diff options
-rw-r--r-- | src/ellinika/conjugator.scm | 258 |
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 \ |
149 | WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'"))) | 129 | WHERE 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,\ |
295 | f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \ | 274 | f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \ |
296 | FROM conjugation c, verbflect f \ | 275 | FROM conjugation c, verbflect f \ |
297 | WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mood='" mood | 276 | WHERE 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 \ |
400 | FROM individual_verb i,verbflect f \ | 379 | FROM 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))))) |