#!/usr/local/bin/guile -s !# ;;;; Greek Dictionary Web Engine ;;;; Copyright (C) 2004 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 2 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, write to the Free Software ;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;;; ;; FIXME: These should be set by configure (set! %load-path (append %load-path (list "/usr/local/share/guile-sql"))) (set! %load-path (append %load-path (list "/usr/local/share/guile-gettext"))) (use-modules (www cgi)) (use-modules (sql)) (use-modules (gettext)) (cgi:init) ;;; User-definable variables (define base-dir "=PREFIX=") (define html-dir "=HTMLDIR=") (define sysconf-dir "=SYSCONFDIR=") (define locale-dir "=LOCALEDIR=") (define ref-loc #f) (define dict-cgi-path "cgi-bin/dict.cgi") ;; Path to the cgi (relative ;; to the Base HREF) (define config-file-name "ellinika.conf") (define template-file-name "dict.html") (define target-language "el_GR") (define word-forms-reference '()) (define sql-iface "mysql") ;; SQL interface ("mysql" or "postgres") (define sql-host "localhost") ;; SQL server hostname or a path to the UNIX ;; socket (define sql-port 3306) ;; SQL port number (0 for sockaddr_un ;; connection) (define sql-database "ellinika") ;; Name of the database (define sql-username "gray") ;; Database user name (define sql-password "") ;; Password for that user name (define match-list-columns 4) ;; Number of colums in fuzzy search output ;;; End of user-definable variables ;;; Load the site defaults (let ((rc-file (string-append sysconf-dir "/" config-file-name))) (if (file-exists? rc-file) (load rc-file))) (define (language-code lang) (cond ((string-index lang #\_) => (lambda (len) (substring lang 0 len))) (else lang))) (define (template-file lang) (string-append html-dir "/" (language-code lang) "/" template-file-name)) ;;; Load the language-specific defaults (cond ((cgi:value "LANG") => (lambda (x) (if (and (file-exists? (template-file x)) (false-if-exception (setlocale LC_ALL x))) (set! target-language x))))) ;;; Initialize i18n (setlocale LC_ALL target-language) (bindtextdomain "=PACKAGE=" locale-dir) (bind_textdomain_codeset "=PACKAGE=" "UTF-8") (textdomain "=PACKAGE=") (define (make-cgi-name . rest) (apply string-append (cons dict-cgi-path (let ((arglist (let ((lang (cgi:value "LANG"))) (do ((ilist (if lang (cons "LANG" (cons lang rest)) rest) (cdr ilist)) (i 1 (1+ i)) (olist '())) ((null? ilist) (if (null? olist) olist (reverse (cdr olist)))) (set! olist (cons (car ilist) olist)) (set! olist (cons (if (odd? i) "=" "&") olist)))))) (if (null? arglist) arglist (cons "?" arglist)))))) ;; Τα μέρη του λογου (define part-of-speech (list (cons "κανένα μέρος του λόγου" #f) (cons "ρήμα" "(dict.pos=\"μετ.\" OR dict.pos=\"αμετ.\" OR dict.pos=\"μετ.,αμετ.\")") (cons "μεταβατικό" "dict.pos=\"μετ.\"") (cons "αμετάβατο" "dict.pos=\"αμετ.\"") (cons "άρθρο" "dict.pos=\"άρθρο\"") (cons "αριθμός" "dict.pos=\"αριθ.\"") (cons "επίθετο" "dict.pos=\"επίθ.\"") (cons "επίρρημα" "dict.pos=\"επίρρ.\"") (cons "επιφώνημα" "dict.pos=\"επιφ.\"") (cons "μετοχή" "dict.pos=\"μετοχή\"") (cons "μόριο" "dict.pos=\"μόριο\"") (cons "πρόθεση" "dict.pos=\"πρόθ.\"") (cons "σύνδεσμος" "dict.pos=\"σύνδ.\"") (cons "ουσιαστικό" "(dict.pos=\"ο\" OR dict.pos=\"η\" OR dict.pos=\"το\")"))) ;; Protect occurences of " in a string. ;; Usual backslash escapes do not work in INPUT widgets, so I ;; change all quotation marks to " ;; Possibly not the better solution, though... (define (protect string) (list->string (apply append (map (lambda (x) (if (eq? x #\") (list #\& #\# #\3 #\4 #\;) (list x))) (string->list string))))) (define (get-topic-list) (let ((conn (sql-connect sql-iface sql-host sql-port sql-database sql-username sql-password))) (cond (conn (let ((result (sql-query conn "SELECT ident,title FROM topic"))) (sql-connect-close conn) result)) (else #f)))) (define (main-form) (display "
") (display (_"Εισάγετε τη λέξη")) (display "
") (display (_"Επιλέξτε το μέρος του λόγου")) (display "") (let ((selected-choice (or (let ((s (cgi:value "POS"))) (if s (string->number s) #f)) 0)) (index 0)) (display "")) (display "
") (display (_"Επιλέξτε το θέμα")) (display "") (let ((topic-list (get-topic-list))) (if topic-list (let ((selected-choice (or (let ((s (cgi:value "TOPIC"))) (if s (string->number s) #f)) 0))) (display "")))) (display "

