/ [runasimi] / trunk / src / runasimi / dico.scm
To checkout: svn checkout http://svn.gnu.org.ua/sources/runasimi/trunk/src/runasimi/dico.scm
Puszcza

Contents of /trunk/src/runasimi/dico.scm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 48 - (show annotations)
Sun Jun 27 20:05:52 2010 UTC (11 years, 2 months ago) by gray
File size: 7115 byte(s)
Upgrade for Dico 2.0.90

* src/runasimi/dico.scm: Update.

1 ;;;; This file is a part of Quechua Web Dictionary Search Engine
2 ;;;; Copyright (C) 2008 Sergey Poznyakoff
3 ;;;;
4 ;;;; This program is free software; you can redistribute it and/or modify
5 ;;;; it under the terms of the GNU General Public License as published by
6 ;;;; the Free Software Foundation; either version 3 of the License, or
7 ;;;; (at your option) any later version.
8 ;;;;
9 ;;;; This program is distributed in the hope that it will be useful,
10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;;; GNU General Public License for more details.
13 ;;;;
14 ;;;; You should have received a copy of the GNU General Public License
15 ;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
16 ;;;;
17
18 (define-module (runasimi dico)
19 #:use-module (guile-user)
20 #:use-module (gamma sql)
21 #:use-module (runasimi config)
22 #:use-module (runasimi dictdb))
23
24 (define (sql-error-handler err descr)
25 (format #t "cannot connect to the database")
26 (with-output-to-port
27 (current-error-port)
28 (lambda ()
29 (display err)
30 (display ": ")
31 (display descr))))
32
33 (define (dico-error err . rest)
34 (with-output-to-port
35 (current-error-port)
36 (lambda ()
37 (display err)
38 (for-each
39 display
40 rest)
41 (newline))))
42
43 (define (my-sql-query conn query)
44 (catch #t
45 (lambda ()
46 (sql-query conn query))
47 (lambda args
48 '())))
49
50 ;; Dico interface
51
52 (define (open-module name . rest)
53 (let ((target-language "es"))
54 (for-each (lambda (arg)
55 (let ((av (string-split arg #\=)))
56 (case (length av)
57 ((2) (let ((var (car av)))
58 (cond
59 ((string=? var "lang")
60 (set! target-language (cadr av)))
61 (else
62 (dico-error "Unknown option " (car av))))))
63 (else
64 (dico-error "Unknown option " (car av))))))
65 rest)
66 (let ((conn (sql-connect
67 sql-iface sql-host sql-port sql-database
68 sql-username sql-password)))
69 (sql-query conn "SET NAMES utf8")
70 (list
71 conn
72 target-language
73 (dictdb:lang-to table (assoc 'qu lang-list))
74 (dictdb:lang-to table (assoc (string->symbol target-language)
75 lang-list))))))
76
77 (defmacro dbh:conn (dbh) `(list-ref ,dbh 0))
78 (defmacro dbh:lang (dbh) `(list-ref ,dbh 1))
79 (defmacro dbh:srctab (dbh) `(list-ref ,dbh 2))
80 (defmacro dbh:dsttab (dbh) `(list-ref ,dbh 3))
81
82 (define (close-module dbh)
83 (sql-connect-close (dbh:conn dbh)))
84
85 (define descr-list
86 '(("es" . "Diccionário Quechua-Español")
87 ("en" . "Quechua-English Dictionary")
88 ("de" . "Quechua-Deutsch Wörterbuch")))
89
90 (define (descr dbh)
91 (let ((res (assoc (dbh:lang dbh) descr-list)))
92 (if res
93 (cdr res)
94 #f)))
95
96 (define info-list
97 '(("es" .
98 "Diccionário Runasimi-Español.\n\
99 Copyright © 2004, 2005, 2008 Sergey Poznyakoff.\n\
100 Vocabulario compuesto por Philip Jacobs (http://www.runasimi.de/runaespa.htm).\n\
101 \n\
102 Contenido disponible bajo los términos de la Licencia de documentación libre\n\
103 de GNU (véase http://www.gnu.org/licenses/fdl.html")
104 ("en" .
105 "Quechua-English dictionary.\n\
106 Copyright © 2004, 2005, 2008 Sergey Poznyakoff.\n\
107 Dictionary corpus by Philip Jacobs (http://www.runasimi.de/runaespa.htm).\n\
108 \n\
109 Dictionary is available under the terms of the GNU Free Documentation License,\n\
110 see http://www.gnu.org/licenses/fdl.html")
111 ("de" .
112 "Quechua-Deutsch Wörterbuch.\n\
113 Copyright © 2004, 2005, 2008 Sergey Poznyakoff.\n\
114 Basiert auf dem Werk von Philip Jacobs (http://www.runasimi.de/runaespa.htm).\n\
115 \n\
116 Ihr Text steht unter der GNU-Lizenz für freie Dokumentation\n\
117 (http://www.gnu.org/licenses/fdl.html)")))
118
119 (define (info dbh)
120 (let ((res (assoc (dbh:lang dbh) info-list)))
121 (if res
122 (cdr res)
123 #f)))
124
125
126 (define (define-word dbh word)
127 (let ((res (sql-query (dbh:conn dbh)
128 (dictdb:build-forward-query
129 (dbh:srctab dbh)
130 (dbh:dsttab dbh)
131 word))))
132 (and res (cons #t (dictdb:compact-forward-reply res)))))
133
134 (defmacro rh:define? (res)
135 `(car ,res))
136
137 (defmacro rh:result (res)
138 `(cdr ,res))
139
140 (define (match-exact dbh strat word)
141 (my-sql-query
142 (dbh:conn dbh)
143 (dictdb:build-list-query
144 (dbh:srctab dbh) (dbh:dsttab dbh)
145 (string-append "= \"" word "\""))))
146
147 (define (match-prefix dbh strat word)
148 (my-sql-query
149 (dbh:conn dbh)
150 (dictdb:build-list-query
151 (dbh:srctab dbh) (dbh:dsttab dbh)
152 (string-append "LIKE \"" word "%\""))))
153
154 (define (match-suffix dbh strat word)
155 (my-sql-query
156 (dbh:conn dbh)
157 (dictdb:build-list-query
158 (dbh:srctab dbh) (dbh:dsttab dbh)
159 (string-append "LIKE \"%" word "\""))))
160
161 (define (match-extnd-regex dbh strat word)
162 (my-sql-query
163 (dbh:conn dbh)
164 (dictdb:build-list-query
165 (dbh:srctab dbh) (dbh:dsttab dbh)
166 (string-append "REGEXP \"" word "\""))))
167
168 (define (match-basic-regex dbh strat word)
169 #f) ; FIXME
170
171 ;; Convert SLIST, which is a list of strings, into a string of
172 ;; comma-separated values.
173 (define (list->csv slist)
174 (apply string-append
175 (let loop ((elt '())
176 (slist slist))
177 (cond
178 ((null? (cdr slist))
179 (reverse
180 (cons "\"" (cons (car slist) (cons "\"" elt)))))
181 (else
182 (loop (cons "\"," (cons (car slist) (cons "\"" elt)))
183 (cdr slist)))))))
184
185 (define (match-selector dbh strat key)
186 (let ((dlist (mapcan
187 (lambda (elt)
188 (let ((word (car elt)))
189 (and (dico-strat-select? strat word key)
190 word)))
191 (my-sql-query
192 (dbh:conn dbh)
193 (dictdb:build-list-query
194 (dbh:srctab dbh) (dbh:dsttab dbh) #f)))))
195 (if (not (null? dlist))
196 (my-sql-query
197 (dbh:conn dbh)
198 (dictdb:build-list-query
199 (dbh:srctab dbh) (dbh:dsttab dbh)
200 (string-append " IN (" (list->csv dlist) ")")))
201 #f)))
202
203 (define (match-reverse dbh src-table key)
204 (my-sql-query
205 (dbh:conn dbh)
206 (dictdb:build-reverse-list-query
207 (dbh:dsttab dbh) (dbh:srctab dbh) key)))
208
209 (define strategy-list
210 (list (cons "exact" match-exact)
211 (cons "prefix" match-prefix)
212 (cons "suffix" match-suffix)
213 (cons "re" match-extnd-regex)
214 (cons "rev-qu" match-reverse)))
215
216 (define (match-word dbh strat key)
217 (let ((sp (assoc (dico-strat-name strat) strategy-list)))
218 (let ((res (cond
219 (sp
220 ((cdr sp) dbh strat (dico-key->word key)))
221 ((dico-strat-selector? strat)
222 (match-selector dbh strat key))
223 (else
224 (match-prefix dbh strat (dico-key->word key))))))
225 (and res (cons #f (map car res))))))
226
227 (define (output rh n)
228 (let ((res (rh:result rh)))
229 (cond
230 ((rh:define? rh)
231 (dictdb:display-compacted-forward-result res 'text))
232 (else
233 (display (list-ref res n))))))
234
235 (define (result-count rh)
236 (length (rh:result rh)))
237
238 (define-public (dico-runasimi-init arg)
239 (list (cons "open" open-module)
240 (cons "close" close-module)
241 (cons "descr" descr)
242 (cons "info" info)
243 (cons "define" define-word)
244 (cons "match" match-word)
245 (cons "output" output)
246 (cons "result-count" result-count)))
247
248 ;;
249 ;; Setup
250 (runasimi-config-setup)
251 (dico-register-strat "suffix" "Match word suffixes")
252 (dico-register-strat "rev-qu" "Reverse search in Quechua databases")

Send suggestions and bug reports to Sergey Poznyakoff
ViewVC Help
Powered by ViewVC 1.1.20