#! =GUILE_BINDIR=/guile -s =AUTOGENERATED= !# ;;;; Greek Dictionary Web Engine ;;;; Copyright (C) 2004, 2005 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. ;;;; ;;; Tailor this statement to your needs if necessary. ;=GUILE_COMMENT=;(set! %load-path (cons "=GUILE_SITE=" %load-path)) (use-modules (www cgi) (gamma sql) (gamma gettext) (xmltools dict) (ellinika xlat) (ellinika cgi)) (cgi:init) (ellinika-cgi-init dict-template-file-name) ;; Τα μέρη του λογου (define part-of-speech '()) (define (sql-error-handler err descr) (format #t "

~A

\n" (_ "ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε.")) (with-output-to-port (current-error-port) (lambda () (display err) (display ": ") (display descr)))) (define (mk-dict-connect) (let ((db-connection #f)) (lambda (. rest) (cond ((null? rest) (if (not db-connection) (begin (set! db-connection (sql-connect sql-iface sql-host sql-port sql-database sql-username sql-password)) (sql-query db-connection "SET NAMES utf8") ))) (else (if db-connection (sql-connect-close db-connection)) (set! db-connection #f))) db-connection))) (define dict-connect (mk-dict-connect)) (defmacro catch-sql-failure (expr) `(catch 'gsql-error (lambda () ,expr) (lambda (key err descr) (sql-error-handler err descr)))) (defmacro ignore-sql-failure (expr) `(catch 'gsql-error (lambda () ,expr) (lambda (key err descr) #f))) (define (load-pos) (ignore-sql-failure (let ((conn (dict-connect))) (let ((plist (my-sql-query conn "SELECT name,id FROM pos WHERE canonical='Y' order by id"))) (set! part-of-speech (cons (cons "κανένα μέρος του λόγου" #f) (map (lambda (x) (cons (car x) (cadr x))) plist))))))) ;; 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 ((categories #f)) (letrec ((getcat (lambda () (ignore-sql-failure (let ((conn (dict-connect))) (let ((ctg (my-sql-query conn "SELECT category, title, description FROM category ORDER BY category"))) (if (null? ctg) '() (map (lambda (category) (let ((topics (my-sql-query conn (string-append "SELECT ident,title FROM topic WHERE category=" (car category) " ORDER BY title")))) (append category (if (null? topics) '() (list topics))))) ctg)))))))) (if (not categories) (set! categories (or (getcat) '()))) categories))) (define (join-widget widget-id tabindex) (let* ((name (string-append "join" widget-id)) (selected-choice (or (let ((s (cgi:value name))) (if s (string->number s) #f)) 0))) (display (string-append ""))) (define (main-form) (load-pos) (display "
") (display "") (display " ") (let ((tabindex 4)) (for-each (lambda (category) (display "") (set! tabindex (1+ tabindex)))) (get-topic-list)) (display "
") (display (_"Εισάγετε τη λέξη")) (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 "") (join-widget "pos" "3") (display "
") (display (list-ref category 1)) (display "") (let ((selected-choice (or (let ((s (cgi:value (list-ref category 0)))) (if s (string->number s) #f)) 0))) (display (string-append "") (display "") (join-widget (list-ref category 0) (number->string tabindex)) (display "

