;;;; Greek Dictionary Web Engine ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2010, 2011 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 3 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, see . ;;;; ;;; Tailor this statement to your needs if necessary. (set! %load-path (cons "GUILE_SITE" %load-path)) (use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user)) (ice-9 rdelim) (xmltools dict) (gamma sql) (ellinika elmorph) (ellinika sql) (ellinika i18n) (ellinika xlat) (ellinika cgi)) ifelse(IFACE,[CGI],(cgi:init)) (ellinika-cgi-init dict-template-file-name) ;; Τα μέρη του λόγου (define part-of-speech '()) (define (sql-error-handler key func fmt fmtargs data) (format #t "

~A

\n" (_ "ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε.")) (apply format (current-error-port) fmt fmtargs)) (define (load-pos) (sql-ignore-failure (let ((plist (ellinika:sql-query "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)))))) (define (get-topic-list) (let ((categories #f)) (letrec ((getcat (lambda () (sql-ignore-failure (let ((ctg (ellinika:sql-query "SELECT t.category, c.title, c.description\ FROM category c,topic t\ WHERE c.lang=~Q AND c.category=t.category GROUP BY 1 ORDER BY 1" (language-code target-language)))) (if (null? ctg) '() (map (lambda (category) (let ((topics (ellinika:sql-query "SELECT ident,title FROM topic WHERE category=~Q ORDER BY title" (car category)))) (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)) (word (car x)) (isverb (> (string->number (list-ref x 6)) 0))) (display "") (display "") (cond ((list-ref x 3) (display ""))) (display "") (if isverb (format #t "" (make-cgi-name (cgi-program-name "conj") "key" (dict:encode-string word)) (_ "κλίση"))) (display "")) (display "
") (display word) (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 "~A
") (newline) (display "
    ") (for-each (lambda (x) (display "
  1. ") (display (replace-tilde (car x) (list-ref x 5))) (display ";
  2. ")) 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 key theme pos) (let ((where-cond (list (string-append "WHERE dict.ident=articles.ident and articles.lang='" (utf8-escape (language-code target-language)) "' AND"))) (select-stmt "SELECT DISTINCT dict.word FROM ") (from-list (list ",articles" "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 \"" (utf8-escape (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 (sql-query ellinika:sql-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+ (quotient 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"))) (sql-catch-failure (cond ((and keyval (not (string-null? keyval)) (null? theme) (= (string->number pos) 0)) (display "
") (let* ((key (ellinika:translate-input keyval)) (result (ellinika:sql-query "SELECT dict.word,dict.ident,pos.abbr,\ dict.forms,articles.subindex,articles.meaning,(dict.pos & conv(\"100000\",16,10))\ FROM dict,articles,pos WHERE dict.word=~Q\ AND dict.ident=articles.ident\ AND articles.lang=~Q\ AND dict.pos=pos.id\ AND pos.canonical='Y' order by dict.ident, articles.subindex" key (language-code target-language)))) (cond ((null? result) (fuzzy-search key theme pos)) (else (for-each (lambda (entry) (display-results entry) (let ((ant (ellinika:sql-query "SELECT dict.word FROM dict,links\ WHERE links.type='ANT' AND links.ident=~Q AND dict.ident=links.xref\ ORDER BY word" (cadr (car entry))))) (if (and ant (not (null? ant))) (display-xref ant (if (= (length ant) 1) (_"Αντώνυμο: ") (_"Αντώνυμα: "))))) (display "

") (let ((x (ellinika:sql-query "SELECT dict.word FROM dict,links\ WHERE links.type='XREF' AND links.ident=~Q\ AND dict.ident=links.xref ORDER BY word" (cadr (car entry))))) (if (and x (not (null? x))) (display-xref x (_"Βλέπετε επίσης "))))) (sort-result result)))))) ((or (not (null? theme)) (> (string->number pos) 0)) (display "


") (fuzzy-search (ellinika:translate-input (or keyval "")) theme pos)))))) ;;; (define (stat key) (let ((stat-data #f)) (if (not stat-data) (set! stat-data (or (sql-ignore-failure (ellinika:sql-query "SELECT count,updated from stat WHERE lang=~Q" (language-code target-language))) '()))) (if (null? stat-data) "<>" (case key ((#:updated) (list-ref (car stat-data) 1)) ((#:count) (list-ref (car stat-data) 0)) (else "<>"))))) ;;; (define (dict-connect) (if (not ellinika:sql-conn) (ellinika:sql-connect ellinika-sql-connection))) (define (dict-html) (sql-catch-failure (let ((explist (list (cons "@@args@@" (lambda () (for-each (lambda (name) (cond ((string=? name "lang")) (else (let ((v (cgi:value name))) (cond ((and v (not (string-null? v))) (display "&") (display name) (display "=") (display v))))))) (cgi:names)))) (cons "@@dict@@" (lambda () (dict-connect) (main-form) (dict-search))) (cons "@@stat_updated@@" (lambda () (dict-connect) (display (stat #:updated)))) (cons "@@stat_count@@" (lambda () (dict-connect) (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)) (ellinika:sql-disconnect)))) ;;; Main ifelse(IFACE,[CGI],(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) ;;;; Local variables: ;;;; mode: Scheme ;;;; buffer-file-coding-system: utf-8 ;;;; End: