(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)