aboutsummaryrefslogtreecommitdiff
path: root/scm
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2004-06-11 13:49:26 +0000
committerSergey Poznyakoff <gray@gnu.org.ua>2004-06-11 13:49:26 +0000
commitdd46d0f4d2884e66a98a5444fa384e65af25ab7c (patch)
treed3d44a812c0b904f1c859675bd7fc1be42b16057 /scm
parent9efa28af3c0ba603a8b0e296088211b16d03fecb (diff)
downloadellinika-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.scm159
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)
+
+
+
+
+
+
+
+
+
+

Return to:

Send suggestions and report system problems to the System administrator.