;;;; A Dico module for Greek Dictionary Web Engine -*- scheme -*- ;;;; Copyright (C) 2008, 2010 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 . ;;;; (define-module (ellinika dico)) (use-modules (guile-user) (ice-9 rdelim) (gamma sql) (xmltools dict) (ellinika xlat) (ellinika config)) (define (sql-error-handler key func fmt fmtargs data) (apply format (current-error-port) fmt fmtargs)) (define (my-sql-query conn query) (catch #t (lambda () (sql-query conn query)) (lambda args '()))) (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)))))) rest) (let ((db-connection (sql-open-connection ellinika-sql-connection))) (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-close-connection (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"))) ;; Implementation of a Common LISP mapcan function (define (mapcan fun list) (apply (lambda ( . slist) (let loop ((elt '()) (slist slist)) (cond ((null? slist) (reverse elt)) ((not (car slist)) (loop elt (cdr slist))) (else (loop (cons (car slist) elt) (cdr slist)))))) (map fun list))) ;; Convert SLIST, which is a list of strings, into a string of ;; comma-separated values. (define (list->csv slist) (apply string-append (let loop ((elt '()) (slist slist)) (cond ((null? (cdr slist)) (reverse (cons "\"" (cons (car slist) (cons "\"" elt))))) (else (loop (cons "\"," (cons (car slist) (cons "\"" elt))) (cdr slist))))))) (define (match-selector dbh strat key) (let* ((key (dico-make-key strat (dico-key->word key))) (sound (ellinika:sounds-like (dico-key->word key))) (dlist (mapcan (lambda (elt) (let ((word (car elt))) (and (dico-strat-select? strat word key) word))) (my-sql-query (dbh:conn dbh) (string-append "SELECT DISTINCT dict.sound FROM dict,articles " "WHERE dict.ident=articles.ident " "AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1"))))) (if (not (null? dlist)) (my-sql-query (dbh:conn dbh) (string-append "SELECT DISTINCT dict.word FROM dict " "WHERE dict.sound IN (" (list->csv dlist) ")")) #f))) (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))) (define (match-word dbh strat key) (let ((sp (assoc (dico-strat-name strat) strategy-list))) (let ((res (cond (sp ((cdr sp) dbh strat (dico-key->word key))) ((dico-strat-selector? strat) (match-selector dbh strat key)) (else (match-default dbh strat (dico-key->word key)))))) (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) (dico-register-strat "suffix" "Match word suffixes")