;;;; Greek Dictionary Web Engine
;;;; Copyright (C) 2004, 2005, 2006, 2007, 2010, 2011, 2015 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))
(setlocale LC_ALL "")
(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 "
"))
(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 "")
(cond
((not (member 'stem att))
(display "? ")
(if (not (member 'stem unattested))
(set! unattested (cons 'stem unattested)))))
(display tense-name)
(display " | ")
(newline)))
tenses)
(display "
"))
(define (table-footer)
(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 ""
(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
""
(_ "Η συζυγία αυτό του ρήματος δεν επιβεβαιώνεται από τη βάση δεδοµένων")))
(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
""
(_ "Στην λέξη εισαγωγής δεν υπάρχει τόνος. Μήπος θέλατε να κλίσετε ένα απ'αυτά τα ρήματα:"))
(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-cross-reference (car (list-ref result j)))
(display " | "))
(display "
")))
(display "
")))))
(define (do-conj)
(let ((keyval (cgi:value-u8 "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
""
(_ "Αυτή η λέξη δεν είναι ρήμα στο πρώτο ενικό πρόσωπο της οριστικής του ενεστώτα.")))
((= (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 ""))
(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-u8 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: