From e289283447fac165757b37f7e145cf51ebda17b1 Mon Sep 17 00:00:00 2001 From: Sergey Poznyakoff Date: Sun, 13 Jun 2004 16:57:40 +0000 Subject: Updated git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@122 941c8c0f-9102-463b-b60b-cd22ce0e6858 --- scm/conj.scm | 274 +++++++++++++++++++++++++++++++++++++++++++++-------------- scm/xlat.scm | 23 +++-- 2 files changed, 220 insertions(+), 77 deletions(-) (limited to 'scm') 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) diff --git a/scm/xlat.scm b/scm/xlat.scm index 7548e54..37028b3 100644 --- a/scm/xlat.scm +++ b/scm/xlat.scm @@ -101,7 +101,7 @@ (cons "Ϋ" #\Y ) (cons "ΰ" (cons #\Y #t)))) -(define (greek->xlat0 str) +(define-public (greek->xlat0 str) "Convert the greek STRing into its latin transliteration. Returns (list AP XLAT) @@ -116,9 +116,8 @@ Secondary accents are ignored" (lcnt 0 (1+ lcnt)) (sl '())) ((= i len) (cons - (if accent-pos - (- (length sl) accent-pos 1) - 0) + (and accent-pos + (- (length sl) accent-pos 1)) (reverse sl))) (letrec ((get-trans (lambda (x) (let ((y (cdr x))) @@ -225,7 +224,7 @@ Secondary accents are ignored" (set! wl (cdr wl)) (set! syl (cons a syl)) (cond - ((= ap (length wl)) + ((and ap (= ap (length wl))) (set! accented (length sl))) (else (case a @@ -235,7 +234,7 @@ Secondary accents are ignored" (or (char=? (car wl) #\i) (char=? (car wl) #\y))) (set! syl (cons (car wl) syl)) (set! wl (cdr wl)) - (if (= ap (length wl)) + (if (and ap (= ap (length wl))) (set! accented (length sl)))))) ((#\i) (if (not (null? wl)) @@ -244,19 +243,19 @@ Secondary accents are ignored" (char=? (car wl) #\a)) (set! syl (cons (car wl) syl)) (set! wl (cdr wl)) - (if (= ap (length wl)) + (if (and ap (= ap (length wl))) (set! accented (length sl)))) ((char=? (car wl) #\o) ;; "ιο" ή "ιου" (set! syl (cons (car wl) syl)) (set! wl (cdr wl)) (cond - ((= ap (length wl)) + ((and ap (= ap (length wl))) (set! accented (length sl))) ((and (not (null? wl)) (char=? (car wl) #\y)) (set! syl (cons (car wl) syl)) (set! wl (cdr wl)) - (if (= ap (length wl)) + (if (and ap (= ap (length wl))) (set! accented (length sl))))))))) ((#\y) (cond @@ -264,7 +263,7 @@ Secondary accents are ignored" (char=? (car wl) #\i)) (set! syl (cons (car wl) syl)) (set! wl (cdr wl)) - (if (= ap (length wl)) + (if (and ap (= ap (length wl))) (set! accented (length sl)))))) ((#\Y #\I) (set! accented (length sl)))))) @@ -273,9 +272,9 @@ Secondary accents are ignored" (define-public (greek->xlat str) (let* ((wl (greek->xlat0 str)) - (sl (prosodia (car wl) (cdr wl) 0 '()))) + (sl (prosodia (car wl) (cdr wl) #f '()))) (cons - (- (length (cdr sl)) (car sl)) + (and (car sl) (- (length (cdr sl)) (car sl))) (cdr sl)))) ;;;; End of file \ No newline at end of file -- cgit v1.2.1