"))) ;; (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 (my-sql-query conn query) (catch #t (lambda () (sql-query conn query)) (lambda args '()))) (define (fuzzy-search conn key theme pos) (let ((where-cond (list "WHERE")) (select-stmt "SELECT DISTINCT dict.word FROM ") (from-list (list "dict"))) (cond ((not (null? theme)) (set! where-cond (cons " topic_tab.word_ident=dict.ident" where-cond)) (set! from-list (cons ",topic_tab" from-list)))) (cond ((not (string-null? key)) (if (not (null? theme)) (set! where-cond (cons " AND" where-cond))) (set! where-cond (cons (string-append " dict.sound LIKE \"" (ellinika:sounds-like key) "%\"") where-cond)))) (cond ((> (string->number pos) 0) (let ((pos-entry (list-ref part-of-speech (string->number pos)))) (if (or (not (string-null? key)) (not (null? theme))) (set! where-cond (cons (if (string=? (cgi:value "joinpos") "0") " AND" " OR") where-cond))) (set! where-cond (cons (string-append " (dict.pos & " (cdr pos-entry) ") = " (cdr pos-entry)) where-cond))))) (let ((result (my-sql-query conn (string-append select-stmt " " (apply string-append (reverse from-list)) " " (apply string-append (append (reverse where-cond) (map (lambda (x) (cond ((boolean? x) (if x " AND" " OR")) (else (if (not (member ",topic_tab" from-list)) (set! from-list (cons ",topic_tab" from-list))) (string-append " topic_tab.topic_ident=" x)))) theme))) " ORDER BY dict.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") (dict:decode-string (cgi:value "IDENT")) (cgi:value "key"))) (theme (do ((catlist (get-topic-list) (cdr catlist)) (ret '())) ((null? catlist) ret) (let ((name (caar catlist))) (let ((v (cgi:value name))) (if (and v (> (string->number v) 0)) (set! ret (append ret (list (= (string->number (cgi:value (string-append "join" name))) 0) v)))))))) (pos (or (cgi:value "POS") "0"))) (catch-sql-failure (let ((conn (dict-connect))) (cond ((and keyval (not (string-null? keyval)) (null? theme) (= (string->number pos) 0)) (display "
") (let* ((key (ellinika:translate-input keyval)) (result (my-sql-query conn (string-append "SELECT dict.word,dict.ident,pos.abbr,dict.forms,articles.subindex,articles.meaning FROM dict,articles,pos WHERE dict.word=\"" key "\" and dict.ident=articles.ident and dict.pos=pos.id and pos.canonical='Y' 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 (my-sql-query conn (string-append "SELECT dict.word FROM dict,links WHERE links.type='ANT' AND links.ident=" (cadr (car entry)) " AND dict.ident=links.xref ORDER BY word")))) (if (and ant (not (null? ant))) (display-xref ant (if (= (length ant) 1) (_"Антоним: ") (_"Антонимы: "))))) (display "

") (let ((x (my-sql-query conn (string-append "SELECT dict.word FROM dict,links WHERE links.type='XREF' AND links.ident=" (cadr (car entry)) " AND dict.ident=links.xref ORDER BY word")))) (if (and x (not (null? x))) (display-xref x (_"См. также "))))) (sort-result result)))))) ((or (not (null? theme)) (> (string->number pos) 0)) (display "


") (fuzzy-search conn (ellinika:translate-input (or keyval "")) theme pos))))))) ;;; (define (stat key) (let ((stat-data #f)) (if (not stat-data) (set! stat-data (or (ignore-sql-failure (my-sql-query (dict-connect) "SELECT count,updated from stat")) '()))) (if (null? stat-data) "<>" (case key ((#:updated) (list-ref (car stat-data) 1)) ((#:count) (list-ref (car stat-data) 0)) (else "<>"))))) ;;; (define (dict-html) (let ((explist (list (cons "@@dict@@" (lambda () (main-form) (dict-search))) (cons "@@stat_updated@@" (lambda () (display (stat #:updated)))) (cons "@@stat_count@@" (lambda () (display (let ((s (stat #:count))) (if (string=? s "<>") s (let ((n (string->number s))) (string-append s " " (ngettext "λέξη" "λέξεις" n))))))))))) (do ((line (read-line) (read-line))) ((eof-object? line) #f) (expand-template explist line) (newline)))) ;;; Main (display "Content-type: text/html; charset=utf-8\r\n\r\n") (with-input-from-file (template-file target-language dict-template-file-name) dict-html) (dict-connect #t) ;;;; Local variables: ;;;; mode: Scheme ;;;; buffer-file-coding-system: utf-8 ;;;; End: