(use-modules (ellinika elmorph)
(ellinika i18n)
(ellinika cgi)
(xmltools dict)
(gamma sql))
(use-syntax (ice-9 syncase))
; FIXME:
(ellinika-cgi-init dict-template-file-name)
(define (mk-dict-connect)
(let ((db-connection #f))
(lambda (. rest)
(cond
((null? rest)
(if (not db-connection)
(begin
(set! db-connection
(sql-open-connection
ellinika-sql-connection))
(sql-query db-connection "SET NAMES utf8")
)))
(else
(if db-connection
(sql-close-connection db-connection))
(set! db-connection #f)))
db-connection)))
(define dict-connect (mk-dict-connect))
(define (q-my-sql-query conn query)
(catch #t
(lambda ()
(sql-query conn query))
(lambda args
'())))
(define (my-sql-query conn query)
; (display "Q:")(display query)(newline)
(sql-query conn query))
(define (sql-error-handler key func fmt fmtargs data)
(format #t "
~A
\n"
(_ "ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε."))
(apply format (current-error-port) fmt fmtargs))
(define (guess-verb-info verb)
(let ((elverb (force-elstr verb)))
(cond
;; FIXME
((elstr-suffix? elverb "άω")
(list "B1"
#f
#f
"ησ"
#f
#f))
((elstr-suffix? elverb "ώ")
(list "B2"
#f
#f
"ησ"
#f
#f))
(else
(list "A"
#f
"ε"
#f
#f
#f)))))
(define (get-verb-info verb . rest)
(let ((conn (dict-connect))
(class (if (null? rest)
""
(string-append " AND conj='" (car rest) "'"))))
(let ((vdb (my-sql-query
conn
(string-append
"SELECT conj,accmap,augment,suffix_aor_path FROM verb \
WHERE verb='" (force-string verb) "'"
class))))
(cond
((and vdb (not (null? vdb)))
(let ((x (car vdb)))
(list
(list-ref x 0)
(list-ref x 1)
(or (list-ref x 2) "ε")
(list-ref x 3)
#f
'(class))))
((elstr-suffix? (force-elstr verb) "άω")
(get-verb-info (elstr-append
(elstr-trim (force-elstr verb) -2) "ώ") "B1"))
(else
(guess-verb-info verb))))))
(define (thema-aoristoy-mesapathitikis root)
(cond
((elstr-suffix? root "αίν")
(elstr-append (elstr-trim root -3) "ανθ")) ;; FIXME: Also αθ, ηθ
((and
(elstr-suffix? root "ν")
(logand (elstr-char-prop-bitmask root -2) elmorph:vowel))
(elstr-append (elstr-trim root -1) "θ")) ;; FIXME: also στ, νθ, θ
((and
(elstr-suffix? root "δ" "θ" "ζ" "ν") ;; FIXME: see above
(logand (elstr-char-prop-bitmask root -2) elmorph:vowel))
(elstr-append (elstr-trim root -1) "στ"))
((elstr-suffix? root "γγ" "σσ" "ττ" "χν" "γ" "ζ" "κ" "χ") =>
(lambda (suf)
(elstr-append (elstr-trim root (- 0 (elstr-length (string->elstr suf))))
"χτ"))) ;; also χθ
((elstr-suffix? root "π" "β" "φ" "πτ" "φτ") =>
(lambda (suf)
(elstr-append (elstr-trim root (- 0 (elstr-length (string->elstr suf))))
"φτ"))) ;; also φθ
((elstr-suffix? root "αύ" "εύ") =>
(lambda (suf)
(elstr-append root "τ")))
((elstr-suffix? root "άρ" "ίρ")
((elstr-append root "ιστ")))
((logand (elstr-char-prop-bitmask root -1) elmorph:vowel)
(elstr-append root "θ"))
(else
#f)))
(define (complement-verb-info vinfo verb voice thema)
; (format #t "COMPLEMENT ~S~%" thema)
(let ((elverb (string->elstr verb))
(result (my-sql-query
(dict-connect)
(string-append
"SELECT root FROM irregular_root \
WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'"))))
(verb-info-set! #:root vinfo
(cond
((not (null? result))
(verb-info-set! #:attested vinfo 'root)
(caar result))
((string=? (verb-info #:conj vinfo) "A")
(let ((root (elstr-trim elverb -1)))
(cond
((string=? thema "pres")
(verb-info-set! #:attested vinfo 'root)
root)
((or (string=? thema "aor") (string=? thema "sub"))
(if (string=? voice "act")
(elstr-thema-aoristoy root)
(thema-aoristoy-mesapathitikis root)))
(else
#f))))
((string=? (verb-info #:conj vinfo) "B1")
(let ((root (if (elstr-suffix? elverb "άω")
(elstr-trim elverb -2)
(elstr-trim elverb -1))))
(cond
((or (string=? voice "act") (string=? thema "pres"))
(verb-info-set! #:attested vinfo 'root)
root)
((or (string=? thema "aor") (string=? thema "sub"))
(elstr-append root "ηθ")) ;; FIXME: guesswork
(else
#f))))
((string=? (verb-info #:conj vinfo) "B2")
(let ((root (elstr-trim elverb -1)))
(cond
((or (string=? voice "act") (string=? thema "pres"))
(verb-info-set! #:attested vinfo 'root)
root)
((or (string=? thema "aor") (string=? thema "sub"))
(elstr-append root "ηθ")) ;; FIXME: guesswork
(else
#f))))
(else
#f)))))
(define-syntax verb-info
(syntax-rules ()
((verb-info #:conj v)
(list-ref v 0))
((verb-info #:accmap v)
(list-ref v 1))
((verb-info #:augment v)
(list-ref v 2))
((verb-info #:suffix v)
(list-ref v 3))
((verb-info #:root v)
(list-ref v 4))
((verb-info #:attested v)
(list-ref v 5))))
(define-syntax verb-info-set!
(syntax-rules ()
((verb-info-set! #:root v val)
(list-set! v 4 val))
((verb-info-set! #:attested v val)
(list-set! v 5
(if (not val)
val
(let ((oldval (list-ref v 5)))
(cond
((not oldval)
(list val))
((boolean? oldval)
(list val))
((member val oldval)
oldval)
(else
(cons val oldval)))))))))
(define-syntax conj-info
(syntax-rules ()
((conj-info #:thema v)
(list-ref v 0))
((conj-info #:suffix v)
(list-ref v 1))
((conj-info #:accmap v)
(list-ref v 2))
((conj-info #:particle v)
(list-ref v 3))
((conj-info #:aux v)
(list-ref v 4))
((conj-info #:auxtense v)
(list-ref v 5))
((conj-info #:flect v)
(list-tail v 6))
((conj-info #:sing 1 v)
(list-ref v 7))
((conj-info #:sing 2 v)
(list-ref v 8))
((conj-info #:sing 3 v)
(list-ref v 9))
((conj-info #:plur 1 v)
(list-ref v 10))
((conj-info #:plur 1 v)
(list-ref v 11))
((conj-info #:plur 1 v)
(list-ref v 12))))
(define-syntax conj-info-set!
(syntax-rules ()
((conj-info-set! #:particle v val)
(list-set! v 3 val))))
(define (get-conj-info conj voice mode tense)
(let ((conn (dict-connect)))
(let ((answer (my-sql-query
conn
(string-append
"SELECT c.thema,c.suffix,c.accmap,c.particle,c.aux,c.auxtense,\
f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \
FROM conjugation c, verbflect f \
WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mode='" mode
"' AND c.tense='" tense "' AND c.flect = f.ident"))))
(if (null? answer)
#f
(car answer)))))
(define (force-string str)
(if (elstr? str)
(elstr->string str)
str))
(define (force-elstr str)
(if (string? str)
(string->elstr str)
str))
(define (apply-flect conj vinfo)
(let ((root (verb-info #:root vinfo))
(suffix (let ((s (conj-info #:suffix conj)))
(if s
(or (verb-info #:suffix vinfo) s)
"")))
(accmap (string->list (or (verb-info #:accmap vinfo)
(conj-info #:accmap conj)
"000000")))
(augment ""))
; (format #t "ROOT ~S, ACCMAP ~S~%" root accmap)
(cond
((> (length accmap) 6)
(set! accmap (list-head accmap 6))
(set! augment (verb-info #:augment vinfo))))
(let ((forms
(map
(lambda (flect acc)
(cond
((not flect) #f)
((char=? acc #\0)
(let* ((rs (force-elstr root))
(suf (elstr-deaccent (elstr-append suffix flect)))
(result (elstr-append rs suf)))
(cond
((or (= (elstr-accented-syllable rs) 0)
(> (elstr-number-of-syllables suf) 2))
(let ((nsyl (elstr-number-of-syllables suf)))
(cond
((= nsyl 1)
result)
((= nsyl 3)
(elstr-set-accent result 3))
(else
(elstr-set-accent result 2)))))
(else
result))))
((char=? acc #\f)
(elstr-append
(elstr-deaccent (elstr-append root suffix))
flect))
((char=? acc #\s)
(elstr-append
(elstr-deaccent (force-elstr root))
suffix
(elstr-deaccent (force-elstr flect))))
((char=? acc #\-)
#f)
((char-numeric? acc)
(let ((num (- (char->integer acc) (char->integer #\0))))
(let ((obj (elstr-append root suffix flect)))
(if (and augment (= (+ (elstr-number-of-syllables obj) 1)
num))
(set! obj (elstr-append augment obj)))
(elstr-set-accent! obj num)
obj)))
(else
(error "invalid accent character" acc))))
(conj-info #:flect conj)
accmap)))
(if (conj-info #:particle conj)
(map
(lambda (w)
(if w
(string-append
(conj-info #:particle conj) " " (force-string w))))
forms)
(map force-string forms)))))
(define (individual-verb verb voice mode tense)
(let ((res (my-sql-query
(dict-connect)
(string-append
"SELECT f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \
FROM individual_verb i,verbflect f \
WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mode='" mode
"' AND i.tense = '" tense "' AND i.ident=f.ident"))))
(if (not (null? res))
(append (car res)
(list "I"
'(class root)))
#f)))
(define (conjugate verb voice mode tense . rest)
(cond
((individual-verb verb voice mode tense) =>
(lambda (res)
res))
(else
(let* ((vinfo (get-verb-info verb))
(conj (get-conj-info (verb-info #:conj vinfo) voice mode tense)))
(if (not conj)
(error "cannot obtain conjugation information for "
(verb-info #:conj vinfo) voice mode tense))
(if (member #:nopart rest)
(conj-info-set! #:particle conj #f))
(cond
((string=? (conj-info #:thema conj) "synt")
(let* ((verb-conj (conjugate verb "act" "sub" "Αόριστος" #:nopart))
(form (list-ref verb-conj 2))
(part (conj-info #:particle conj)))
(append
(map
(lambda (aux)
(elstr->string
(if part
(elstr-append part " " aux " " form)
(elstr-append aux " " form))))
(conjugation:table (conjugate (conj-info #:aux conj) "act" "ind"
(conj-info #:auxtense conj))))
(list (verb-info #:conj vinfo)
(conjugation:attested verb-conj)))))
(else
; (format #t "CONJ ~S~%" conj)
(complement-verb-info vinfo verb voice (conj-info #:thema conj))
(append (apply-flect conj vinfo)
(list (verb-info #:conj vinfo)
(verb-info #:attested vinfo)))))))))
(define (conjugation:table conj)
(list-head conj 6))
(define (conjugation:class conj)
(list-ref conj 6))
(define (conjugation:attested conj)
(list-ref conj 7))
(define (empty-conjugation? conj)
(call-with-current-continuation
(lambda (return)
(for-each
(lambda (x)
(if x
(return #f)))
conj)
(return #t))))
;;
;(display (verb-info "βρίσκω"))
;(newline)
;(display (verb-info "ανοίγω"))
;(newline)
(define transtab
'(("act" . "Ενεργητηκή φωνή")
("pas" . "Μεσοπαθητική φωνή")
("ind" . "Οριστική")
("sub" . "Υποτακτική")
("imp" . "Προστακτική")))
(define (term x)
(or (assoc-ref transtab x) x))
(define (test-conjugation verb voice mode tense)
(format #t "~A ~A/~A/~A: " verb (term voice) (term mode) tense)
(let* ((result (conjugate verb voice mode tense))
(conj (conjugation:table result)))
(cond
((empty-conjugation? conj)
(display "#f"))
(else
(let ((att (conjugation:attested result)))
(cond
((not att)
(display "*"))
(else
(if (not (member 'class att))
(display "*"))
(if (not (member 'root att))
(display "!"))))
(display conj)))))
(newline)
(gc))
(test-conjugation "είμαι" "act" "ind" "Ενεστώτας")
(test-conjugation "είμαι" "act" "ind" "Παρατατίκος")
(test-conjugation "είμαι" "act" "ind" "Μέλλοντας διαρκείας")
(test-conjugation "είμαι" "act" "sub" "Ενεστώτας")
(test-conjugation "είμαι" "act" "imp" "Ενεστώτας")
(test-conjugation "είμαι" "act" "ind" "Αόριστος")
(test-conjugation "έχω" "act" "ind" "Ενεστώτας")
(test-conjugation "έχω" "act" "ind" "Παρατατίκος")
(test-conjugation "έχω" "act" "ind" "Μέλλοντας διαρκείας")
(test-conjugation "έχω" "act" "sub" "Ενεστώτας")
(test-conjugation "έχω" "act" "imp" "Ενεστώτας")
(test-conjugation "έχω" "act" "imp" "Αόριστος")
(test-conjugation "ανοίγω" "act" "ind" "Ενεστώτας")
(test-conjugation "ανοίγω" "act" "ind" "Αόριστος")
(test-conjugation "ανοίγω" "pas" "ind" "Αόριστος")
(test-conjugation "δένω" "act" "ind" "Αόριστος")
(test-conjugation "θέλω" "act" "ind" "Αόριστος")
(test-conjugation "θέλω" "act" "ind" "Παρατατικός")
(test-conjugation "βρίσκω" "act" "ind" "Ενεστώτας")
(test-conjugation "βρίσκω" "act" "ind" "Αόριστος")
(test-conjugation "βρίσκω" "act" "ind" "Μέλλοντας στιγμιαίος")
(test-conjugation "βρίσκω" "pas" "ind" "Αόριστος")
(test-conjugation "βρίσκω" "act" "sub" "Ενεστώτας")
(test-conjugation "βρίσκω" "act" "sub" "Αόριστος")
(test-conjugation "βρίσκω" "act" "ind" "Παρακείμενος")
(test-conjugation "βρίσκω" "act" "sub" "Παρακείμενος")
(test-conjugation "βρίσκω" "act" "imp" "Αόριστος")
(test-conjugation "νικάω" "act" "ind" "Ενεστώτας")
(test-conjugation "νικάω" "act" "ind" "Αόριστος")
(test-conjugation "νικώ" "act" "ind" "Ενεστώτας")
(test-conjugation "νικώ" "act" "ind" "Αόριστος")
(test-conjugation "νικώ" "pas" "ind" "Αόριστος")
(test-conjugation "κρεμάω" "act" "ind" "Αόριστος")
(test-conjugation "κιτάω" "act" "ind" "Αόριστος")
(test-conjugation "τραβάω" "act" "ind" "Αόριστος")
(newline)