aboutsummaryrefslogtreecommitdiff
path: root/src/ellinika
diff options
context:
space:
mode:
Diffstat (limited to 'src/ellinika')
-rw-r--r--src/ellinika/conjugator.scm657
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 \
94WHERE 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 \
149WHERE 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))