diff options
-rw-r--r-- | data/irregular-verbs.xml | 1 | ||||
-rw-r--r-- | scm/verbop.scm | 32 | ||||
-rw-r--r-- | src/cgi-bin/conj.scm4 | 3 | ||||
-rw-r--r-- | src/ellinika/conjugator.scm | 73 | ||||
-rw-r--r-- | src/ellinika/sql.scm | 2 |
5 files changed, 72 insertions, 39 deletions
diff --git a/data/irregular-verbs.xml b/data/irregular-verbs.xml index 2e604e3..1923d88 100644 --- a/data/irregular-verbs.xml +++ b/data/irregular-verbs.xml @@ -455,24 +455,25 @@ <imp> <t name="Ενεστώτας"> <prop name="root">λέγ</prop> </t> <t name="Αόριστος"> <p n="s" p="2">πες</p> <p n="p" p="2">πείτε,πέστε</p> </t> </imp> </act> <pas> <root theme="aor">ειπώθ</root> + <root theme="aor">λεχθ</root> <ind> <t name="Ενεστώτας"> <prop name="root">λέγ</prop> </t> <t name="Παρατατικός"> <prop name="root">λέγ</prop> </t> </ind> <imp> <t name="Ενεστώτας"> <prop name="root">λέγ</prop> </t> diff --git a/scm/verbop.scm b/scm/verbop.scm index 0fff38f..8308d70 100644 --- a/scm/verbop.scm +++ b/scm/verbop.scm @@ -121,28 +121,36 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (command-line))" "$@" (set! mood (append mood (list (cons key val))))) ;;; Conjugation is an associative list of moods (define conjugation #f) (define (get-conjugation) (let ((ret conjugation)) (set! conjugation #f) ret)) (define (conjugation-set key val) - (set! conjugation - (if conjugation - (append conjugation (list (cons key val))) - (list (cons key val))))) + (let ((elt (cond + ((not (eq? key #:root)) + (cons key val)) + ((and conjugation (assoc (car val) conjugation)) => + (lambda (entry) + (set-cdr! entry (cons (cdr val) (cdr entry))))) + (else + (cons key (list val)))))) + (set! conjugation + (if conjugation + (append conjugation (list elt)) + (list elt))))) ;;; Verb structure: (define verbdef '()) (define (verbdef:index c) (case c ((#:verb) 0) ((#:class) 1) ((#:action) 2) ((#:augment) 3) ((#:suffix) 4) @@ -213,32 +221,34 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (command-line))" "$@" (define (insert-individual-verb voice mood tense ident) (ellinika:sql-query "INSERT INTO individual_verb (verb,voice,mood,tense,ident) \ VALUES (~Q,~Q,~Q,~Q,~Q)" (verb-get #:verb) voice mood tense ident)) (define (flush-mood mood vstr) (if (eq? (car mood) #:root) - (let ((val (cdr mood))) - (ellinika:sql-query - "INSERT INTO irregular_root (verb,voice,thema,root) \ + (for-each + (lambda (val) + (ellinika:sql-query + "INSERT INTO irregular_root (verb,voice,thema,root) \ VALUES (~Q,~Q,~Q,~Q)" - (verb-get #:verb) - vstr - (car val) - (cdr val))) + (verb-get #:verb) + vstr + (car val) + (cdr val))) + (cdr mood)) (let ((mood-str (car mood))) (let ((lst (cdr mood))) (cond ((null? lst) (for-each (lambda (tense) (insert-individual-verb vstr mood-str tense 0)) (assoc-ref ellinika-tense-list mood-str))) (else ; (format #t "LST ~A~%" lst) (for-each diff --git a/src/cgi-bin/conj.scm4 b/src/cgi-bin/conj.scm4 index fec7eca..8c5e317 100644 --- a/src/cgi-bin/conj.scm4 +++ b/src/cgi-bin/conj.scm4 @@ -319,24 +319,26 @@ ifelse(IFACE,[CGI],(cgi:init)) (display "</a>")) (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 "<div class=\"error\"><p>~A</p></div>" (_ "Στην λέξη εισαγωγής δεν υπάρχει τόνος. Μήπος θέλατε να κλίσετε ένα απ'αυτά τα ρήματα:")) (display "<table width=\"100%\" class=\"noframe\">") (let* ((result-length (length result)) (lim (1+ (quotient result-length match-list-columns)))) (do ((i 0 (1+ i))) ((= i lim) #f) (display "<tr>") (do ((j i (+ j lim))) ((>= j result-length) #f) @@ -398,24 +400,25 @@ ifelse(IFACE,[CGI],(cgi:init)) (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 () + (format #t "<!-- ~A -->" (environ)) (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)))) diff --git a/src/ellinika/conjugator.scm b/src/ellinika/conjugator.scm index 0abec8d..f70e20c 100644 --- a/src/ellinika/conjugator.scm +++ b/src/ellinika/conjugator.scm @@ -38,25 +38,28 @@ ;; attested (define (verb-set! verb key value) ; (format #t "VERB ~A KEY ~A VALUE ~A~%" verb key value) (case key ((#:conj) (list-set! verb 0 value)) ((#:verb) (list-set! verb 1 value)) ((#:attested) (list-set! verb 3 (append (list-ref verb 3) (list value)))) (else - (let ((container (assoc key (list-ref verb 2)))) + (let ((container (assoc key (list-ref verb 2))) + (value (if (and (eq? key #:root) (not (list? value))) + (list value) + value))) (if container (set-cdr! container value) (list-set! verb 2 (append (list-ref verb 2) (list (cons key value))))))))) (define (verb-get verb key) (case key ((#:conj) (list-ref verb 0)) ((#:verb) @@ -92,39 +95,51 @@ (elstr-trim verb -2) "ώ") proplist "B1")) ((null? rest) (list (guess-verb-class verb) verb proplist '())) (else (list (car rest) verb '() '()))))) (define (load-verb-info verb voice mood tense) ; (format #t "LOAD ~A~%" verb) (let ((verbprop (ellinika:sql-query "SELECT property,value FROM verbtense WHERE \ verb=\"~A\" AND voice=\"~A\" AND mood=\"~A\" AND tense=\"~A\"" verb voice mood tense))) - (create-basic-verb-info verb - (if (null? verbprop) - '() - (map - (lambda (elt) - (let ((name (car elt)) - (value (cadr elt))) - (if (string=? name "override") - (cons #:override - (string-split value #\,)) - (cons (symbol->keyword - (string->symbol name)) - value)))) - verbprop))))) - + (create-basic-verb-info + verb + (let loop ((inlist (if (null? verbprop) + '() + (map + (lambda (elt) + (let ((name (car elt)) + (value (cadr elt))) + (if (string=? name "override") + (cons #:override + (string-split value #\,)) + (cons (symbol->keyword + (string->symbol name)) + value)))) + verbprop))) + (rootlist '()) + (outlist '())) +; (format #t "ARGS: ~A/~A/~A~%" inlist rootlist outlist) + (cond + ((null? inlist) + (if (null? rootlist) + outlist + (cons (cons #:root rootlist) outlist))) + ((eq? (caar inlist) #:root) + (loop (cdr inlist) (cons (cdar inlist) rootlist) outlist)) + (else + (loop (cdr inlist) rootlist (cons (car inlist) outlist)))))))) (define (thema-aoristoy-mesapathitikis-A root) (cond ((elstr-suffix? root "αίν") (elstr-append (elstr-trim root -3) "ανθ")) ;; FIXME: Also αθ, ηθ ((and (elstr-suffix? root "ν") (logand (elstr-char-prop-bitmask root -2) elmorph:vowel)) (elstr-append (elstr-trim root -1) "θ")) ;; FIXME: also στ, νθ, θ ((and (elstr-suffix? root "δ" "θ" "ζ" "ν") ;; FIXME: see above (logand (elstr-char-prop-bitmask root -2) elmorph:vowel)) @@ -183,25 +198,25 @@ WHERE verb=\"~A\" AND voice=\"~A\" AND thema=\"~A\"" (define (complement-verb-info vinfo verb voice thema) ; (format #t "COMPLEMENT ~A~%" vinfo) (let ((elverb (string->elstr verb)) (result (let ((tmpres (lookup-verb-info verb voice thema))) (if (and (null? tmpres) (string=? thema "sub")) (lookup-verb-info verb voice "aor") tmpres)))) (verb-set! vinfo #:root (cond ((not (null? result)) (verb-set! vinfo #:attested 'root) - (caar result)) + (map car result)) ((string=? (verb-get vinfo #:conj) "A") (let ((root (verb-A-root elverb))) (cond ((string=? thema "pres") (verb-set! vinfo #:attested 'root) root) ((or (string=? thema "aor") (string=? thema "sub")) (if (string=? voice "act") (elstr-thema-aoristoy root) (thema-aoristoy-mesapathitikis-A root))) (else #f)))) @@ -348,28 +363,27 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" (define (get-accmap conj vinfo) (let ((override (verb-get vinfo #:override))) (if (and override (member "accmap" override)) (let ((t (conj-info #:accmap conj))) (if t (or (verb-get vinfo #:accmap) t))) (or (verb-get vinfo #:accmap) (conj-info #:accmap conj) "000000")))) -(define (apply-flect conj vinfo verb) +(define (apply-flect conj vinfo verb root) ; (format #t "VINFO ~A~%" vinfo) - (let ((root (verb-get vinfo #:root)) - (suffix (get-suffix conj vinfo)) + (let ((suffix (get-suffix conj vinfo)) (accmap (string->list (get-accmap conj vinfo))) (augment "")) ; (format #t "ROOT ~A, ACCMAP ~S, SUFFIX: ~A~%" root accmap suffix) (cond ((> (length accmap) 6) (set! accmap (list-head accmap 6)) (set! augment (or (verb-get vinfo #:augment) "ε")))) ; (format #t "AUGMENT ~A ~A~%" vinfo (verb-get vinfo #:augment)) (let ((forms (map (lambda (flect acc person) (cond @@ -543,31 +557,36 @@ AND i.tense=\"~A\" AND i.ident=f.ident" (else (let ((vinfo (copy-tree vinfo))) (if (verb-get vinfo #:root) (verb-set! vinfo #:attested 'root) (let ((thema (string-split (conj-info #:thema conj) #\:))) ; (format #t "THEMA ~A~%" thema) (complement-verb-info vinfo verb (if (null? (cdr thema)) voice (car (cdr thema))) (car thema)))) ; (format #t "VINFO ~A~%" vinfo) - (cons - (cons - (append (apply-flect conj vinfo verb) - (list (verb-get vinfo #:conj) - (verb-get vinfo #:attested))) - (conj-info #:fold conj)) - prev))))) + + (fold + (lambda (stem prev) + (cons + (cons + (append (apply-flect conj vinfo verb stem) + (list (verb-get vinfo #:conj) + (verb-get vinfo #:attested))) + (conj-info #:fold conj)) + prev)) + prev + (verb-get vinfo #:root)))))) '() conj-list)))))))) (define-public (conjugator verb voice mood tense) (conjugate verb voice mood tense)) (define-public (conjugation:table conj) (cond ((not conj) #f) (else (list-head conj 6)))) diff --git a/src/ellinika/sql.scm b/src/ellinika/sql.scm index 5867d28..f281847 100644 --- a/src/ellinika/sql.scm +++ b/src/ellinika/sql.scm @@ -35,25 +35,25 @@ (sql-query ellinika:sql-conn "SET NAMES utf8")) ellinika:sql-conn))) (define-public (ellinika:sql-disconnect) (if ellinika:sql-conn (sql-close-connection ellinika:sql-conn))) (define (->string arg) (cond ((string? arg) arg) ((elstr? arg) (elstr->string arg)) ((number? arg) (number->string arg)) - ((bool? arg) (if arg "true" "false")) + ((boolean? arg) (if arg "true" "false")) (else (error "Unhandled argument type: ~S" arg)))) ;; Format specifiers: ;; ~A - escaped string ;; ~Q - escaped and quoted string; NULL if argument is #f ;; ~N - unescaped number ;; ~<anychar> - <anychar> (define-public (ellinika:format-sql-query fmt args) (let* ((fmtlist (string-split fmt #\~)) (segments (reverse |