diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2011-06-05 11:17:15 +0300 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2011-06-05 11:17:15 +0300 |
commit | 618724bfda07dfb1f8b61212da8f43e2eace95ba (patch) | |
tree | 51de57587f931926b881fd12b59a62ff62c5e66f | |
parent | 7087cd30afbb6f15c55b8adbc270776f35d4fefb (diff) | |
download | ellinika-618724bfda07dfb1f8b61212da8f43e2eace95ba.tar.gz ellinika-618724bfda07dfb1f8b61212da8f43e2eace95ba.tar.bz2 |
Add test version of verb conjugator.
* db.struct: Update.
* src/ellinika/elmorph.c (_elstr_syllabize): If there is
no accented syllable, set acc_syl to 0.
* scm/conjugator.scm: New file.
-rw-r--r-- | scm/conjugator.scm | 259 |
1 files changed, 259 insertions, 0 deletions
diff --git a/scm/conjugator.scm b/scm/conjugator.scm new file mode 100644 index 0000000..19642b3 --- /dev/null +++ b/scm/conjugator.scm @@ -0,0 +1,259 @@ +(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 "<h1 class=\"error\">~A</h1>\n" + (_ "ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε.")) + (apply format (current-error-port) fmt fmtargs)) + +(define (guess-verb-info verb) + (let ((elverb (string->elstr verb))) + (cond + (else + (let ((root (elstr-trim elverb -1))) + (list "A" + "ε" + (list + (cons "pres" root) + (cons "aor" (elstr-thema-aoristoy root)) + (cons "pass" root)))))))) + +(define (get-verb-info verb) + (let ((conn (dict-connect))) + (let ((vdb (my-sql-query + conn + (string-append + "SELECT conj,augment,present,aorist,pass FROM verb WHERE word='" + verb + "'")))) + (if (null? vdb) + (guess-verb-info verb) + (let ((x (car vdb))) + (list + (car x) + (or (list-ref x 1) "ε") + (list + (cons "pres" (list-ref x 2)) + (cons "aor" (list-ref x 3)) + (cons "pass" (list-ref x 4))))))))) + +(define-syntax verb-info + (syntax-rules () + ((verb-info #:conj v) + (list-ref v 0)) + ((verb-info #:augment v) + (list-ref v 1)) + ((verb-info #:root v) + (list-ref v 2)))) + +(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 (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 (force-accent str) + (if (and str (= (elstr-accented-syllable str) 0)) + (let ((nsyl (elstr-number-of-syllables str))) + (cond + ((= nsyl 1) + str) + (else + (elstr-set-accent str 2)))) + str)) + +(define (apply-flect root conj vinfo) + (let ((suffix (or (conj-info #:suffix conj) "")) + (accmap (string->list (or (conj-info #:accmap conj) "000000"))) + (augment "")) + (cond + ((> (length accmap) 6) + (set! accmap (list-head accmap 6)) + (set! augment (verb-info #:augment vinfo)))) + (let ((forms + (map + (lambda (flect acc) + (cond + ((char=? acc #\0) + (force-accent + (elstr-append + root + (elstr-deaccent (elstr-append suffix flect))))) + ((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) + forms)))) + +(define (conjugate verb voice mode tense . rest) + (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) + (list-set! conj 3 #f)) + (cond + ((string=? (conj-info #:thema conj) "synt") + (let ((form (list-ref + (conjugate verb "act" "sub" "Ενεστώτας" #:nopart) 2)) + (part (conj-info #:particle conj))) + (map + (lambda (aux) + (elstr->string + (if part + (elstr-append part " " aux " " form) + (elstr-append aux " " form)))) + (conjugate (conj-info #:aux conj) "act" "ind" + (conj-info #:auxtense conj))) )) + (else + (let ((root #f) + (exception (my-sql-query + (dict-connect) + (string-append + "SELECT root,accmap FROM irregular_verb \ +WHERE word='" verb "' AND voice='" voice "' AND tense='" tense "'")))) + (if (not (null? exception)) + (let ((x (car exception))) + (set! root (list-ref x 0)) + (let ((accmap (list-ref x 1))) + (if accmap + (list-set! conj 2 accmap)))) + (set! root (assoc-ref (verb-info #:root vinfo) + (conj-info #:thema conj)))) + (apply-flect root conj vinfo)))))) + +;; +;(display (verb-info "βρίσκω")) +;(newline) +;(display (verb-info "ανοίγω")) +;(newline) + +;(display (conjugate "έχω" "act" "ind" "Ενεστώτας")) +;(display (conjugate "ανοίγω" "act" "ind" "Ενεστώτας")) +;(display (conjugate "ανοίγω" "act" "ind" "Αόριστος")) +;(display (conjugate "δένω" "act" "ind" "Αόριστος")) +;(display (conjugate "βρίσκω" "act" "ind" "Ενεστώτας")) +;(display (conjugate "βρίσκω" "act" "ind" "Αόριστος")) +;(display (conjugate "βρίσκω" "act" "ind" "Μέλλοντας στιγμιαίος")) +;(display (conjugate "βρίσκω" "pas" "ind" "Αόριστος")) +;(display (conjugate "θέλω" "act" "ind" "Αόριστος")) +;(display (conjugate "θέλω" "act" "ind" "Παρατατικός")) +;(display (conjugate "βρίσκω" "act" "ind" "Παρακείμενος")) +;(display (conjugate "βρίσκω" "act" "sub" "Παρακείμενος")) +;(display (conjugate "βρίσκω" "act" "sub" "Ενεστώτας")) +(display (conjugate "βρίσκω" "act" "sub" "Αόριστος")) +(newline) |