From cf6bfb57a877b35ffae958c2baa11fc4bebd93e5 Mon Sep 17 00:00:00 2001 From: Sergey Poznyakoff Date: Fri, 13 Feb 2004 14:21:02 +0000 Subject: Initial revision git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@2 941c8c0f-9102-463b-b60b-cd22ce0e6858 --- cgi-bin/dict.cgi | 658 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 658 insertions(+) create mode 100755 cgi-bin/dict.cgi (limited to 'cgi-bin') diff --git a/cgi-bin/dict.cgi b/cgi-bin/dict.cgi new file mode 100755 index 0000000..6d7457e --- /dev/null +++ b/cgi-bin/dict.cgi @@ -0,0 +1,658 @@ +#!/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. +;;;; + +(set! %load-path (append %load-path (list "/usr/local/share/guile-sql"))) +(use-modules (www cgi)) +(use-modules (sql)) +(cgi:init) + +;;; User-definable variables +(define dict-cgi-path "/cgi-bin/dict.cgi") +(define sql-iface "mysql") +(define sql-host "localhost") +(define sql-port 3306) +(define sql-database "ellinika") +(define sql-username "gray") +(define sql-password "Imbabura") +;;; End of user-definable variables + +;; Τα μέρη του λογου +(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 (dict-html-start) + (display "Content-type: text/html; charset=utf-8\r\n\r\n") + (display " + + + Ellinika + + + +

Ελληνορώσικο λέξικο

+
")) + +(define (dict-html-end) + (display "")) + +(define (main-form) + (display "
+ + + + + + + + + + + +
+ + + +
") + + (display "Διαλέξτε το μέρος του λόγου") + + (let ((selected-choice (or (let ((s (cgi:value "POS"))) + (if s + (string->number s) + #f)) + 0)) + (index 0)) + + (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 "Ω"))) + + +;;; 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 2) len) + (assoc (substring str i (+ i 4)) transcription-list)) => + (lambda (x) + (set! i (+ i 4)) + (cdr x))) + ((assoc (substring str i (+ i 2)) transcription-list) => + (lambda (x) + (set! i (+ i 2)) + (cdr x))) + (else + (set! i (1+ i)) + (substring str i (+ i 1)))) + 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 "") + (cond + ((list-ref x 3) + (display ""))) + (display "")) + (for-each + (lambda (x) + (display "")) + rlist) + (display "
") + (display (car x)) + (display "") + (display (list-ref x 3)) + (display "") + (display (list-ref x 2)) + (display "
") + (display (1+ (string->number (list-ref x 4)))) + (display "") + (display (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 "

Sorry, \"") + (display key) + (display "\" was not found in the dictionary

")) + + +(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 "") + (for-each + (lambda (x) + (display "")) + result) + (display "
") + (display-cross-reference (car x)) + (display "
"))))) + + +(define (dict-search) + (let ((keyval (if (cgi:value "IDENT") + (decode-string (cgi:value "IDENT")) + (cgi:value "key"))) + (theme (cgi:value "TOPIC")) + (pos (cgi:value "POS"))) + (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) + (display "

ERROR: cannot connect to the dictionary

\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) + (display "

ERROR: cannot connect to the dictionary

\n")) + (else + (display "
") + (fuzzy-search conn "" theme pos) + (sql-connect-close conn)))))))) + +;;; Main +(dict-html-start) +(main-form) +(dict-search) +(dict-html-end) + +;;;; Local variables: +;;;; mode: Scheme +;;;; buffer-file-coding-system: utf-8 +;;;; End: + -- cgit v1.2.1