aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2011-06-05 11:17:15 +0300
committerSergey Poznyakoff <gray@gnu.org.ua>2011-06-05 11:17:15 +0300
commit618724bfda07dfb1f8b61212da8f43e2eace95ba (patch)
tree51de57587f931926b881fd12b59a62ff62c5e66f
parent7087cd30afbb6f15c55b8adbc270776f35d4fefb (diff)
downloadellinika-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.scm259
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)

Return to:

Send suggestions and report system problems to the System administrator.