aboutsummaryrefslogtreecommitdiff
path: root/scm/conj.scm
diff options
context:
space:
mode:
Diffstat (limited to 'scm/conj.scm')
-rw-r--r--scm/conj.scm335
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)
-
-

Return to:

Send suggestions and report system problems to the System administrator.