aboutsummaryrefslogtreecommitdiff
path: root/cgi-bin
diff options
context:
space:
mode:
Diffstat (limited to 'cgi-bin')
-rwxr-xr-xcgi-bin/dict.cgi658
1 files changed, 658 insertions, 0 deletions
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 "
+<HTML>
+<HEAD>
+ <TITLE>Ellinika</TITLE>
+ <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
+</HEAD>
+<BODY BGCOLOR=\"#FFFFFF\" TEXT=\"#000000\" LINK=\"#1F00FF\" ALINK=\"#FF0000\" VLINK=\"#9900DD\">
+<H2>Ελληνορώσικο λέξικο</H2>
+<hr>"))
+
+(define (dict-html-end)
+ (display "</BODY></HTML>"))
+
+(define (main-form)
+ (display "<FORM ACTION=\"")
+ (display dict-cgi-path)
+ (display "\" METHOD=POST>
+<TABLE>
+<TR>
+ <TD>
+ <INPUT size=64 NAME=\"key\" TABINDEX=\"1\"")
+ (let ((value (cgi:value "key")))
+ (if value
+ (begin
+ (display (string-append "GOT VALUE " value "\n")
+ (current-error-port))
+ (display "VALUE=\"")
+ (display (protect value))
+ (display "\""))))
+ (display ">
+ </TD>
+ <TD>
+ <INPUT TYPE=\"submit\" NAME=\"search\" VALUE=\"Αναζήτηση\" TABINDEX=\"4\">
+ </TD>
+</TR>
+<TR>
+ <TD>")
+
+ (display "Διαλέξτε το μέρος του λόγου</TD><TD>")
+
+ (let ((selected-choice (or (let ((s (cgi:value "POS")))
+ (if s
+ (string->number s)
+ #f))
+ 0))
+ (index 0))
+
+ (display "<SELECT NAME=\"POS\" TABINDEX=\"2\">")
+
+ (for-each
+ (lambda (x)
+ (let ((name (car x)))
+ (display "<OPTION VALUE=")
+ (display index)
+ (if (= index selected-choice)
+ (display " selected"))
+ (display ">")
+ (display name)
+ (set! index (1+ index))))
+ part-of-speech)
+ (display "</SELECT>"))
+
+ (display "
+ </TD>
+</TR>
+<TR>
+ <TD>")
+
+ (display "Διαλέξτε η θέμα</TD><TD>")
+ (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 "<SELECT NAME=\"TOPIC\" TABINDEX=\"3\">")
+ (display "<OPTION VALUE=0>καμία θέμα")
+ (for-each
+ (lambda (x)
+ (let ((id (car x))
+ (name (car (cdr x))))
+ (display "<OPTION VALUE=")
+ (display id)
+ (if (eq? (string->number id) selected-choice)
+ (display " selected"))
+ (display ">")
+ (display name)))
+ topic-list)
+ (display "</SELECT>"))))
+
+ (display "
+ </TD>
+</TR>
+</TABLE>
+<P>"))
+
+
+(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 "<TABLE BORDER=0>")
+ (display "<TR><TD>")
+ (display (car x))
+ (display "</TD>")
+ (cond
+ ((list-ref x 3)
+ (display "<TD>")
+ (display (list-ref x 3))
+ (display "</TD>")))
+ (display "<TD>")
+ (display (list-ref x 2))
+ (display "</TD></TR>"))
+ (for-each
+ (lambda (x)
+ (display "<TR><TD>")
+ (display (1+ (string->number (list-ref x 4))))
+ (display "</TD><TD>")
+ (display (list-ref x 5))
+ (display ";</TD></TR>"))
+ rlist)
+ (display "</TABLE>")
+ (newline))
+
+(define (display-cross-reference word)
+ (display "<A HREF=\"")
+ (display dict-cgi-path)
+ (display "?IDENT=")
+ (display (encode-string word))
+ (display "\">")
+ (display word)
+ (display "</A>"))
+
+(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 "<H2>Sorry, \"")
+ (display key)
+ (display "\" was not found in the dictionary</H2>"))
+
+
+(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 "<TABLE>")
+ (for-each
+ (lambda (x)
+ (display "<TR><TD>")
+ (display-cross-reference (car x))
+ (display "</TD></TR>"))
+ result)
+ (display "</TABLE>")))))
+
+
+(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 "<H1>ERROR: cannot connect to the dictionary</H1>\n"))
+ (else
+ (display "<HR>")
+ (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 "<P>")
+ (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 "<H1>ERROR: cannot connect to the dictionary</H1>\n"))
+ (else
+ (display "<HR>")
+ (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:
+

Return to:

Send suggestions and report system problems to the System administrator.