(use-modules (xlat)) (define (active-aorist-root present-root) (let ((last-syllable (car present-root))) (case (car last-syllable) ((#\@) (set-car! last-syllable #\s)) ((#\z) (set-car! last-syllable #\s)) ;; FIXME: not always ((#\k) (cond ((and (not (null? (cdr last-syllable))) (char=? (cadr last-syllable) #\s)) (set! last-syllable (cons #\x (cddr last-syllable)))) (else (set-car! last-syllable #\x)))) ((#\n) (cond ((and (not (null? (cdr last-syllable))) (char=? (cadr last-syllable) #\h)) (set! last-syllable (cons #\x (cddr last-syllable)))) (else (set-car! last-syllable #\s)))) ((#\g #\h) (set-car! last-syllable #\x)) ((#\p #\b #\f) (set-car! last-syllable #\*)) ((#\y) (cond ((and (not (null? (cdr last-syllable))) (or (char=? (cadr last-syllable) #\a) (char=? (cadr last-syllable) #\e))) (set! last-syllable (cons #\* (cdr last-syllable)))))) (else (throw 'grammar "Dont't know how to handle " present-root))) (cons last-syllable (cdr present-root)))) (define (aor str) (active-aorist-root (cdr (greek-normalize str)))) (define (add-flection word flect) (let* ((syl-list (append (cdr flect) (cdr word))) (acc-pos (or (car flect) (and (car word) (+ (car word) (length (cdr flect))))))) (cons (if (and acc-pos (> acc-pos 3)) 3 acc-pos) syl-list))) ; FIXME: Should return real augment! (define (get-augment root) #\e) ; FIXME: Does not handle verbs with internal augment (define (create-paratatikos-A root flect) (let ((word (add-flection root flect))) (cons 3 (if (< (length (cdr word)) 3) (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 "Α" (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-A #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 "Β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) table (let ((entry (assoc (car form-list) table))) (if entry (verbal-flect-table-lookup (cdr entry) (cdr form-list)) #f)))) (define (find-verbal-form . rest) (verbal-flect-table-lookup verbal-flect-table rest)) (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 (vtab-composer tab)) (root-selector (vtab-root tab))) (map (lambda (x) (func root x)) (vtab-flection tab pers))))) (define (conjugate-v root pers . forms) (conjugate root pers forms)) ;; Test (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))) ;(conj-all "βεβαίων" "Α" "ενεργητηκή" "οριστική" "ενεστώτας") ;(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)