diff options
Diffstat (limited to 'src/ellinika')
-rw-r--r-- | src/ellinika/conjugator.scm | 657 |
1 files changed, 657 insertions, 0 deletions
diff --git a/src/ellinika/conjugator.scm b/src/ellinika/conjugator.scm new file mode 100644 index 0000000..edc649e --- /dev/null +++ b/src/ellinika/conjugator.scm | |||
@@ -0,0 +1,657 @@ | |||
1 | (use-modules (srfi srfi-1) | ||
2 | (ellinika elmorph) | ||
3 | (ellinika i18n) | ||
4 | (ellinika cgi) | ||
5 | (ellinika tenses) | ||
6 | (xmltools dict) | ||
7 | (gamma sql)) | ||
8 | |||
9 | (use-syntax (ice-9 syncase)) | ||
10 | |||
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) | ||
42 | ; (format #t "Q: ~A~%" query) | ||
43 | (let ((res (sql-query conn query))) | ||
44 | ; (format #t "R: ~A~%" res) | ||
45 | res)) | ||
46 | |||
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 | ||
54 | (list | ||
55 | (list "A" | ||
56 | #f | ||
57 | "ε" | ||
58 | #f | ||
59 | #f | ||
60 | #f) | ||
61 | (list "B1" | ||
62 | #f | ||
63 | #f | ||
64 | #f | ||
65 | #f | ||
66 | #f) | ||
67 | (list "B2" | ||
68 | #f | ||
69 | #f | ||
70 | #f | ||
71 | #f | ||
72 | #f))) | ||
73 | |||
74 | (define (guess-verb-info verb) | ||
75 | (cond | ||
76 | ;; FIXME | ||
77 | ((elstr-suffix? verb "άω") | ||
78 | (assoc "B1" verb-info-template)) | ||
79 | ((elstr-suffix? verb "ώ") | ||
80 | (assoc "B2" verb-info-template)) | ||
81 | ;; FIXME: deponentia? | ||
82 | (else | ||
83 | (assoc "A" verb-info-template)))) | ||
84 | |||
85 | (define (get-verb-info verb . rest) | ||
86 | (let ((conn (dict-connect)) | ||
87 | (class (if (null? rest) | ||
88 | "" | ||
89 | (string-append " AND conj='" (car rest) "'")))) | ||
90 | (let ((vdb (my-sql-query | ||
91 | conn | ||
92 | (string-append | ||
93 | "SELECT conj,accmap,augment,suffix FROM verb \ | ||
94 | WHERE verb='" (force-string verb) "'" | ||
95 | class)))) | ||
96 | (cond | ||
97 | ((and vdb (not (null? vdb))) | ||
98 | (let ((x (car vdb))) | ||
99 | (list | ||
100 | (list-ref x 0) | ||
101 | (list-ref x 1) | ||
102 | (or (list-ref x 2) "ε") | ||
103 | (list-ref x 3) | ||
104 | #f | ||
105 | '(class)))) | ||
106 | ((elstr-suffix? verb "άω") | ||
107 | (get-verb-info (elstr-append | ||
108 | (elstr-trim verb -2) "ώ") "B1")) | ||
109 | ((null? rest) | ||
110 | (guess-verb-info verb)) | ||
111 | (else | ||
112 | (assoc (car rest) verb-info-template)))))) | ||
113 | |||
114 | (define (thema-aoristoy-mesapathitikis root) | ||
115 | (cond | ||
116 | ((elstr-suffix? root "αίν") | ||
117 | (elstr-append (elstr-trim root -3) "ανθ")) ;; FIXME: Also αθ, ηθ | ||
118 | ((and | ||
119 | (elstr-suffix? root "ν") | ||
120 | (logand (elstr-char-prop-bitmask root -2) elmorph:vowel)) | ||
121 | (elstr-append (elstr-trim root -1) "θ")) ;; FIXME: also στ, νθ, θ | ||
122 | ((and | ||
123 | (elstr-suffix? root "δ" "θ" "ζ" "ν") ;; FIXME: see above | ||
124 | (logand (elstr-char-prop-bitmask root -2) elmorph:vowel)) | ||
125 | (elstr-append (elstr-trim root -1) "στ")) | ||
126 | ((elstr-suffix? root "γγ" "σσ" "ττ" "χν" "γ" "ζ" "κ" "χ") => | ||
127 | (lambda (suf) | ||
128 | (elstr-append (elstr-trim root (- 0 (elstr-length (string->elstr suf)))) | ||
129 | "χτ"))) ;; also χθ | ||
130 | ((elstr-suffix? root "π" "β" "φ" "πτ" "φτ") => | ||
131 | (lambda (suf) | ||
132 | (elstr-append (elstr-trim root (- 0 (elstr-length (string->elstr suf)))) | ||
133 | "φτ"))) ;; also φθ | ||
134 | ((elstr-suffix? root "αύ" "εύ") => | ||
135 | (lambda (suf) | ||
136 | (elstr-append root "τ"))) | ||
137 | ((elstr-suffix? root "άρ" "ίρ") | ||
138 | ((elstr-append root "ιστ"))) | ||
139 | ((logand (elstr-char-prop-bitmask root -1) elmorph:vowel) | ||
140 | (elstr-append root "θ")) | ||
141 | (else | ||
142 | #f))) | ||
143 | |||
144 | (define (lookup-verb-info verb voice thema) | ||
145 | (my-sql-query | ||
146 | (dict-connect) | ||
147 | (string-append | ||
148 | "SELECT root FROM irregular_root \ | ||
149 | WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'"))) | ||
150 | |||
151 | (define (verb-A-root verb) | ||
152 | (cond | ||
153 | ((elstr-suffix? verb "ω") | ||
154 | (elstr-trim verb -1)) | ||
155 | ((elstr-suffix? verb "ομαι") | ||
156 | (elstr-trim verb -4)) | ||
157 | (else | ||
158 | (error "cannot handle ~A~%" verb)))) | ||
159 | |||
160 | (define (complement-verb-info vinfo verb voice thema) | ||
161 | ; (format #t "COMPLEMENT ~A~%" thema) | ||
162 | (let ((elverb (string->elstr verb)) | ||
163 | (result (let ((tmpres (lookup-verb-info verb voice thema))) | ||
164 | (if (and (null? tmpres) (string=? thema "sub")) | ||
165 | (lookup-verb-info verb voice "aor") | ||
166 | tmpres)))) | ||
167 | (verb-info-set! #:root vinfo | ||
168 | (cond | ||
169 | ((not (null? result)) | ||
170 | (verb-info-set! #:attested vinfo 'root) | ||
171 | (caar result)) | ||
172 | ((string=? (verb-info #:conj vinfo) "A") | ||
173 | (let ((root (verb-A-root elverb))) | ||
174 | (cond | ||
175 | ((string=? thema "pres") | ||
176 | (verb-info-set! #:attested vinfo 'root) | ||
177 | root) | ||
178 | ((or (string=? thema "aor") (string=? thema "sub")) | ||
179 | (if (string=? voice "act") | ||
180 | (elstr-thema-aoristoy root) | ||
181 | (thema-aoristoy-mesapathitikis root))) | ||
182 | (else | ||
183 | #f)))) | ||
184 | ((string=? (verb-info #:conj vinfo) "A-depon") | ||
185 | (let ((root (verb-A-root elverb))) | ||
186 | (cond | ||
187 | ((string=? thema "pres") | ||
188 | (verb-info-set! #:attested vinfo 'root) | ||
189 | root) | ||
190 | ((or (string=? thema "aor") (string=? thema "sub")) | ||
191 | #f) ; FIXME | ||
192 | (else | ||
193 | #f)))) | ||
194 | ((string=? (verb-info #:conj vinfo) "B1") | ||
195 | (let ((root (if (elstr-suffix? elverb "άω") | ||
196 | (elstr-trim elverb -2) | ||
197 | (elstr-trim elverb -1)))) | ||
198 | (cond | ||
199 | ((or (string=? voice "act") (string=? thema "pres")) | ||
200 | (verb-info-set! #:attested vinfo 'root) | ||
201 | root) | ||
202 | ((or (string=? thema "aor") (string=? thema "sub")) | ||
203 | (elstr-append root "ηθ")) ;; FIXME: guesswork | ||
204 | (else | ||
205 | #f)))) | ||
206 | ((string=? (verb-info #:conj vinfo) "B2") | ||
207 | (let ((root (elstr-trim elverb -1))) | ||
208 | (cond | ||
209 | ((or (string=? voice "act") (string=? thema "pres")) | ||
210 | (verb-info-set! #:attested vinfo 'root) | ||
211 | root) | ||
212 | ((or (string=? thema "aor") (string=? thema "sub")) | ||
213 | (elstr-append root "ηθ")) ;; FIXME: guesswork | ||
214 | (else | ||
215 | #f)))) | ||
216 | (else | ||
217 | #f))))) | ||
218 | |||
219 | (define-syntax verb-info | ||
220 | (syntax-rules () | ||
221 | ((verb-info #:conj v) | ||
222 | (list-ref v 0)) | ||
223 | ((verb-info #:accmap v) | ||
224 | (list-ref v 1)) | ||
225 | ((verb-info #:augment v) | ||
226 | (list-ref v 2)) | ||
227 | ((verb-info #:suffix v) | ||
228 | (list-ref v 3)) | ||