diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2011-06-15 10:05:10 +0300 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2011-06-15 10:24:46 +0300 |
commit | bb9dd8a54a96307aad7bf976f1736d20c70d43e3 (patch) | |
tree | df632e2c76facc932c4c34978eba4b9ae4cb0354 /src/cgi-bin/conj.scm4 | |
parent | a27881a1c5bd7d8f8f42cd6526adf80815acfe63 (diff) | |
download | ellinika-bb9dd8a54a96307aad7bf976f1736d20c70d43e3.tar.gz ellinika-bb9dd8a54a96307aad7bf976f1736d20c70d43e3.tar.bz2 |
Implement web conjugator.
* src/cgi-bin/.gitignore: Update.
* src/cgi-bin/Makefile.am: Build conj,cgi
* src/cgi-bin/conj.scm4: New file.
* src/cgi-bin/dict.scm4 (protect): Move to cgi.scm, function
cgi-protect-quotes. All uses updated.
* src/ellinika/cgi.scm4 (cgi-protect-quotes): New function.
* src/ellinika/Makefile.am (guile_DATA): Add conjugator.scm
* src/ellinika/conjugator.scm: Minor fixes.
* src/ellinika/sql.scm (->string): Fix typo.
* src/ellinika/tenses.scm (ellinika-conjugation-term-transtab): New var.
(ellinika-conjugation-term): New function.
* src/ellinika/test-conjugation.scm: Use ellinika-conjugation-term instead
of (term).
* xml/lingua.conf.in (install-conj): New macro.
* xml/pl/ellinika.xml (GUILE): Call install-conj.
* xml/pl/rhmata.xml: Define conjugator template page.
Diffstat (limited to 'src/cgi-bin/conj.scm4')
-rw-r--r-- | src/cgi-bin/conj.scm4 | 235 |
1 files changed, 235 insertions, 0 deletions
diff --git a/src/cgi-bin/conj.scm4 b/src/cgi-bin/conj.scm4 new file mode 100644 index 0000000..b48b225 --- /dev/null +++ b/src/cgi-bin/conj.scm4 @@ -0,0 +1,235 @@ +;;;; 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 <http://www.gnu.org/licenses/>. +;;;; + +;;; 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) + (xmltools dict) + (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_08.html") + +(ellinika-cgi-init conj-template-file-name) + +(define (sql-error-handler key func fmt fmtargs data) + (format #t "<h1 class=\"error\">~A</h1>\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 "<form action=\"~A\" method=\"post\">" + (make-cgi-name cgi-script-name)) + (display "\ +<table class=\"noframe\"> +<tr> + <td>") + (display (_"Εισάγετε τον ρήμα")) + (display " + </td> + <td> + <input size=\"36\" name=\"key\" tabindex=\"1\"") + (let ((value (cgi:value "key"))) + (if value + (begin + (display " value=\"") + (display (cgi-protect-quotes value)) + (display "\"")))) + (display " /> + </td> + <td> + <input type=\"submit\" name=\"conjugate\" value=\"") + (display (_"Κλίση")) + (display "\" tabindex=\"2\" /> + </td> +</tr> +</table> +</form> +")) + +(define tense-driver-list + '(("ind" 3 5) + ("sub" 3) + ("imp" 3))) + +(define (show-conjugation:tense verb voice mood tense) + + #t) + +(define (table-header count tense-names) + (display "\ + <table class=\"frame align-center\"> + <thead class=\"std\"> + <tr>") + (for-each + (lambda (tense) + (format #t "<th>~A</th>~%" tense)) + tense-names) + (display "</tr></thead>")) + +(define (table-footer) + (display "</table>")) + +(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-names voice mood verb) + (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 "<tr class=\"~A\">" class) + (for-each + (lambda (x) + (let ((val (concat-unique x))) + (format #t "<td>~A</td>" (if val val "--")))) + row) + (display "</tr>")))) + (transpose + (map + (lambda (tense) + (let ((conj (conjugator verb voice mood tense))) + (compact-conj-list (transpose (map conjugation:table conj))))) + tense-names)) + '(1 2 3 4 5 6) + '("odd" "even" "odd" "even" "odd" "even")))) + +(define (show-conjugation:mood voice mood tense-list verb) + (format #t "<div class=\"subsection\"><h3>~A</h3>" + (ellinika-conjugation-term mood)) + (for-each + (lambda (count) + (let ((tenses (list-head tense-list count))) + (table-header count tenses) + (format-tenses count tenses voice mood verb) + (table-footer) + (set! tense-list (list-tail tense-list count)) + (if (not (null? tense-list)) + (display "<br/><br/>")))) + (assoc-ref tense-driver-list mood)) + (display "</div>")) + +(define (show-conjugation:voice voice verb) + (format #t "<div class=\"section\"><h2>~A</h2>" + (ellinika-conjugation-term voice)) + (for-each + (lambda (mood-tenses) + (show-conjugation:mood voice (car mood-tenses) (cdr mood-tenses) verb)) + ellinika-tense-list) + + (display "</div>")) + +(define (show-conjugation verb) + (show-conjugation:voice "act" verb) + (show-conjugation:voice "pas" verb)) + +(define (do-conj) + (let ((keyval (cgi:value "key"))) + (if keyval + (show-conjugation keyval)))) + +(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)))))) + + (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: + |