;;;; 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)) (srfi srfi-1) (ice-9 rdelim) (ice-9 optargs) (xmltools dict) (ellinika config) (ellinika elmorph) (ellinika tenses) (ellinika conjugator) (ellinika sql) (ellinika i18n) (ellinika xlat) (ellinika cgi)) ifelse(IFACE,[CGI],(cgi:init)) (define conj-template-file-name "conj.html") (ellinika-cgi-init conj-template-file-name) (define (sql-error-handler key func fmt fmtargs data) (format #t "

~A

\n" (_ "ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε.")) (apply format (current-error-port) fmt fmtargs)) ;;; (define (dict-connect) (if (not ellinika:sql-conn) (ellinika:sql-connect ellinika-sql-connection))) (define (main-form) (format #t "
" (make-cgi-name cgi-script-name)) (display "\
") (display (_"Εισάγετε το ρήμα")) (display "
")) (define tense-driver-list '(("ind" 3 5) ("sub" 3) ("imp" 3))) (define unattested '()) ; List of unattested flags (define (table-header count tenses) (display "\ ") (for-each (lambda (tense) (let ((tense-name (car tense)) (att (fold (lambda (conj prev) (let ((att (conjugation:attested conj))) (if att (append att prev) prev))) '() (cdr tense)))) (display "") (newline))) tenses) (display "")) (define (table-footer) (display "
") (cond ((not (member 'stem att)) (display "? ") (if (not (member 'stem unattested)) (set! unattested (cons 'stem unattested))))) (display tense-name) (display "
")) (define (transpose mtx) (let* ((w (length (car mtx))) (res (make-list w))) (do ((i 0 (1+ i))) ((= i w)) (list-set! res i (map (lambda (row) (list-ref row i)) mtx))) res)) (define (compact-conj-list conj) (map (lambda (x) (fold-right (lambda (elt prev) (if (member elt prev) prev (cons elt prev))) '() x)) conj)) (define (concat-unique lst) (fold (lambda (elt prev) (if prev (string-append prev ",
" elt) elt)) #f lst)) (define (format-tenses count tense-list voice mood) (let ((prosopa (if (string=? mood "imp") '(2 5) '(1 2 3 4 5 6)))) (for-each (lambda (row pers class) (cond ((member pers prosopa) (format #t "" class) (for-each (lambda (x) (let ((val (concat-unique x))) (format #t "~A" (if val val "--")))) row) (display "")))) (transpose (map (lambda (conj) (compact-conj-list (transpose (map conjugation:table conj)))) tense-list)) '(1 2 3 4 5 6) '("odd" "even" "odd" "even" "odd" "even")))) (define (show-conjugation:mood voice mood tense-list) (format #t "

~A

" (ellinika-conjugation-term mood)) (for-each (lambda (count) (let ((tenses (list-head tense-list count))) (table-header count tenses) (format-tenses count (map cdr tenses) voice mood) (table-footer) (set! tense-list (list-tail tense-list count)) (if (not (null? tense-list)) (display "

")))) (assoc-ref tense-driver-list mood)) (display "
")) (define (show-conjugation:voice voice) (format #t "

~A

" (ellinika-conjugation-term (car voice))) (for-each (lambda (mood-tenses) (show-conjugation:mood voice (car mood-tenses) (cdr mood-tenses))) (cdr voice)) (display "
")) (define (conjugate-all verb) (map (lambda (voice) (cons voice (map (lambda (mood-tenses) (let ((mood (car mood-tenses))) (cons mood (map (lambda (tense) (cons tense (conjugator verb voice mood tense))) (cdr mood-tenses))))) ellinika-tense-list))) '("act" "pas"))) (define (force-string str) (if (elstr? str) (elstr->string str) str)) (define (error-message fmtstr . fmtargs) (display "

") (apply format #t fmtstr fmtargs) (display "

")) (define (class-attested? result) (call-with-current-continuation (lambda (return) (for-each (lambda (voice) (for-each (lambda (mood) (for-each (lambda (tense-list) (for-each (lambda (tense) (if (and (not (empty-conjugation? tense)) (conjugation:attested tense)) (return (member 'class (conjugation:attested tense))))) (cdr tense-list))) (cdr mood))) (cdr voice))) result) (return #f)))) (define (show-conjugation verb) (catch #t (lambda () (let ((descr (ellinika:sql-query "SELECT articles.meaning\ FROM dict,articles\ WHERE dict.word=~Q AND dict.ident=articles.ident\ AND articles.lang=~Q AND (dict.pos & 1048576) = 1048576\ ORDER BY articles.subindex\ LIMIT 1" verb (language-code target-language)))) (cond ((and descr (not (null? descr))) (format #t "

~A - ~A

" (make-cgi-name (cgi-program-name "dict") "ident" (dict:encode-string verb)) verb (caar descr))) (else (format #t "

~A - (~A)

" verb (_ "δεν βρέθηκε στο λέξικο"))))) (let ((result (conjugate-all verb))) (if (not (class-attested? result)) (format #t "

~A

" (_ "Η συζυγία αυτό του ρήματος δεν επιβεβαιώνεται από τη βάση δεδοµένων"))) (for-each (lambda (voice) (show-conjugation:voice voice)) result))) (lambda (key . args) (case key ((conjugator-error) (let-optional args (subkey fmtstr fmtargs) (case subkey ((conjugator-error-input) (error-message (_ "Μη έγκυρη είσοδος"))) (else (error-message "CONJUGATOR ERROR: ~A ~A" subkey (apply format #f fmtstr fmtargs)))))) ((misc-error) (let-optional args (func-name fmtstr fmtargs sys-err) (error-message "MISC ERROR in ~A: ~A" func-name (apply format #f fmtstr (map force-string fmtargs))))) (else (error-message "OTHER ERROR: ~S ~S" key args)))))) (define (show-conjugation-simple verb) (for-each (lambda (voice) (show-conjugation:voice voice)) (conjugate-all verb))) (define (search-failure key) (display "

") (format #t (_"Συγγνώμη, η λέξη \"~A\" δεν βρέθηκε στο λέξικο.") key) (display "

")) (define (display-cross-reference word) (display "") (display word) (display "")) (define (show-best-matches key) (let ((result (ellinika:sql-query "SELECT DISTINCT word\ FROM dict\ WHERE sound LIKE ~Q\ AND (pos & 1048576) <> 0 ORDER BY 1" (ellinika:sounds-like key)))) (cond ((null? result) (search-failure key)) ((= (length result) 1) (show-conjugation (caar result))) (else (format #t "

~A

" (_ "Στην λέξη εισαγωγής δεν υπάρχει τόνος. Μήπος θέλατε να κλίσετε ένα απ'αυτά τα ρήματα:")) (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 (do-conj) (let ((keyval (cgi:value "key"))) (if (and keyval (not (string-null? keyval))) (let ((input (ellinika:translate-input (let ((keyval keyval)) (cond ((string-suffix? "o'" keyval) (string-set! keyval (- (string-length keyval) 2) #\v)) ((string-suffix? "o" keyval) (string-set! keyval (- (string-length keyval) 1) #\v))) keyval)))) (cond ((not (elstr-suffix? input "ω" "ώ" "ομαι" "αμαι")) (format #t "

~A

" (_ "Αυτή η λέξη δεν είναι ρήμα στο πρώτο ενικό πρόσωπο της οριστικής του ενεστώτα."))) ((= (elstr-accented-syllable input) 0) (show-best-matches input)) (else (show-conjugation input))))))) (define (print-footnote id sign text) (format #t "

~A  ~A

~%" id sign text)) (define (footnotes) (display "
") (for-each (lambda (flag) (case flag ((class) (print-footnote "class-na" "*" "Conjugation class of this verb is not attested")) ((root) (print-footnote "stem-na" "?" (_ "Το θέμα αυτού του χρόνου δεν επιβεβαιώνεται από τη βάση δεδοµένων"))))) unattested) (display "
")) (define (conj-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 "@@conj@@" (lambda () (dict-connect) (main-form) (do-conj) (if (not (null? unattested)) (footnotes))))))) (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 conj-template-file-name) conj-html) ;;;; Local variables: ;;;; mode: Scheme ;;;; buffer-file-coding-system: utf-8 ;;;; End: