aboutsummaryrefslogtreecommitdiff
path: root/ellinika
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2008-06-17 18:50:08 +0000
committerSergey Poznyakoff <gray@gnu.org.ua>2008-06-17 18:50:08 +0000
commite99c9e97b1007ba8e70d8ea62ab06d1cd2399465 (patch)
treeb07580cae8a20253bcf53623165c3a78e2a65f7b /ellinika
parentd2ce7e645d27f63f4ffd1338208dc200d426a3e3 (diff)
downloadellinika-e99c9e97b1007ba8e70d8ea62ab06d1cd2399465.tar.gz
ellinika-e99c9e97b1007ba8e70d8ea62ab06d1cd2399465.tar.bz2
Move the Dico module to modules.
* cgi-bin/dico-ellinika.scm4: Move to ... * ellinika/dico.scm4: ... here. * ellinika/Makefile.am (guile_DATA): Add dico.scm (dico.scm): New rule. * cgi-bin/Makefile.am: (EXTRA_SCRIPTS): Remove. git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@518 941c8c0f-9102-463b-b60b-cd22ce0e6858
Diffstat (limited to 'ellinika')
-rw-r--r--ellinika/Makefile.am5
-rw-r--r--ellinika/dico.scm4322
2 files changed, 325 insertions, 2 deletions
diff --git a/ellinika/Makefile.am b/ellinika/Makefile.am
index 248666d..f2b9ab6 100644
--- a/ellinika/Makefile.am
+++ b/ellinika/Makefile.am
@@ -15,7 +15,7 @@
# along with this program. If not, see <http://www.gnu.org/licenses/>.
guiledir=$(GUILE_SITE)/$(PACKAGE)
-guile_DATA=xlat.scm cgi.scm i18n.scm config.scm
+guile_DATA=xlat.scm cgi.scm i18n.scm config.scm dico.scm
cgi.m4: Makefile
echo 'divert(-1)' > $@
@@ -40,4 +40,5 @@ SUFFIXES = .scm4 .scm
m4 cgi.m4 $< > $@
cgi.scm: cgi.scm4 cgi.m4
-config.scm: config.scm4 cgi.m4 \ No newline at end of file
+config.scm: config.scm4 cgi.m4
+dico.scm: dico.scm4 cgi.m4
diff --git a/ellinika/dico.scm4 b/ellinika/dico.scm4
new file mode 100644
index 0000000..38d7e08
--- /dev/null
+++ b/ellinika/dico.scm4
@@ -0,0 +1,322 @@
+;;;; A Dico module for Greek Dictionary Web Engine -*- scheme -*-
+;;;; Copyright (C) 2008 Sergey Poznyakoff
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;;;
+
+;;; Tailor this statement to your needs if necessary.
+(set! %load-path (cons "GUILE_SITE" %load-path))
+
+(define-module (dico))
+
+(use-modules (guile-user)
+ (ice-9 rdelim)
+ (gamma sql)
+ (xmltools dict)
+ (ellinika xlat)
+ (ellinika config))
+
+;; FIXME: These are defined in dict.scm4
+
+(define (sql-error-handler err descr)
+ (format #t "cannot connect to the database")
+ (with-output-to-port
+ (current-error-port)
+ (lambda ()
+ (display err)
+ (display ": ")
+ (display descr))))
+
+(defmacro catch-sql-failure (expr)
+ `(catch 'gsql-error
+ (lambda () ,expr)
+ (lambda (key err descr)
+ (sql-error-handler err descr))))
+
+(defmacro ignore-sql-failure (expr)
+ `(catch 'gsql-error
+ (lambda () ,expr)
+ (lambda (key err descr)
+ #f)))
+
+(define (my-sql-query conn query)
+ (catch #t
+ (lambda ()
+ (sql-query conn query))
+ (lambda args
+ '())))
+
+;; END of FIXME
+
+(define (dico-error err . rest)
+ (with-output-to-port
+ (current-error-port)
+ (lambda ()
+ (display err)
+ (for-each
+ display
+ rest)
+ (newline))))
+
+;; Dico interface
+
+(define (open-module name . rest)
+ (let ((target-language "el")
+ (type 'dict))
+ (for-each (lambda (arg)
+ (let ((av (string-split arg #\=)))
+ (case (length av)
+ ((1) (cond
+ ((string=? (car av) "synonym")
+ (set! type 'synonim))
+ ((string=? (car av) "antonym")
+ (set! type 'antonym))
+ (else
+ (dico-error "Unknown option " (car av)))))
+ ((2) (cond
+ ((string=? (car av) "lang")
+ (set! target-language (cadr av)))
+ (else
+ (dico-error "Unknown option " (car av)))))
+ (else
+ (dico-error "Unknown option " (car av))))))
+ (cdr rest))
+ (let ((db-connection (sql-connect
+ sql-iface sql-host sql-port sql-database
+ sql-username sql-password)))
+ (sql-query db-connection "SET NAMES utf8")
+ (list db-connection target-language type))))
+
+(defmacro dbh:conn (dbh) `(list-ref ,dbh 0))
+(defmacro dbh:lang (dbh) `(list-ref ,dbh 1))
+(defmacro dbh:type (dbh) `(list-ref ,dbh 2))
+
+(define (close-module dbh)
+ (sql-connect-close (dbh:conn dbh)))
+
+(define descr-list
+ '(("pl" . "Słownik grecko-polski")
+ ("uk" . "Грецько-украЇнський словник")
+ ("ru" . "Греческо-русский словарь")))
+
+(define (descr dbh)
+ (case (dbh:type dbh)
+ ((dict)
+ (let ((res (assoc (dbh:lang dbh) descr-list)))
+ (if res
+ (cdr res)
+ "Ellinika (no description available)")))
+ ((antonym)
+ "Λέξικο αντωνύμων της Ελληνικής γλώσσας")
+ ((synonym)
+ "a")))
+
+(define (info dbh)
+ (string-append "Ellinika - A greek dictionary.\n\
+See http://ellinika.gnu.org.ua/cgi-bin/dict.cgi?LANG="
+ (dbh:lang dbh) "\n\
+Copyright © 2004, 2005, 2006, 2007, 2008 Sergey Poznyakoff\n\
+\n\
+Permission is granted to copy, distribute and/or modify this document\n\
+under the terms of the GNU Free Documentation License, Version 1.2 or\n\
+any later version published by the Free Software Foundation; with no\n\
+Invariant Sections, no Front-Cover and Back-Cover Texts"))
+
+(define (define-word-dict dbh key)
+ (let ((result '())
+ (last-id -1)
+ (word '())
+ (articles '()))
+ (for-each
+ (lambda (tuple)
+ (cond
+ ((not (= last-id (string->number (car tuple))))
+ (if (not (null? articles))
+ (set! result (cons
+ (cons word (reverse articles))
+ result)))
+ (set! last-id (string->number (car tuple)))
+ (set! word (cons (list-ref tuple 1)
+ (list-ref tuple 2))); FIXME: forms?
+ (set! articles '())))
+ (set! articles (cons
+ (cons (list-ref tuple 4)
+ (list-ref tuple 5))
+ articles)))
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT dict.ident,dict.word,pos.abbr,dict.forms,articles.subindex,articles.meaning "
+ "FROM dict,articles,pos WHERE dict.word=\""
+ key
+ "\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' "
+ "AND dict.pos=pos.id AND pos.canonical='Y' ORDER BY dict.ident, articles.subindex")))
+ (if (not (null? articles))
+ (set! result (cons
+ (cons word (reverse articles))
+ result)))
+ (cons 'define-word-dict (reverse result))))
+
+(define (define-word-x dbh word link-type)
+ (let ((res (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict,links,articles "
+ "WHERE links.type='" link-type "' AND links.ident IN "
+ "(SELECT ident FROM dict WHERE word=\"" word "\") "
+ "AND dict.ident=links.xref "
+ "AND dict.ident=articles.ident and articles.lang=\""
+ (dbh:lang dbh)
+ "\" ORDER BY word"))))
+ (if (and res (not (null? res)))
+ (cons 'define-word-x (list (cons word (map car res))))
+ #f)))
+
+(define (define-word-antonym dbh word)
+ (define-word-x dbh word "XREF"))
+
+(define (define-word-synonym dbh word)
+ (define-word-x dbh word "ANT"))
+
+(define define-list
+ (list (cons 'dict define-word-dict)
+ (cons 'synonym define-word-synonym)
+ (cons 'antonym define-word-antonym)))
+
+(define (define-word dbh word)
+ (let ((key (ellinika:translate-input word))
+ (x (assoc (dbh:type dbh) define-list)))
+ (if x
+ ((cdr x) dbh key)
+ #f)))
+
+(define (match-exact dbh strat word)
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict, articles WHERE dict.word=\""
+ (ellinika:translate-input word)
+ "\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1")))
+
+(define (match-prefix dbh strat word)
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict, articles WHERE dict.word LIKE \""
+ (ellinika:translate-input word)
+ "%\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1")))
+
+(define (match-suffix dbh strat word)
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict, articles WHERE dict.word LIKE \"%"
+ (ellinika:translate-input word)
+ "\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1")))
+
+(define (match-extnd-regex dbh strat word)
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict, articles WHERE dict.word regexp \""
+ (ellinika:translate-input word)
+ "\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1")))
+
+(define (match-basic-regex dbh strat word)
+ #f) ;FIXME
+
+(define (match-default dbh strat word)
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict,articles WHERE dict.sound LIKE \""
+ (ellinika:sounds-like word)
+ "%\" AND dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1")))
+
+
+(define strategy-list
+ (list (cons "exact" match-exact)
+ (cons "prefix" match-prefix)
+ (cons "suffix" match-suffix)
+ (cons "re" match-extnd-regex)
+ (cons "regexp" match-basic-regex)))
+
+(define (match-word dbh strat word)
+ (let ((sp (assoc (dico-strat-name strat) strategy-list)))
+ (let ((res (if sp
+ ((cdr sp) dbh strat word)
+ (match-default dbh strat word))))
+ (if res
+ (cons #f (map car res))
+ #f))))
+
+(define (output res n)
+ (let ((type (car res))
+ (contents (list-ref (cdr res) n)))
+ (case type
+ ((define-word-dict)
+ (let ((word-pair (car contents))
+ (defn (cdr contents)))
+ (display (car word-pair))
+ (display ", <")
+ (display (cdr word-pair))
+ (display ">")
+ (for-each
+ (lambda (article)
+ (newline)
+ (display (1+ (string->number (car article))))
+ (display ". ")
+ (display (cdr article))
+ (display ";"))
+ defn)))
+ ((define-word-x)
+ (let ((word (car contents))
+ (defn (cdr contents)))
+ (display word)
+ (display " -- ")
+ (display (car defn))
+ (if (cdr defn)
+ (for-each
+ (lambda (elt)
+ (display ", ")
+ (display elt))
+ (cdr defn)))))
+ (else
+ (display contents)))))
+
+(define (result-count res)
+ (length (cdr res)))
+
+(define-public (dico-ellinika-init arg)
+ (list (cons "open" open-module)
+ (cons "close" close-module)
+ (cons "descr" descr)
+ (cons "info" info)
+ (cons "define" define-word)
+ (cons "match" match-word)
+ (cons "output" output)
+ (cons "result-count" result-count)))
+
+;;
+;; Setup
+(ellinika-config-setup)
+
+
+

Return to:

Send suggestions and report system problems to the System administrator.