")) (define greek-postfix-map (list (cons #\: (list (cons "ι" "ϊ") (cons "υ" "ϋ") (cons "ί" "ΐ") (cons "ύ" "ΰ") (cons "θ" "ϊ") (cons "θ" "ϋ"))) (cons #\' (list (cons "α" "ά") (cons "Α" "Ά") (cons "ε" "έ") (cons "Ε" "Έ") (cons "η" "ή") (cons "Η" "Ή") (cons "ι" "ί") (cons "Ι" "Ί") (cons "ϊ" "ΐ") (cons "Ϊ" "Ϊ") (cons "ο" "ό") (cons "Ο" "Ό") (cons "υ" "ύ") (cons "Υ" "Ύ") (cons "θ" "ύ") (cons "Θ" "Ύ") (cons "ϋ" "ΰ") (cons "Ϋ" "Ϋ") (cons "ω" "ώ") (cons "Ω" "Ώ"))) (cons #\s (list (cons "κ" "ξ") (cons "π" "ψ"))))) (define greek-kbd-map (list (cons #\a "α") (cons #\A "Α") (cons #\b "β") (cons #\B "Β") (cons #\g "γ") (cons #\G "Γ") (cons #\d "δ") (cons #\D "Δ") (cons #\e "ε") (cons #\E "Ε") (cons #\z "ζ") (cons #\Z "Ζ") (cons #\h "η") (cons #\H "Η") (cons #\u "θ") (cons #\U "Θ") (cons #\i "ι") (cons #\I "Ι") (cons #\k "κ") (cons #\K "Κ") (cons #\l "λ") (cons #\L "Λ") (cons #\m "μ") (cons #\M "Μ") (cons #\n "ν") (cons #\M "Ν") (cons #\j "ξ") (cons #\J "Ξ") (cons #\o "ο") (cons #\O "Ο") (cons #\p "π") (cons #\P "Π") (cons #\r "ρ") (cons #\R "Ρ") (cons #\s "σ") (cons #\S "Σ") (cons #\w "ς") (cons #\W "Σ") (cons #\t "τ") (cons #\T "Τ") (cons #\y "υ") (cons #\Y "Υ") (cons #\f "φ") (cons #\F "Φ") (cons #\x "χ") (cons #\X "Χ") (cons #\c "ψ") (cons #\C "Ψ") (cons #\v "ω") (cons #\V "Ω"))) (define (after-thita? c) (member c (list #\a #\e #\i #\o #\y #\v))) ;;; Given input string in Greek transliteration, convert it to ;;; an equivalent Greek word in UTF-8 encoding. The input string is ;;; supposed to follow the traditional Greek keyboard layout: ;;; ;;; +----------------------------------------------------------------+ ;;; | 1! | 2@ | 3# | 4$ | 5% | 6^ | 7& | 8* | 9( | 0) | -_ | =+ | `~ | ;;; +----------------------------------------------------------------+ ;;; | ·― | ςΣ | εΕ | ρΡ | τΤ | υΥ | θΘ | ιΙ | οΟ | πΠ | [{ | ]} | ;;; +------------------------------------------------------------+ ;;; | αΑ | σΣ | δΔ | φΦ | γΓ | ηΗ | ξΞ | κΚ | λΛ | ΄¨ | '" | \| | ;;; +-----------------------------------------------------------+ ;;; | ζΖ | χΧ | ψΨ | ωΩ | βΒ | νΝ | μΜ | ,; | .: | /? | ;;; +-------------------------------------------------+ ;;; +-----------------------------+ ;;; | space bar | ;;; +-----------------------------+ ;;; ;;; ;;; The followin escape sequences are recognized: ;;; ;;; '\ks' -> 'ξ' ;;; '\ps' -> 'ψ' ;;; '\th' -> 'θ' ;;; ;;; Additionally some spell fixing heuristics is applied: ;;; ;;; 's' at the end of the word -> 'ς' ;;; 'w' anywhere but at the end of the word -> 'ω' ;;; 'ks' -> 'ξ' ;;; 'ps' -> 'ψ' ;;; "th" -> 'θ' unless followed by a consonant ;;; "u'" -> 'ύ' ;;; ;;; FIXME: The case of less obvious spelling errors, like e.g. 'ou' -> 'ου' ;;; will be handled by later spelling corrections if fuzzy search is ;;; enabled (define (translate-kbd str) (apply string-append (do ((sl (string->list str) (cdr sl)) (l '())) ((null? sl) (reverse l)) (letrec ((decode-kbd-map (lambda () (let ((g (assoc (let ((c (car sl))) (cond ((and (char=? c #\w) (not (null? (cdr sl)))) #\v) ((and (char=? c #\s) (null? (cdr sl))) #\w) (else c))) greek-kbd-map))) (if g (set! l (cons (cdr g) l)) (if (char=? (car sl) #\\) (cond ((> (length sl) 2) (cond ((char=? (car (cdr (cdr sl))) #\s) (let ((c (car (cdr sl)))) (cond ((char=? c #\k) (set! sl (cdr (cdr sl))) (set! l (cons "ξ" l))) ((char=? c #\p) (set! sl (cdr (cdr sl))) (set! l (cons "ψ" l))) (else (set! sl (cdr sl)))))) ((and (char=? (car (cdr sl))) (char=? (car (cdr (cdr sl))) #\h)) (set! sl (cdr (cdr sl))) (set! l (cons "θ" l))))) (else (set! l (cons (string (car sl)) l)))))))))) (if (null? l) (decode-kbd-map) (cond ((char=? (car sl) #\h) (if (and (not (null? (cdr sl))) (after-thita? (car (cdr sl)))) (set-car! l "θ") (decode-kbd-map))) ((assoc (car sl) greek-postfix-map) => (lambda (cmap) (let ((x (assoc (car l) (cdr cmap)))) (if x (set-car! l (cdr x)) (decode-kbd-map))))) (else (decode-kbd-map)))))))) ;; Translate the input string to UTF-8 if necessary. (define (translate-input input) (if (< (char->integer (string-ref input 0)) 127) (translate-kbd input) input)) (define transcription-list (list (cons "μπ" "b" ) (cons "γγ" "g" ) (cons "γκ" "g" ) (cons "γχ" "g" ) (cons "ντ" "d" ) (cons "αι" "e" ) (cons "αί" "e" ) (cons "αυ" "au") (cons "αύ" "au") (cons "ου" "ou") (cons "ού" "ou") (cons "ευ" "eu") (cons "εύ" "eu") (cons "οι" "i" ) (cons "ει" "i" ) (cons "εί" "i" ) (cons "υι" "i" ) (cons "α" "a" ) (cons "Α" "a" ) (cons "Ά" "a" ) (cons "ά" "a" ) (cons "β" "b" ) (cons "Β" "b" ) (cons "γ" "g" ) (cons "Γ" "g" ) (cons "δ" "d" ) (cons "Δ" "d" ) (cons "ε" "e" ) (cons "Ε" "e" ) (cons "Έ" "e" ) (cons "έ" "e" ) (cons "ζ" "z" ) (cons "Ζ" "z" ) (cons "η" "i" ) (cons "Η" "i" ) (cons "Ή" "i" ) (cons "ή" "i" ) (cons "θ" "t" ) (cons "Θ" "t" ) (cons "ι" "i" ) (cons "Ι" "i" ) (cons "Ί" "i" ) (cons "ί" "i" ) (cons "κ" "k" ) (cons "Κ" "k" ) (cons "λ" "l" ) (cons "Λ" "l" ) (cons "μ" "m" ) (cons "Μ" "m" ) (cons "ν" "n" ) (cons "Ν" "n" ) (cons "ξ" "x" ) (cons "Ξ" "x" ) (cons "ο" "o" ) (cons "Ο" "o" ) (cons "Ό" "o" ) (cons "ό" "o" ) (cons "π" "p" ) (cons "Π" "p" ) (cons "ρ" "r" ) (cons "Ρ" "r" ) (cons "σ" "s" ) (cons "Σ" "s" ) (cons "ς" "s" ) (cons "τ" "t" ) (cons "Τ" "t" ) (cons "υ" "i" ) (cons "Υ" "i" ) (cons "Ύ" "i" ) (cons "ύ" "i" ) (cons "φ" "f" ) (cons "Φ" "f" ) (cons "χ" "h" ) (cons "Χ" "h" ) (cons "ψ" "P" ) (cons "Ψ" "P" ) (cons "ω" "o" ) (cons "Ω" "o" ) (cons "Ώ" "o" ) (cons "ώ" "o" ) (cons "Ϊ" "i" ) (cons "ΐ" "i" ) (cons "Ϋ" "i" ) (cons "ΰ" "i" ))) (define (greek-to-transcription str) (let ((len (string-length str))) (do ((i 0) (sl '())) ((= i len) (apply string-append (reverse sl))) (set! sl (cons (cond ((and (<= (+ i 4) len) (assoc (substring str i (+ i 4)) transcription-list)) => (lambda (x) (set! i (+ i 4)) (cdr x))) ((and (<= (+ i 2) len) (assoc (substring str i (+ i 2)) transcription-list)) => (lambda (x) (set! i (+ i 2)) (cdr x))) (else (set! i (1+ i)) (substring str (- i 1) i))) sl))))) (define (encode-string str) (apply string-append (map (lambda (x) (let ((n (char->integer x))) (if (or (and (> n 97) (< n 122)) (and (> n 65) (< n 90)) (and (> n 48) (< n 57))) (string x) (let ((s (number->string n 16))) (string-append "%" (if (< n 16) "0" "") s))))) (string->list str)))) (define (decode-string str) (do ((i 0) (sl '())) ((= i (string-length str)) (list->string (reverse sl))) (let ((c (string-ref str i))) (set! sl (cons (cond ((char=? c #\%) (set! i (+ i 3)) (integer->char (string->number (substring str (- i 2) i) 16))) (else (set! i (1+ i)) c)) sl))))) ;; (define (replace-tilde word sentence) (apply string-append (let loop ((lst '()) (str sentence)) (cond ((string-index str #\~) => (lambda (x) (loop (append lst (list (substring str 0 x) word)) (substring str (1+ x))))) ((string-null? str) lst) (else (append lst (list str))))))) ;; (define (display-results rlist) (let ((x (car rlist))) (display "") (display "") (cond ((list-ref x 3) (display ""))) (display "")) (for-each (lambda (x) (display "")) rlist) (display "
") (display (car x)) (display "") (let ((href (assoc (list-ref x 2) word-forms-reference))) (cond (href (display "") (display (list-ref x 3)) (display "")) (else (display (list-ref x 3))))) (display "") (display (list-ref x 2)) (display "
") (display (1+ (string->number (list-ref x 4)))) (display "") (display (replace-tilde (car x) (list-ref x 5))) (display ";
") (newline)) (define (display-cross-reference word) (display "") (display word) (display "")) (define (display-xref rlist text) (display text) (let ((n 0)) (for-each (lambda (x) (if (> n 0) (display ", ")) (set! n (1+ n)) (display-cross-reference (car x))) rlist)) (display ";")) (define (sort-result input-list) (let ((output-list '()) (current-element '())) (for-each (lambda (x) (cond ((or (null? current-element) (= (string->number (cadr x)) (string->number (cadr (car current-element))))) (set! current-element (cons x current-element))) (else (set! output-list (cons (reverse current-element) output-list)) (set! current-element (list x))))) input-list) (cons (reverse current-element) output-list))) (define (search-failure key) (display "

") (format #t (_"Συγγνώμη, η λέξη \"~A\" δεν βρέθηκε στο λέξικο.") key) (display "

")) (define (fuzzy-search conn key theme pos) (let ((result (sql-query conn (cond ((> (string->number theme) 0) (string-append "SELECT dict.word FROM dict,topic_tab WHERE " (cond ((not (string-null? key)) (string-append "dict.sound LIKE \"" (greek-to-transcription key) "%\" AND ")) (else "")) "topic_tab.topic_ident=" theme " AND topic_tab.word_ident=dict.ident " (if (> (string->number pos) 0) (let ((pos-entry (list-ref part-of-speech (string->number pos)))) (string-append "AND " (cdr pos-entry))) "") " order by word")) (else (string-append "SELECT word FROM dict WHERE sound like \"" (greek-to-transcription key) "%\" " (if (> (string->number pos) 0) (let ((pos-entry (list-ref part-of-speech (string->number pos)))) (string-append "AND " (cdr pos-entry))) "") " ORDER BY WORD")))))) (cond ((null? result) (search-failure key)) (else (display "") (let* ((result-length (length result)) (lim (1+ (inexact->exact (/ result-length match-list-columns))))) (do ((i 0 (1+ i))) ((= i lim) #f) (display "") (do ((j i (+ j lim))) ((>= j result-length) #f) (display "")) (display ""))) (display "
") (display-cross-reference (car (list-ref result j))) (display "
"))))) (define (dict-search) (let ((keyval (if (cgi:value "IDENT") (decode-string (cgi:value "IDENT")) (cgi:value "key"))) (theme (or (cgi:value "TOPIC") "0")) (pos (or (cgi:value "POS") "0"))) (cond ((and keyval (not (string-null? keyval)) (= (string->number theme) 0) (= (string->number pos) 0)) (let ((conn (sql-connect sql-iface sql-host sql-port sql-database sql-username sql-password))) (cond ((not conn) (format #t "

~A

\n" "ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε.")) (else (display "
") (let* ((key (translate-input keyval)) (result (sql-query conn (string-append "SELECT dict.word,dict.ident,dict.pos,dict.forms,articles.subindex,articles.meaning from dict,articles where dict.word=\"" key "\" and dict.ident=articles.ident order by dict.ident, articles.subindex")))) (cond ((null? result) (fuzzy-search conn key theme pos)) (else (for-each (lambda (entry) (display-results entry) (let ((ant (sql-query conn (string-append "SELECT dict.word FROM dict,antonym WHERE antonym.ident=" (cadr (car entry)) " AND dict.ident=antonym.antonym ORDER BY word")))) (if (and ant (not (null? ant))) (display-xref ant (if (= (length ant) 1) (_"Антоним: ") (_"Антонимы: "))))) (display "

") (let ((x (sql-query conn (string-append "SELECT dict.word FROM dict,xref WHERE xref.ident=" (cadr (car entry)) " AND dict.ident=xref.xref ORDER BY word")))) (if (and x (not (null? x))) (display-xref x (_"См. также "))))) (sort-result result)))) (sql-connect-close conn)))))) ((or (> (string->number theme) 0) (> (string->number pos) 0)) (let ((conn (sql-connect sql-iface sql-host sql-port sql-database sql-username sql-password))) (cond ((not conn) (format #t "

\n" (_"ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε."))) (else (display "
") (fuzzy-search conn "" theme pos) (sql-connect-close conn)))))))) ;;; (define (dict-html) (do ((line (read-line) (read-line))) ((eof-object? line) #f) (cond ((string=? line "@@dict@@") (main-form) (dict-search)) (else (display line) (newline))))) ;;; Main (display "Content-type: text/html; charset=utf-8\r\n\r\n") (with-input-from-file (template-file target-language) dict-html) ;;;; Local variables: ;;;; mode: Scheme ;;;; buffer-file-coding-system: utf-8 ;;;; End: