summaryrefslogtreecommitdiffabout
path: root/src/ellinika
authorSergey Poznyakoff <gray@gnu.org.ua>2011-06-12 00:29:59 (GMT)
committer Sergey Poznyakoff <gray@gnu.org.ua>2011-06-12 00:29:59 (GMT)
commita9fa703eecfc81b26c1d969cc13a7ce476c84d6d (patch) (unidiff)
treebf0ff5fc9740378b37c23df3ad1fa369c4a9e787 /src/ellinika
parent246974441fb5dc155260c273c61757cbc90469a8 (diff)
downloadellinika-a9fa703eecfc81b26c1d969cc13a7ce476c84d6d.tar.gz
ellinika-a9fa703eecfc81b26c1d969cc13a7ce476c84d6d.tar.bz2
Convert src/ellinika/conjugator.scm to module.
Diffstat (limited to 'src/ellinika') (more/less context) (ignore whitespace changes)
-rw-r--r--src/ellinika/conjugator.scm258
1 files changed, 55 insertions, 203 deletions
diff --git a/src/ellinika/conjugator.scm b/src/ellinika/conjugator.scm
index edc649e..c8fd012 100644
--- a/src/ellinika/conjugator.scm
+++ b/src/ellinika/conjugator.scm
@@ -1,55 +1,36 @@
1;;;; Modern Greek Verb Conjugator.
2;;;; This file is part of Ellinika project.
3;;;; Copyright (C) 2011 Sergey Poznyakoff
4;;;;
5;;;; Ellinika is free software; you can redistribute it and/or modify
6;;;; it under the terms of the GNU General Public License as published by
7;;;; the Free Software Foundation; either version 3 of the License, or
8;;;; (at your option) any later version.
9;;;;
10;;;; Ellinika is distributed in the hope that it will be useful,
11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13;;;; GNU General Public License for more details.
14;;;;
15;;;; You should have received a copy of the GNU General Public License
16;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
17
18(define-module (ellinika conjugator))
19
1(use-modules (srfi srfi-1) 20(use-modules (srfi srfi-1)
2 (ellinika elmorph) 21 (ellinika elmorph)
3 (ellinika i18n) 22 (ellinika i18n)
4 (ellinika cgi)
5 (ellinika tenses) 23 (ellinika tenses)
6 (xmltools dict)
7 (gamma sql)) 24 (gamma sql))
8 25
9(use-syntax (ice-9 syncase)) 26(use-syntax (ice-9 syncase))
10 27
11; FIXME:
12(ellinika-cgi-init dict-template-file-name)
13
14(define (mk-dict-connect)
15 (let ((db-connection #f))
16 (lambda (. rest)
17 (cond
18 ((null? rest)
19 (if (not db-connection)
20 (begin
21 (set! db-connection
22 (sql-open-connection
23 ellinika-sql-connection))
24 (sql-query db-connection "SET NAMES utf8")
25 )))
26 (else
27 (if db-connection
28 (sql-close-connection db-connection))
29 (set! db-connection #f)))
30 db-connection)))
31
32(define dict-connect (mk-dict-connect))
33
34(define (q-my-sql-query conn query)
35 (catch #t
36 (lambda ()
37 (sql-query conn query))
38 (lambda args
39 '())))
40
41(define (my-sql-query conn query) 28(define (my-sql-query conn query)
42; (format #t "Q: ~A~%" query) 29; (format #t "Q: ~A~%" query)
43 (let ((res (sql-query conn query))) 30 (let ((res (sql-query conn query)))
44; (format #t "R: ~A~%" res) 31; (format #t "R: ~A~%" res)
45 res)) 32 res))
46 33
47
48(define (sql-error-handler key func fmt fmtargs data)
49 (format #t "<h1 class=\"error\">~A</h1>\n"
50 (_ "ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε."))
51 (apply format (current-error-port) fmt fmtargs))
52
53(define verb-info-template 34(define verb-info-template
54 (list 35 (list
55 (list "A" 36 (list "A"
@@ -82,9 +63,8 @@
82 (else 63 (else
83 (assoc "A" verb-info-template)))) 64 (assoc "A" verb-info-template))))
84 65
85(define (get-verb-info verb . rest) 66(define (get-verb-info conn verb . rest)
86 (let ((conn (dict-connect)) 67 (let ((class (if (null? rest)
87 (class (if (null? rest)
88 "" 68 ""
89 (string-append " AND conj='" (car rest) "'")))) 69 (string-append " AND conj='" (car rest) "'"))))
90 (let ((vdb (my-sql-query 70 (let ((vdb (my-sql-query
@@ -104,7 +84,7 @@ WHERE verb='" (force-string verb) "'"
104 #f 84 #f
105 '(class)))) 85 '(class))))
106 ((elstr-suffix? verb "άω") 86 ((elstr-suffix? verb "άω")
107 (get-verb-info (elstr-append 87 (get-verb-info conn (elstr-append
108 (elstr-trim verb -2) "ώ") "B1")) 88 (elstr-trim verb -2) "ώ") "B1"))
109 ((null? rest) 89 ((null? rest)
110 (guess-verb-info verb)) 90 (guess-verb-info verb))
@@ -141,9 +121,9 @@ WHERE verb='" (force-string verb) "'"
141 (else 121 (else
142 #f))) 122 #f)))
143 123
144(define (lookup-verb-info verb voice thema) 124(define (lookup-verb-info conn verb voice thema)
145 (my-sql-query 125 (my-sql-query
146 (dict-connect) 126 conn
147 (string-append 127 (string-append
148 "SELECT root FROM irregular_root \ 128 "SELECT root FROM irregular_root \
149WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'"))) 129WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'")))
@@ -157,12 +137,12 @@ WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'")))
157 (else 137 (else
158 (error "cannot handle ~A~%" verb)))) 138 (error "cannot handle ~A~%" verb))))
159 139
160(define (complement-verb-info vinfo verb voice thema) 140(define (complement-verb-info conn vinfo verb voice thema)
161; (format #t "COMPLEMENT ~A~%" thema) 141; (format #t "COMPLEMENT ~A~%" thema)
162 (let ((elverb (string->elstr verb)) 142 (let ((elverb (string->elstr verb))
163 (result (let ((tmpres (lookup-verb-info verb voice thema))) 143 (result (let ((tmpres (lookup-verb-info conn verb voice thema)))
164 (if (and (null? tmpres) (string=? thema "sub")) 144 (if (and (null? tmpres) (string=? thema "sub"))
165 (lookup-verb-info verb voice "aor") 145 (lookup-verb-info conn verb voice "aor")
166 tmpres)))) 146 tmpres))))
167 (verb-info-set! #:root vinfo 147 (verb-info-set! #:root vinfo
168 (cond 148 (cond
@@ -286,19 +266,18 @@ WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'")))
286 ((conj-info-set! #:particle v val) 266 ((conj-info-set! #:particle v val)
287 (list-set! v 3 val)))) 267 (list-set! v 3 val))))
288 268
289(define (get-conj-info conj voice mood tense) 269(define (get-conj-info conn conj voice mood tense)
290 (let ((conn (dict-connect))) 270 (let ((answer (my-sql-query
291 (let ((answer (my-sql-query 271 conn
292 conn 272 (string-append
293 (string-append
294 "SELECT c.thema,c.suffix,c.accmap,c.particle,c.aux,c.auxtense,c.fold AS fold,\ 273 "SELECT c.thema,c.suffix,c.accmap,c.particle,c.aux,c.auxtense,c.fold AS fold,\
295f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \ 274f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \
296FROM conjugation c, verbflect f \ 275FROM conjugation c, verbflect f \
297WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mood='" mood 276WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mood='" mood
298"' AND c.tense='" tense "' AND c.flect = f.ident ORDER by fold")))) 277"' AND c.tense='" tense "' AND c.flect = f.ident ORDER by fold"))))
299 (if (null? answer) 278 (if (null? answer)
300 #f 279 #f
301 answer)))) 280 answer)))
302 281
303(define (force-string str) 282(define (force-string str)
304 (if (elstr? str) 283 (if (elstr? str)
@@ -392,9 +371,9 @@ WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mood='" mood
392 forms) 371 forms)
393 (map force-string forms))))) 372 (map force-string forms)))))
394 373
395(define (individual-verb verb voice mood tense) 374(define (individual-verb conn verb voice mood tense)
396 (let ((res (my-sql-query 375 (let ((res (my-sql-query
397 (dict-connect) 376 conn
398 (string-append 377 (string-append
399 "SELECT f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \ 378 "SELECT f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \
400FROM individual_verb i,verbflect f \ 379FROM individual_verb i,verbflect f \
@@ -412,16 +391,17 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mood='" mood
412 (or a b)) 391 (or a b))
413 lista listb)) 392 lista listb))
414 393
415(define (conjugate verb voice mood tense . rest) 394(define (conjugate conn verb voice mood tense . rest)
416 (cond 395 (cond
417 ((individual-verb verb voice mood tense) => 396 ((individual-verb conn verb voice mood tense) =>
418 (lambda (res) 397 (lambda (res)
419 (list res))) 398 (list res)))
420 (else 399 (else
421 (map car 400 (map car
422 (let* ((vinfo (get-verb-info verb)) 401 (let* ((vinfo (get-verb-info conn verb))
423 (conj-list (get-conj-info (verb-info #:conj vinfo) voice mood 402 (conj-list (get-conj-info conn
424 tense))) 403 (verb-info #:conj vinfo)
404 voice mood tense)))
425 (if (not conj-list) 405 (if (not conj-list)
426 (error "cannot obtain conjugation information for " 406 (error "cannot obtain conjugation information for "
427 (verb-info #:conj vinfo) voice mood tense)) 407 (verb-info #:conj vinfo) voice mood tense))
@@ -449,7 +429,8 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mood='" mood
449 (cond 429 (cond
450 ((string=? (conj-info #:thema conj) "synt") 430 ((string=? (conj-info #:thema conj) "synt")
451 (let* ((verb-conj 431 (let* ((verb-conj
452 (car (conjugate verb voice "sub" "Αόριστος" #:nopart))) 432 (car (conjugate conn verb voice "sub" "Αόριστος"
433 #:nopart)))
453 (form (list-ref verb-conj 2)) 434 (form (list-ref verb-conj 2))
454 (part (conj-info #:particle conj))) 435 (part (conj-info #:particle conj)))
455 (cond 436 (cond
@@ -465,7 +446,8 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mood='" mood
465 (elstr-append part " " aux " " form) 446 (elstr-append part " " aux " " form)
466 (elstr-append aux " " form))))) 447 (elstr-append aux " " form)))))
467 (conjugation:table 448 (conjugation:table
468 (car (conjugate (conj-info #:aux conj) "act" "ind" 449 (car (conjugate conn
450 (conj-info #:aux conj) "act" "ind"
469 (conj-info #:auxtense conj)))) 451 (conj-info #:auxtense conj))))
470 (string->list (or (verb-info #:accmap vinfo) 452 (string->list (or (verb-info #:accmap vinfo)
471 (conj-info #:accmap conj) 453 (conj-info #:accmap conj)
@@ -477,7 +459,7 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mood='" mood
477 (else 459 (else
478 (let ((thema (string-split (conj-info #:thema conj) #\:))) 460 (let ((thema (string-split (conj-info #:thema conj) #\:)))
479 ; (format #t "THEMA ~A~%" thema) 461 ; (format #t "THEMA ~A~%" thema)
480 (complement-verb-info vinfo verb 462 (complement-verb-info conn vinfo verb
481 (if (null? (cdr thema)) 463 (if (null? (cdr thema))
482 voice 464 voice
483 (car (cdr thema))) 465 (car (cdr thema)))
@@ -488,8 +470,11 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mood='" mood
488 (verb-info #:attested vinfo)))))) 470 (verb-info #:attested vinfo))))))
489 (conj-info #:fold conj))) 471 (conj-info #:fold conj)))
490 conj-list))))))) 472 conj-list)))))))
491 473
492(define (conjugation:table conj) 474(define-public (conjugator conn verb voice mood tense)
475 (conjugate conn verb voice mood tense))
476
477(define-public (conjugation:table conj)
493 (cond 478 (cond
494 ((not conj) 479 ((not conj)
495 #f) 480 #f)
@@ -497,20 +482,20 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mood='" mood
497 (list-head conj 6)))) 482 (list-head conj 6))))
498 483
499 484
500(define (conjugation:class conj) 485(define-public (conjugation:class conj)
501 (cond 486 (cond
502 ((not conj) 487 ((not conj)
503 #f) 488 #f)
504 (else 489 (else
505 (list-ref conj 6)))) 490 (list-ref conj 6))))
506 491
507(define (conjugation:attested conj) 492(define-public (conjugation:attested conj)
508 (cond 493 (cond
509 ((not conj) 494 ((not conj)
510 #f) 495 #f)
511 (else (list-ref conj 7)))) 496 (else (list-ref conj 7))))
512 497
513(define (empty-conjugation? conj) 498(define-public (empty-conjugation? conj)
514 (or 499 (or
515 (not conj) 500 (not conj)
516 (call-with-current-continuation 501 (call-with-current-continuation
@@ -522,136 +507,3 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mood='" mood
522 conj) 507 conj)
523 (return #t))))) 508 (return #t)))))
524 509
525;;
526;(display (verb-info "βρίσκω"))
527;(newline)
528;(display (verb-info "ανοίγω"))
529;(newline)
530
531(define transtab
532 '(("act" . "Ενεργητηκή φωνή")
533 ("pas" . "Μεσοπαθητική φωνή")
534 ("ind" . "Οριστική")
535 ("sub" . "Υποτακτική")
536 ("imp" . "Προστακτική")))
537
538(define (term x)
539 (or (assoc-ref transtab x) x))
540
541(define (test-conjugation verb voice mood tense)
542 (for-each
543 (lambda (result)
544 (format #t "~A ~A/~A/~A: " verb (term voice) (term mood) tense)
545 (let ((conj (conjugation:table result)))
546 (cond
547 ((empty-conjugation? conj)
548 (display "#f"))
549 (else
550 (let ((att (conjugation:attested result)))
551 (cond
552 ((not att)
553 (display "*"))
554 (else
555 (if (not (member 'class att))
556 (display "*"))
557 (if (not (member 'root att))
558 (display "!"))))
559 (display conj)))))
560 (newline))
561 (conjugate verb voice mood tense))
562 (gc))
563
564(define (test-voice voice verb)
565 (for-each
566 (lambda (mood-tenses)
567 (let ((mood (car mood-tenses)))
568 (for-each
569 (lambda (tense)
570 (test-conjugation verb voice mood tense))
571 (cdr mood-tenses))))
572 ellinika-tense-list))
573
574;(test-conjugation "διαβάζω" "act" "imp" "Αόριστος")
575;; (test-conjugation "είμαι" "act" "ind" "Ενεστώτας")
576;; (test-conjugation "είμαι" "act" "ind" "Παρατατίκος")
577;; (test-conjugation "είμαι" "act" "ind" "Μέλλοντας διαρκείας")
578;; (test-conjugation "είμαι" "act" "sub" "Ενεστώτας")
579;; (test-conjugation "είμαι" "act" "imp" "Ενεστώτας")
580;; (test-conjugation "είμαι" "act" "ind" "Αόριστος")
581
582;; (test-conjugation "έχω" "act" "ind" "Ενεστώτας")
583(test-conjugation "έχω" "act" "ind" "Παρατατίκος")
584;; (test-conjugation "έχω" "act" "ind" "Μέλλοντας διαρκείας")
585;; (test-conjugation "έχω" "act" "sub" "Ενεστώτας")
586;; (test-conjugation "έχω" "act" "imp" "Ενεστώτας")
587;; (test-conjugation "έχω" "act" "imp" "Αόριστος")
588
589;; (test-conjugation "ανοίγω" "act" "ind" "Ενεστώτας")
590;; (test-conjugation "ανοίγω" "act" "ind" "Αόριστος")
591;; (test-conjugation "ανοίγω" "pas" "ind" "Αόριστος")
592;; (test-conjugation "δένω" "act" "ind" "Αόριστος")
593;; (test-conjugation "θέλω" "act" "ind" "Αόριστος")
594;; (test-conjugation "θέλω" "act" "ind" "Παρατατικός")
595;; (test-conjugation "βρίσκω" "act" "ind" "Ενεστώτας")
596;; (test-conjugation "βρίσκω" "act" "ind" "Αόριστος")
597;; (test-conjugation "βρίσκω" "act" "ind" "Μέλλοντας στιγμιαίος")
598;; (test-conjugation "βρίσκω" "pas" "ind" "Αόριστος")
599;; (test-conjugation "βρίσκω" "act" "sub" "Ενεστώτας")
600;; (test-conjugation "βρίσκω" "act" "sub" "Αόριστος")
601;; (test-conjugation "βρίσκω" "act" "ind" "Παρακείμενος")
602;; (test-conjugation "βρίσκω" "act" "sub" "Παρακείμενος")
603;; (test-conjugation "βρίσκω" "act" "imp" "Αόριστος")
604
605;; (test-conjugation "νικάω" "act" "ind" "Ενεστώτας")
606;; (test-conjugation "νικάω" "act" "ind" "Αόριστος")
607;; (test-conjugation "νικώ" "act" "ind" "Ενεστώτας")
608;; (test-conjugation "νικώ" "act" "ind" "Αόριστος")
609;; (test-conjugation "νικώ" "pas" "ind" "Αόριστος")
610;; (test-conjugation "κρεμάω" "act" "ind" "Αόριστος")
611;; (test-conjugation "κιτάω" "act" "ind" "Αόριστος")
612;; (test-conjugation "τραβάω" "act" "ind" "Αόριστος")
613
614;; (test-conjugation "αγγέλω" "act" "ind" "Αόριστος")
615;; (test-conjugation "αγγέλω" "act" "sub" "Αόριστος")
616;; (test-conjugation "άγω" "act" "ind" "Αόριστος")
617;; (test-conjugation "άγω" "act" "sub" "Αόριστος")
618;; (test-conjugation "ανεβαίνω" "act" "ind" "Αόριστος")
619;; (test-conjugation "ανεβαίνω" "act" "sub" "Αόριστος")
620;; (test-conjugation "απονέμω" "act" "ind" "Αόριστος")
621;; (test-conjugation "απονέμω" "act" "sub" "Αόριστος")
622;; (test-conjugation "αρέσω" "act" "ind" "Αόριστος")
623;; (test-conjugation "αρέσω" "act" "sub" "Αόριστος")
624;; (test-conjugation "βάλλω" "act" "ind" "Αόριστος")
625;; (test-conjugation "βάλλω" "act" "sub" "Αόριστος")
626;; (test-conjugation "βγαίνω" "act" "ind" "Αόριστος")
627;; (test-conjugation "βγαίνω" "act" "sub" "Αόριστος")
628;; (test-conjugation "βλέπω" "act" "ind" "Αόριστος")
629;; (test-conjugation "βλέπω" "act" "sub" "Αόριστος")
630;; (test-conjugation "βλέπω" "act" "imp" "Αόριστος")
631;; (test-conjugation "πηγαίνω" "act" "ind" "Μέλλοντας στιγμιαίος")
632;; (test-conjugation "πίνω" "act" "ind" "Αόριστος")
633;; (test-conjugation "πίνω" "act" "sub" "Αόριστος")
634;; (test-conjugation "πίνω" "act" "imp" "Αόριστος")
635
636;(test-conjugation "έρχομαι" "pas" "ind" "Παρατατικός")
637;(test-conjugation "έρχομαι" "pas" "ind" "Αόριστος")
638;(test-conjugation "έρχομαι" "pas" "sub" "Αόριστος")
639;; (test-conjugation "έρχομαι" "pas" "ind" "Συντελεσμένος Μέλλοντας")
640;; (test-conjugation "έρχομαι" "act" "sub" "Αόριστος" )
641;; (test-conjugation "έρχομαι" "pas" "sub" "Αόριστος" )
642;; (test-conjugation "έρχομαι" "pas" "ind" "Ενεστώτας");FIXME!
643;; (test-conjugation "έρχομαι" "pas" "ind" "Υπερσυντέλικος")
644
645;(test-voice "pas" "ντύνω")
646(test-voice "pas" "έρχομαι")
647
648;(display (conjugate "ντύνω" "pas" "ind" "Ενεστώτας"))
649;(newline)
650;(display (conjugate "ντύνω" "pas" "imp" "Αόριστος"))
651;(newline)
652;(display (conjugate "ντύνω" "pas" "ind" "Συντελεσμένος Μέλλοντας"))
653;(newline)
654;(display (conjugate "τραβάω" "act" "ind" "Παρατατικός"))
655;(newline)
656
657(newline)

Return to:

Send suggestions and report system problems to the System administrator.