aboutsummaryrefslogtreecommitdiff
path: root/src/cgi-bin/conj.scm4
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2011-06-15 10:05:10 +0300
committerSergey Poznyakoff <gray@gnu.org.ua>2011-06-15 10:24:46 +0300
commitbb9dd8a54a96307aad7bf976f1736d20c70d43e3 (patch)
treedf632e2c76facc932c4c34978eba4b9ae4cb0354 /src/cgi-bin/conj.scm4
parenta27881a1c5bd7d8f8f42cd6526adf80815acfe63 (diff)
downloadellinika-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.scm4235
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 "&amp;")
+ (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:
+

Return to:

Send suggestions and report system problems to the System administrator.