diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2004-06-11 13:49:26 +0000 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2004-06-11 13:49:26 +0000 |
commit | dd46d0f4d2884e66a98a5444fa384e65af25ab7c (patch) | |
tree | d3d44a812c0b904f1c859675bd7fc1be42b16057 /scm | |
parent | 9efa28af3c0ba603a8b0e296088211b16d03fecb (diff) | |
download | ellinika-dd46d0f4d2884e66a98a5444fa384e65af25ab7c.tar.gz ellinika-dd46d0f4d2884e66a98a5444fa384e65af25ab7c.tar.bz2 |
conjugator
git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@110 941c8c0f-9102-463b-b60b-cd22ce0e6858
Diffstat (limited to 'scm')
-rw-r--r-- | scm/conj.scm | 159 |
1 files changed, 159 insertions, 0 deletions
diff --git a/scm/conj.scm b/scm/conj.scm new file mode 100644 index 0000000..6c3d604 --- /dev/null +++ b/scm/conj.scm @@ -0,0 +1,159 @@ +(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 #\* (cddr 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 (if (car flect) + (car flect) + (+ (car word) (length (cdr flect)))))) + (cons + (if (> 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))) + +(define verbal-flect-table + (list + (cons "Α" + (list + (cons "ενεργητηκή" + (list + (cons "οριστική" + (list + (cons "ενεστώτας" + (flect-list #f + (list "ω") + (list "εις") + (list "ει") + (list "ουμε") + (list "ετε") + (list "ουν" "ουνε"))) + (cons "παρατατικός" + (flect-list (lambda (x flect) + (shift-accent + (add-flection x flect))) + (list "α") + (list "ες") + (list "ε") + (list "αμε") + (list "ατε") + (list "αν" "ανε"))) + (cons "μέλλοντας διαρκείας" + (flect-list (lambda (x) + (list "θα" x)) + (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 (or (car tab) + add-flection))) + (map + (lambda (x) + (func root x)) + (list-ref tab pers))))) + + +(do ((i 1 (1+ i))) + ((> i 6) #f) + (map + (lambda (x) + (display (xlat->greek x))(display ",")) + (conjugate (greek->xlat "βεβαίων") + i "Α" "ενεργητηκή" "οριστική" "ενεστώτας")) + (newline)) +(newline) + + + + + + + + + + |