From e99c9e97b1007ba8e70d8ea62ab06d1cd2399465 Mon Sep 17 00:00:00 2001 From: Sergey Poznyakoff Date: Tue, 17 Jun 2008 18:50:08 +0000 Subject: 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 --- ellinika/Makefile.am | 5 +- ellinika/dico.scm4 | 322 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 325 insertions(+), 2 deletions(-) create mode 100644 ellinika/dico.scm4 (limited to 'ellinika') 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 . 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 . +;;;; + +;;; 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) + + + -- cgit v1.2.1