diff options
Diffstat (limited to 'cgi-bin/dict.cgi')
| -rwxr-xr-x | cgi-bin/dict.cgi | 728 |
1 files changed, 0 insertions, 728 deletions
diff --git a/cgi-bin/dict.cgi b/cgi-bin/dict.cgi deleted file mode 100755 index 637ab98..0000000 --- a/cgi-bin/dict.cgi +++ /dev/null @@ -1,728 +0,0 @@ -#!/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 rc-file-name "/home/gray/linguae/ellinika/etc/ellinika.conf") -(define base-href "http://localhost/") ;; Base HREF -(define home-page "http://cvs.farlep.net/~gray") ;; Author home page -(define dict-cgi-path "cgi-bin/dict.cgi") ;; Path to the cgi (relative - ;; to the Base ) -(define admin-email "gray@mirddin.farlep.net") ;; Administrator email address -(define admin-email-text "gray at mirddin.farlep.net") ;; Textual representation - ;; thereof - -(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 -(if (file-exists? rc-file-name) - (load rc-file-name)) - -;; Τα μέρη του λογου -(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 " -<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"> -<HTML> -<HEAD> - <TITLE>Ellinorosiko lexiko</TITLE> - <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\"> - <BASE HREF=\"") - (display base-href) - (display "\"> -</HEAD> -<BODY BGCOLOR=\"#000080\" TEXT=\"#000000\" LINK=\"#1F00FF\" ALINK=\"#FF0000\" VLINK=\"#9900DD\"> -<TABLE WIDTH=\"99%\" ALIGN=\"CENTER\" CELLSPACING=\"0\" CELLPADDING=\"10%\" BORDER=\"0\" BGCOLOR=\"#FFFFFF\"> -<TR> - <TD VALIGN=TOP width=\"20%\"> - <IMG SRC=\"graphics/gnu-head-sm.jpg\" ALIGN=\"top\" ALT=\" [A GNU head] \"><P> - <TABLE WIDTH=\"100%\" ALIGN=\"LEFT\" CELLSPACING=\"0\" CELLPADDING=\"10%\" BORDER=\"0\" BGCOLOR=\"#FFFFFF\"> - <TR><TD BGCOLOR=\"#0063C1\"><CENTER><STRONG><FONT color=\"white\">Γραμματική</FONT></STRONG></CENTER></TD></TR> - <TR><TD><A HREF=\"ellinika/gram.html\">Γραμματική</A></TD></TR> - <TR><TD><A HREF=\"ellinika/arthra.html\">Τα άρθρα</A></TD></TR> - <TR><TD><A HREF=\"ellinika/oysiastika.html\">Τα ουσιαστικά</A></TD></TR> - <TR><TD><A HREF=\"ellinika/epitheta.html\">Τα επίθετα</A></TD></TR> - <TR><TD><A HREF=\"ellinika/antonimies.html\">Αντωνυμίες</A></TD></TR> - <TR><TD><A HREF=\"ellinika/rhmata.html\">Ρήματα</A></TD></TR> - <TR><TD><A HREF=\"") - (display home-page) - (display "\">Αρχική σελίδα</A></TD></TR> - - <TR><TD BGCOLOR=\"#0063C1\"><CENTER><STRONG><FONT color=\"white\">Πληροφορίες</FONT></STRONG></CENTER></TD></TR> - <TR><TD><A HREF=\"http://validator.w3.org/check/referer\"> - <img border=\"0\" src=\"graphics/valid-html401.png\" - alt=\"[ Valid HTML 4.01! ]\" height=\"31\" width=\"88\"></A></TD></TR> - - </TABLE> - </TD> - <TD VALIGN=top> - <H1 ALIGN=CENTER>Ελληνορωσικό λέξικο</H1> -<HR>")) - -(define (dict-html-end) - (display " - </TD> -</TR> -<TR> - <TD colspan=\"2\"> - <hr> -Για προτάσεις ή απορίες σχετικά με αυτήν τη σελίδα επικοινωνήστε στο -<<A HREF=\"mailto:") - (display admin-email) - (display "\">") - (display admin-email-text) - (display "</A>> - - </TD> -</TR> -</TABLE> -</BODY></HTML>")) - -(define (main-form) - (display "<FORM ACTION=\"") - (display dict-cgi-path) - (display "\" METHOD=POST> -<TABLE BORDER=0> -<TR> - <TD> - Εισάγετε τη λέξη - </TD> - <TD> - <INPUT size=36 NAME=\"key\" TABINDEX=\"1\"") - (let ((value (cgi:value "key"))) - (if value - (begin - (display "VALUE=\"") - (display (protect value)) - (display "\"")))) - (display "> - </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> -<TR> - <TD colspan=\"2\" align=center> - <INPUT TYPE=\"submit\" NAME=\"search\" VALUE=\"Αναζήτηση\" TABINDEX=\"4\"> - </TD> -</TR> -</TABLE> -</FORM> -<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 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 "<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>Συγγνώμη, η λέξη \"") - (display key) - (display "\" δεν βρέθηκε στο λέξικο.</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 WIDTH=\"100%\">") - (let* ((result-length (length result)) - (lim (1+ (inexact->exact (/ result-length match-list-columns))))) - (do ((i 0 (1+ i))) - ((= i lim) #f) - (display "<TR>") - (do ((j i (+ j lim))) - ((>= j result-length) #f) - (display "<TD>") - (display-cross-reference (car (list-ref result j))) - (display "</TD>")) - (display "</TR>"))) - (display "</TABLE>"))))) - - -(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) - (display "<H1>ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε.</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>ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε.</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: - |