#!/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 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 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 (template-file lang)
(let ((name (cond
((string-index lang #\_) =>
(lambda (len)
(substring lang 0 len)))
(else
lang))))
(string-append html-dir "/" name "/" 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
(cons "?"
(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))))))))
;; Τα μέρη του λογου
(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=\"ο\" 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 "
"))
(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 "Ω")))
;;; Given input string in Greek transliteration, convert it to
;;; an equivalent Greek work 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 |
;;; +-----------------------------+
;;;
;;; 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' -> 'ψ'
;;; "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))
(set! l (cons (string (car sl)) l)))))))
(if (null? l)
(decode-kbd-map)
(let ((cmap (assoc (car sl) greek-postfix-map)))
(cond
(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.
;; FIXME: currently does nothing
(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 "υ" "ι" )
(cons "Υ" "ι" )
(cons "Ύ" "ι" )
(cons "ύ" "ι" )
(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 (display-results rlist)
(let ((x (car rlist)))
(display "
")
(display "| ")
(display (car x))
(display " | ")
(cond
((list-ref x 3)
(display "")
(display (list-ref x 3))
(display " | ")))
(display "")
(display (list-ref x 2))
(display " |
"))
(for-each
(lambda (x)
(display "| ")
(display (1+ (string->number (list-ref x 4))))
(display " | ")
(display (list-ref x 5))
(display "; |
"))
rlist)
(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-cross-reference (car (list-ref result j)))
(display " | "))
(display "
")))
(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)))
(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: