diff options
Diffstat (limited to 'scm/conj.scm')
-rw-r--r-- | scm/conj.scm | 335 |
1 files changed, 0 insertions, 335 deletions
diff --git a/scm/conj.scm b/scm/conj.scm deleted file mode 100644 index 3c2e96a..0000000 --- a/scm/conj.scm +++ /dev/null @@ -1,335 +0,0 @@ -(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) - - |