aboutsummaryrefslogtreecommitdiff
path: root/scm/conj.scm
diff options
context:
space:
mode:
Diffstat (limited to 'scm/conj.scm')
-rw-r--r--scm/conj.scm274
1 files changed, 209 insertions, 65 deletions
diff --git a/scm/conj.scm b/scm/conj.scm
index 781d630..3c2e96a 100644
--- a/scm/conj.scm
+++ b/scm/conj.scm
@@ -30,7 +30,7 @@
((and (not (null? (cdr last-syllable)))
(or (char=? (cadr last-syllable) #\a)
(char=? (cadr last-syllable) #\e)))
- (set! last-syllable (cons #\* (cddr last-syllable))))))
+ (set! last-syllable (cons #\* (cdr last-syllable))))))
(else
(throw 'grammar "Dont't know how to handle " present-root)))
(cons last-syllable (cdr present-root))))
@@ -42,26 +42,15 @@
(define (add-flection word flect)
(let* ((syl-list (append (cdr flect) (cdr word)))
- (acc-pos (if (car flect)
- (car flect)
- (+ (car word) (length (cdr flect))))))
+ (acc-pos (or (car flect)
+ (and (car word)
+ (+ (car word) (length (cdr flect)))))))
(cons
- (if (> acc-pos 3)
+ (if (and acc-pos (> acc-pos 3))
3
acc-pos)
syl-list)))
-(define (flect-list fun . p)
- (cons
- fun
- (map
- (lambda (pers)
- (map
- (lambda (f)
- (cons #f (cdr (greek->xlat f))))
- pers))
- p)))
-
; FIXME: Should return real augment!
(define (get-augment root)
#\e)
@@ -74,6 +63,50 @@
(append (cdr word) (list (list (get-augment root))))
(cdr word)))))
+(define (create-paratatikos-B root flect)
+ (add-flection root (add-flection (greek->xlat "ούσ")
+ (cons
+ #f
+ (cdr flect)))))
+
+(define (create-prostaktiki-enestota root flect)
+ (let ((w (add-flection root flect)))
+ (cond
+ ((car flect)
+ (cons (car flect) (cdr w)))
+ ((>= (length (cdr w)) 3)
+ (cons 3 (cdr w)))
+ ((not (car w))
+ (cons (length (cdr w)) (cdr w)))
+ (else
+ w))))
+
+;; Verbal form Accessors
+(define (vtab-root tab)
+ (car tab))
+
+(define (vtab-analizer tab)
+ (list-ref tab 2))
+
+(define (vtab-composer tab)
+ (or (list-ref tab 1)
+ add-flection))
+
+(define (vtab-flection tab person)
+ (list-ref tab (+ person 2)))
+
+;;
+(define (flect-list root composer analizer . p)
+ (append
+ (list root composer analizer)
+ (map
+ (lambda (pers)
+ (map
+ greek->xlat
+ pers))
+ p)))
+
+;;
(define verbal-flect-table
(list
(cons "Α"
@@ -84,6 +117,8 @@
(list
(cons "ενεστώτας"
(flect-list
+ #:present-root
+ #f
#f
(list "ω")
(list "εις")
@@ -93,7 +128,9 @@
(list "ουν" "ουνε")))
(cons "παρατατικός"
(flect-list
+ #:present-root
create-paratatikos-A
+ #f
(list "α")
(list "ες")
(list "ε")
@@ -102,30 +139,121 @@
(list "αν" "ανε")))
(cons "μέλλοντας διαρκείας"
(flect-list
- (lambda (x)
- (list "θα" x))
+ #:present-root
+ #f ;; FIXME: "θα"
+ #f
(list "ω")
(list "εις")
(list "ει")
(list "ουμε")
(list "ετε")
- (list "ουν" "ουνε")))))))))))
-
+ (list "ουν" "ουνε")))))
-;; ("άω")
-;; ("άς")
-;; ("ά" "άει")
-;; ("άμε")
-;; ("άτε")
-;; ("ούν" "ούνε")
-;;
-;; ("ώ")
-;; ("είς")
-;; ("εί")
-;; ("ούμε")
-;; ("είτε")
-;; ("ούν" "ούνε")
+ (cons "προστακτική"
+ (list
+ (cons "ενεστώτας"
+ (flect-list
+ #:present-root
+ create-prostaktiki-enestota
+ #f
+ '()
+ (list "ε")
+ '()
+ '()
+ (list "ετε")
+ '())))) ))))
+ (cons "Β1"
+ (list
+ (cons "ενεργητηκή"
+ (list
+ (cons "οριστική"
+ (list
+ (cons "ενεστώτας"
+ (flect-list
+ #:present-root
+ #f
+ #f
+ (list "άω")
+ (list "άς")
+ (list "ά" "άει")
+ (list "άμε")
+ (list "άτε")
+ (list "ούν" "ούνε")))
+ (cons "παρατατικός"
+ (flect-list
+ #:present-root
+ create-paratatikos-B
+ #f
+ (list "α")
+ (list "ες")
+ (list "ε")
+ (list "αμε")
+ (list "ατε")
+ (list "αν" "ανε")))
+ (cons "μέλλοντας διαρκείας"
+ (flect-list
+ #:present-root
+ #f ;; FIXME: "θα"
+ #f
+ (list "άω")
+ (list "άς")
+ (list "ά" "άει")
+ (list "άμε")
+ (list "άτε")
+ (list "ούν" "ούνε"))) ))
+ (cons "προστακτική"
+ (list
+ (cons "ενεστώτας"
+ (flect-list
+ #:present-root
+ create-prostaktiki-enestota
+ #f
+ '()
+ (list "α")
+ '()
+ '()
+ (list "άτε")
+ '())))) ))))
+ (cons "Β2"
+ (list
+ (cons "ενεργητηκή"
+ (list
+ (cons "οριστική"
+ (list
+ (cons "ενεστώτας"
+ (flect-list
+ #:present-root
+ #f
+ #f
+ (list "ώ")
+ (list "είς")
+ (list "εί")
+ (list "ούμε")
+ (list "είτε")
+ (list "ούν" "ούνε")))
+ (cons "παρατατικός"
+ (flect-list
+ #:present-root
+ create-paratatikos-B
+ #f
+ (list "α")
+ (list "ες")
+ (list "ε")
+ (list "αμε")
+ (list "ατε")
+ (list "αν" "ανε")))
+ (cons "μέλλοντας διαρκείας"
+ (flect-list
+ #:present-root
+ #f ;; FIXME: "θα"
+ #f
+ (list "ώ")
+ (list "είς")
+ (list "εί")
+ (list "ούμε")
+ (list "είτε")
+ (list "ούν" "ούνε"))) ))))))))
(define (verbal-flect-table-lookup table form-list)
(if (null? form-list)
@@ -139,53 +267,69 @@
(verbal-flect-table-lookup verbal-flect-table rest))
-(define (conjugate root pers . forms)
+(define (conjugate root pers forms)
(let ((tab (verbal-flect-table-lookup verbal-flect-table forms)))
(if (not tab)
(throw 'grammar "Verbal form not found " forms))
- (let ((func (or (car tab)
- add-flection)))
+ (let ((func (vtab-composer tab))
+ (root-selector (vtab-root tab)))
+
(map
(lambda (x)
(func root x))
- (list-ref tab pers)))))
+ (vtab-flection tab pers)))))
+(define (conjugate-v root pers . forms)
+ (conjugate root pers forms))
+
+;; Test
-(do ((i 1 (1+ i)))
- ((> i 6) #f)
- (map
- (lambda (x)
- (display (xlat->greek x))(display ","))
- (conjugate (greek->xlat "βεβαίων")
- i "Α" "ενεργητηκή" "οριστική" "ενεστώτας"))
- (newline))
-(newline)
+(define (conj-all root . rest)
+ (map (lambda (x)
+ (display x)(display "/"))
+ rest)
+ (newline)
+ (do ((i 1 (1+ i)))
+ ((> i 6) #f)
+ (map
+ (lambda (x)
+ (display (xlat->greek x))(display ","))
+ (conjugate (greek->xlat root) i rest))
+ (newline)))
+
-(do ((i 1 (1+ i)))
- ((> i 6) #f)
- (map
- (lambda (x)
- (display (xlat->greek x))(display ","))
- (conjugate (greek->xlat "βεβαίων")
- i "Α" "ενεργητηκή" "οριστική" "παρατατικός"))
- (newline))
-(newline)
+;(conj-all "βεβαίων" "Α" "ενεργητηκή" "οριστική" "ενεστώτας")
+;(newline)
-(do ((i 1 (1+ i)))
- ((> i 6) #f)
- (map
- (lambda (x)
- (display (xlat->greek x))(display ","))
- (conjugate (greek->xlat "λύν")
- i "Α" "ενεργητηκή" "οριστική" "παρατατικός"))
- (newline))
+;(conj-all "βεβαίων" "Α" "ενεργητηκή" "οριστική" "παρατατικός")
+;(newline)
+;(conj-all "ντυν" "Α" "ενεργητηκή" "προστακτική" "ενεστώτας")
+;(newline)
+;(conj-all "βεβαίων" "Α" "ενεργητηκή" "προστακτική" "ενεστώτας")
+;(newline)
+;(conj-all "διαβάζ" "Α" "ενεργητηκή" "προστακτική" "ενεστώτας")
+;(newline)
+;(conj-all "λύν" "Α" "ενεργητηκή" "οριστική" "παρατατικός")
+;(newline)
+;(conj-all "νικ" "Β1" "ενεργητηκή" "οριστική" "ενεστώτας")
+;(newline)
+;(conj-all "νικ" "Β1" "ενεργητηκή" "οριστική" "παρατατικός")
+;(newline)
+;(conj-all "νικ" "Β1" "ενεργητηκή" "προστακτική" "ενεστώτας")
+;(newline)
+
+;(conj-all "θεωρ" "Β2" "ενεργητηκή" "οριστική" "ενεστώτας")
+;(newline)
-
-
+;(conj-all "θεωρ" "Β2" "ενεργητηκή" "οριστική" "παρατατικός")
+;(newline)
+
+;(display (xlat->greek (cons #f (active-aorist-root (cdr (greek->xlat "ιατρευ"))))))
+;(newline)

Return to:

Send suggestions and report system problems to the System administrator.

Generated by cgit.