diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2011-06-07 22:15:26 +0300 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2011-06-07 22:19:26 +0300 |
commit | 2bae7da012e2125762855ce014e63345ecbbbb18 (patch) | |
tree | 61faec7672937f8fc420310da0ff531ce9c6a6bb /scm | |
parent | 79447034e393dc5c7f01f3ec0ca1de7ded4f15e6 (diff) | |
download | ellinika-2bae7da012e2125762855ce014e63345ecbbbb18.tar.gz ellinika-2bae7da012e2125762855ce014e63345ecbbbb18.tar.bz2 |
Improve conjugator
* data/dbverb.struct: Remove individual verb definitions.
* data/irregular-verbs.xml: New file.
* scm/verbop.scm: New file.
* scm/Makefile.am: Add rules for verbop.
* scm/conjugator.scm: Various fixes.
* src/ellinika/elmorph.c (elstr-accent-position): Fix handling
of string arguments.
(_elstr_set_accent): Fix error message.
(elstr-set-accent-character)
(elstr-set-accent-character!): New functions.
Diffstat (limited to 'scm')
-rw-r--r-- | scm/.gitignore | 2 | ||||
-rw-r--r-- | scm/Makefile.am | 7 | ||||
-rw-r--r-- | scm/conjugator.scm | 189 | ||||
-rw-r--r-- | scm/verbop.scm | 676 |
4 files changed, 800 insertions, 74 deletions
diff --git a/scm/.gitignore b/scm/.gitignore index d033647..0e10ba2 100644 --- a/scm/.gitignore +++ b/scm/.gitignore @@ -1,4 +1,4 @@ dictrans dictrans.sed neatrans - +verbop diff --git a/scm/Makefile.am b/scm/Makefile.am index f2669f4..481676f 100644 --- a/scm/Makefile.am +++ b/scm/Makefile.am @@ -15,8 +15,8 @@ # along with this program. If not, see <http://www.gnu.org/licenses/>. pkgmoddir=@GUILE_SITE@ -bin_SCRIPTS=dictrans neatrans -CLEANFILES=dictrans.sed dictrans +bin_SCRIPTS=dictrans neatrans verbop +CLEANFILES=dictrans.sed dictrans neatrans verbop EXTRA_DIST=dictrans.scm dictrans.sed: Makefile @@ -34,3 +34,6 @@ neatrans: $(srcdir)/neatrans.scm dictrans.sed sed -f dictrans.sed $(srcdir)/neatrans.scm > $@ chmod +x $@ +verbop: $(srcdir)/verbop.scm dictrans.sed + sed -f dictrans.sed $(srcdir)/verbop.scm > $@ + chmod +x $@ diff --git a/scm/conjugator.scm b/scm/conjugator.scm index ceda52a..7b2a4a6 100644 --- a/scm/conjugator.scm +++ b/scm/conjugator.scm @@ -128,15 +128,21 @@ WHERE verb='" (force-string verb) "'" (elstr-append root "θ")) (else #f))) - + +(define (lookup-verb-info verb voice thema) + (my-sql-query + (dict-connect) + (string-append + "SELECT root FROM irregular_root \ +WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'"))) + (define (complement-verb-info vinfo verb voice thema) ; (format #t "COMPLEMENT ~S~%" thema) (let ((elverb (string->elstr verb)) - (result (my-sql-query - (dict-connect) - (string-append - "SELECT root FROM irregular_root \ -WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'")))) + (result (let ((tmpres (lookup-verb-info verb voice thema))) + (if (and (null? tmpres) (string=? thema "sub")) + (lookup-verb-info verb voice "aor") + tmpres)))) (verb-info-set! #:root vinfo (cond ((not (null? result)) @@ -247,7 +253,7 @@ WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'")))) ((conj-info-set! #:particle v val) (list-set! v 3 val)))) -(define (get-conj-info conj voice mode tense) +(define (get-conj-info conj voice mood tense) (let ((conn (dict-connect))) (let ((answer (my-sql-query conn @@ -255,7 +261,7 @@ WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'")))) "SELECT c.thema,c.suffix,c.accmap,c.particle,c.aux,c.auxtense,\ f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \ FROM conjugation c, verbflect f \ -WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mode='" mode +WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mood='" mood "' AND c.tense='" tense "' AND c.flect = f.ident")))) (if (null? answer) #f @@ -271,7 +277,17 @@ WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mode='" mode (string->elstr str) str)) -(define (apply-flect conj vinfo) +(define (accented-syllable-0 str) + (let ((syl (elstr-accented-syllable str)) + (len (elstr-number-of-syllables str))) + (if (= syl 0) + syl + (+ (- len syl) 1)))) + +(define (set-accented-syllable-0! str nsyl) + (elstr-set-accent! str (+ (- (elstr-number-of-syllables str) nsyl) 1))) + +(define (apply-flect conj vinfo verb) (let ((root (verb-info #:root vinfo)) (suffix (let ((s (conj-info #:suffix conj))) (if s @@ -294,20 +310,29 @@ WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mode='" mode ((char=? acc #\0) (let* ((rs (force-elstr root)) (suf (elstr-deaccent (elstr-append suffix flect))) - (result (elstr-append rs suf))) - (cond - ((or (= (elstr-accented-syllable rs) 0) - (> (elstr-number-of-syllables suf) 2)) - (let ((nsyl (elstr-number-of-syllables suf))) - (cond - ((= nsyl 1) - result) - ((= nsyl 3) - (elstr-set-accent result 3)) - (else - (elstr-set-accent result 2))))) - (else - result)))) + (result (elstr-append rs suf)) + (acc-syl (let ((n (accented-syllable-0 rs))) + (if (= 0 n) + (accented-syllable-0 verb) + n)))) + (if (> (elstr-number-of-syllables result) 1) + (set-accented-syllable-0! result acc-syl)) + (let ((acc-syl (elstr-accented-syllable result))) + (cond + ((and (= acc-syl 1) + (= (elstr-number-of-syllables result) 1)) + (elstr-deaccent result)) + ((> acc-syl 3) + (let ((nsyl (elstr-number-of-syllables suf))) + (cond + ((= nsyl 1) + result) + ((= nsyl 3) + (elstr-set-accent result 3)) + (else + (elstr-set-accent result 2))))) + (else + result))))) ((char=? acc #\f) (elstr-append (elstr-deaccent (elstr-append root suffix)) @@ -340,13 +365,13 @@ WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mode='" mode forms) (map force-string forms))))) -(define (individual-verb verb voice mode tense) +(define (individual-verb verb voice mood tense) (let ((res (my-sql-query (dict-connect) (string-append "SELECT f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \ FROM individual_verb i,verbflect f \ -WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mode='" mode +WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mood='" mood "' AND i.tense = '" tense "' AND i.ident=f.ident")))) (if (not (null? res)) (append (car res) @@ -354,17 +379,17 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mode='" mode '(class root))) #f))) -(define (conjugate verb voice mode tense . rest) +(define (conjugate verb voice mood tense . rest) (cond - ((individual-verb verb voice mode tense) => + ((individual-verb verb voice mood tense) => (lambda (res) res)) (else (let* ((vinfo (get-verb-info verb)) - (conj (get-conj-info (verb-info #:conj vinfo) voice mode tense))) + (conj (get-conj-info (verb-info #:conj vinfo) voice mood tense))) (if (not conj) (error "cannot obtain conjugation information for " - (verb-info #:conj vinfo) voice mode tense)) + (verb-info #:conj vinfo) voice mood tense)) (if (member #:nopart rest) (conj-info-set! #:particle conj #f)) (cond @@ -386,7 +411,7 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mode='" mode (else ; (format #t "CONJ ~S~%" conj) (complement-verb-info vinfo verb voice (conj-info #:thema conj)) - (append (apply-flect conj vinfo) + (append (apply-flect conj vinfo verb) (list (verb-info #:conj vinfo) (verb-info #:attested vinfo))))))))) @@ -423,9 +448,9 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mode='" mode (define (term x) (or (assoc-ref transtab x) x)) -(define (test-conjugation verb voice mode tense) - (format #t "~A ~A/~A/~A: " verb (term voice) (term mode) tense) - (let* ((result (conjugate verb voice mode tense)) +(define (test-conjugation verb voice mood tense) + (format #t "~A ~A/~A/~A: " verb (term voice) (term mood) tense) + (let* ((result (conjugate verb voice mood tense)) (conj (conjugation:table result))) (cond ((empty-conjugation? conj) @@ -444,42 +469,64 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mode='" mode (newline) (gc)) -(test-conjugation "είμαι" "act" "ind" "Ενεστώτας") -(test-conjugation "είμαι" "act" "ind" "Παρατατίκος") -(test-conjugation "είμαι" "act" "ind" "Μέλλοντας διαρκείας") -(test-conjugation "είμαι" "act" "sub" "Ενεστώτας") -(test-conjugation "είμαι" "act" "imp" "Ενεστώτας") -(test-conjugation "είμαι" "act" "ind" "Αόριστος") - -(test-conjugation "έχω" "act" "ind" "Ενεστώτας") -(test-conjugation "έχω" "act" "ind" "Παρατατίκος") -(test-conjugation "έχω" "act" "ind" "Μέλλοντας διαρκείας") -(test-conjugation "έχω" "act" "sub" "Ενεστώτας") -(test-conjugation "έχω" "act" "imp" "Ενεστώτας") -(test-conjugation "έχω" "act" "imp" "Αόριστος") - -(test-conjugation "ανοίγω" "act" "ind" "Ενεστώτας") -(test-conjugation "ανοίγω" "act" "ind" "Αόριστος") -(test-conjugation "ανοίγω" "pas" "ind" "Αόριστος") -(test-conjugation "δένω" "act" "ind" "Αόριστος") -(test-conjugation "θέλω" "act" "ind" "Αόριστος") -(test-conjugation "θέλω" "act" "ind" "Παρατατικός") -(test-conjugation "βρίσκω" "act" "ind" "Ενεστώτας") -(test-conjugation "βρίσκω" "act" "ind" "Αόριστος") -(test-conjugation "βρίσκω" "act" "ind" "Μέλλοντας στιγμιαίος") -(test-conjugation "βρίσκω" "pas" "ind" "Αόριστος") -(test-conjugation "βρίσκω" "act" "sub" "Ενεστώτας") -(test-conjugation "βρίσκω" "act" "sub" "Αόριστος") -(test-conjugation "βρίσκω" "act" "ind" "Παρακείμενος") -(test-conjugation "βρίσκω" "act" "sub" "Παρακείμενος") -(test-conjugation "βρίσκω" "act" "imp" "Αόριστος") - -(test-conjugation "νικάω" "act" "ind" "Ενεστώτας") -(test-conjugation "νικάω" "act" "ind" "Αόριστος") -(test-conjugation "νικώ" "act" "ind" "Ενεστώτας") -(test-conjugation "νικώ" "act" "ind" "Αόριστος") -(test-conjugation "νικώ" "pas" "ind" "Αόριστος") -(test-conjugation "κρεμάω" "act" "ind" "Αόριστος") -(test-conjugation "κιτάω" "act" "ind" "Αόριστος") -(test-conjugation "τραβάω" "act" "ind" "Αόριστος") +;; (test-conjugation "είμαι" "act" "ind" "Ενεστώτας") +;; (test-conjugation "είμαι" "act" "ind" "Παρατατίκος") +;; (test-conjugation "είμαι" "act" "ind" "Μέλλοντας διαρκείας") +;; (test-conjugation "είμαι" "act" "sub" "Ενεστώτας") +;; (test-conjugation "είμαι" "act" "imp" "Ενεστώτας") +;; (test-conjugation "είμαι" "act" "ind" "Αόριστος") + +;; (test-conjugation "έχω" "act" "ind" "Ενεστώτας") +;; (test-conjugation "έχω" "act" "ind" "Παρατατίκος") +;; (test-conjugation "έχω" "act" "ind" "Μέλλοντας διαρκείας") +;; (test-conjugation "έχω" "act" "sub" "Ενεστώτας") +;; (test-conjugation "έχω" "act" "imp" "Ενεστώτας") +;; (test-conjugation "έχω" "act" "imp" "Αόριστος") + +;; (test-conjugation "ανοίγω" "act" "ind" "Ενεστώτας") +;; (test-conjugation "ανοίγω" "act" "ind" "Αόριστος") +;; (test-conjugation "ανοίγω" "pas" "ind" "Αόριστος") +;; (test-conjugation "δένω" "act" "ind" "Αόριστος") +;; (test-conjugation "θέλω" "act" "ind" "Αόριστος") +;; (test-conjugation "θέλω" "act" "ind" "Παρατατικός") +;; (test-conjugation "βρίσκω" "act" "ind" "Ενεστώτας") +;; (test-conjugation "βρίσκω" "act" "ind" "Αόριστος") +;; (test-conjugation "βρίσκω" "act" "ind" "Μέλλοντας στιγμιαίος") +;; (test-conjugation "βρίσκω" "pas" "ind" "Αόριστος") +;; (test-conjugation "βρίσκω" "act" "sub" "Ενεστώτας") +;; (test-conjugation "βρίσκω" "act" "sub" "Αόριστος") +;; (test-conjugation "βρίσκω" "act" "ind" "Παρακείμενος") +;; (test-conjugation "βρίσκω" "act" "sub" "Παρακείμενος") +;; (test-conjugation "βρίσκω" "act" "imp" "Αόριστος") + +;; (test-conjugation "νικάω" "act" "ind" "Ενεστώτας") +;; (test-conjugation "νικάω" "act" "ind" "Αόριστος") +;; (test-conjugation "νικώ" "act" "ind" "Ενεστώτας") +;; (test-conjugation "νικώ" "act" "ind" "Αόριστος") +;; (test-conjugation "νικώ" "pas" "ind" "Αόριστος") +;; (test-conjugation "κρεμάω" "act" "ind" "Αόριστος") +;; (test-conjugation "κιτάω" "act" "ind" "Αόριστος") +;; (test-conjugation "τραβάω" "act" "ind" "Αόριστος") + +;; (test-conjugation "αγγέλω" "act" "ind" "Αόριστος") +;; (test-conjugation "αγγέλω" "act" "sub" "Αόριστος") +;; (test-conjugation "άγω" "act" "ind" "Αόριστος") +;; (test-conjugation "άγω" "act" "sub" "Αόριστος") +;; (test-conjugation "ανεβαίνω" "act" "ind" "Αόριστος") +;; (test-conjugation "ανεβαίνω" "act" "sub" "Αόριστος") +;; (test-conjugation "απονέμω" "act" "ind" "Αόριστος") +;; (test-conjugation "απονέμω" "act" "sub" "Αόριστος") +;; (test-conjugation "αρέσω" "act" "ind" "Αόριστος") +;; (test-conjugation "αρέσω" "act" "sub" "Αόριστος") +;; (test-conjugation "βάλλω" "act" "ind" "Αόριστος") +;; (test-conjugation "βάλλω" "act" "sub" "Αόριστος") +;; (test-conjugation "βγαίνω" "act" "ind" "Αόριστος") +;; (test-conjugation "βγαίνω" "act" "sub" "Αόριστος") +;; (test-conjugation "βλέπω" "act" "ind" "Αόριστος") +;; (test-conjugation "βλέπω" "act" "sub" "Αόριστος") +;; (test-conjugation "βλέπω" "act" "imp" "Αόριστος") +(test-conjugation "πηγαίνω" "act" "ind" "Μέλλοντας στιγμιαίος") +(test-conjugation "πίνω" "act" "ind" "Αόριστος") +(test-conjugation "πίνω" "act" "sub" "Αόριστος") +(test-conjugation "πίνω" "act" "imp" "Αόριστος") (newline) diff --git a/scm/verbop.scm b/scm/verbop.scm new file mode 100644 index 0000000..bb54126 --- /dev/null +++ b/scm/verbop.scm @@ -0,0 +1,676 @@ +(use-modules (srfi srfi-1) + (xmltools xmltrans) + (ellinika elmorph) + (gamma sql) + (ellinika xlat) + (ice-9 getopt-long)) + +(define cleanup-option #f) +(define force-option #f) +(define verbose-option #f) +(define dry-run-option #f) +(define debug-level 0) +(define input-files '()) +(define flect-ident 0) + +(define (next-flect-ident) + (set! flect-ident (1+ flect-ident)) + flect-ident) + +(define connection #f) ; SQL connection + +(define sysconf-dir "=SYSCONFDIR=") +(define config-file-name "ellinika.conf") + +(define ellinika-sql-connection '()) + +(define (add-conn-param key val) + (set! ellinika-sql-connection (cons (cons key val) ellinika-sql-connection))) + +;;; Load the site defaults +(let ((rc-file (string-append sysconf-dir "/" config-file-name))) + (if (file-exists? rc-file) + (load rc-file))) + +(define (debug level . rest) + (if (>= debug-level level) + (begin + (for-each + (lambda (x) + (display x)) + rest) + (newline)))) + +(define (sql-val val) + ;; FIXME: quote + (if (not val) + "NULL" + (string-append "\"" val "\""))) + +(define (run-query . rest) + (debug 100 rest) + (let ((q (apply format (cons #f rest)))) + (if verbose-option + (format #t "QUERY: ~S\n" q)) + (cond + (connection + (let ((res (sql-query connection q))) + (if verbose-option + (format #t "RESULT: ~S\n" res)) + res)) + (else + #f)))) + +(define (query-number q) + (let ((res (run-query q))) + (if (null? res) + #f + (string->number (caar res))))) + +(define (check-parent elt . rest) + (call-with-current-continuation + (lambda (return) + (for-each + (lambda (parent) + (if (xmltrans:parent? parent) + (return #t))) + rest) + (xmltrans:parse-error #f elt " not a child of " rest) + (mark-invalid) + (return #f)))) + +;;;; Internal structures + +;;; Tense is a list of 6 elements or #f +(define tense #f) + +(define (tense-init) + (set! tense (make-list 6 #f))) + +(define (tense-set n val) + (if (not tense) (tense-init)) + (list-set! tense n val)) + +(define (get-tense) + (let ((ret tense)) + (set! tense #f) + ret)) + +;;; Mood is an associative list. Possible keys are: +;;; Tense +(define mood '()) + +(define (get-mood) + (let ((ret mood)) + (set! mood '()) + ret)) + +(define (mood-set key val) + (set! mood (append mood (list (cons key val))))) + +;;; Conjugation is an associative list of moods + +(define conjugation '()) + +(define (get-conjugation) + (let ((ret conjugation)) + (set! conjugation '()) + ret)) + +(define (conjugation-set key val) + (set! conjugation (append conjugation (list (cons key val))))) + +;;; Verb structure: +(define verbdef '()) + +(define (verbdef:index c) + (case c + ((#:verb) 0) + ((#:class) 1) + ((#:action) 2) + ((#:augment) 3) + ((#:suffix) 4) + ((#:accmap) 5) + ((#:act) 6) + ((#:pas) 7) + ((#:validity) 8) + (else + (error "Unknown index " c)))) + +(define (verb-get what) + (if (null? verbdef) + #f + (list-ref verbdef (verbdef:index what)))) + +(define (verb-get-sql what) + (sql-val (verb-get what))) + +(define (verb-set what val) + (if (null? verbdef) + (verb-init)) + (list-set! verbdef (verbdef:index what) val)) + +(define (verb-init) + (set! verbdef (make-list 9 #f)) + (verb-set #:validity #t) + (verb-set #:action 'insert)) + +(define (mark-invalid) + (verb-set #:validity #f)) + +(define (verbdef-validate) + (call-with-current-continuation + (lambda (return) + (if (verb-get #:validity) + (let ((dict-form (verb-get #:verb))) + (cond ((not dict-form) + (xmltrans:parse-error #f "Dictionary form missing") + (verb-set #:validity #f) + (return #f))) + (if (not (verb-get #:class)) + (cond + ((elstr-suffix? dict-form "άω") + (verb-set #:class "B1")) + ((elstr-suffix? dict-form "ώ") + (xmltrans:parse-warning #f "Class not set, assuming B2") + (verb-set #:class "B2")) + (else + (xmltrans:parse-warning #f "Class not set, assuming A") + (verb-set #:class "A")))))) + (return (verb-get #:validity))))) + +(define (mood-key->string key) + (case key + ((#:ind) "ind") + ((#:sub) "sub") + ((#:imp) "imp") + (else + (error "Unknown mood key" key)))) + +(define (empty-conjugation? conj) + (call-with-current-continuation + (lambda (return) + (for-each + (lambda (x) + (if x + (return #f))) + conj) + (return #t)))) + +(define (flush-mood mood vstr) + (if (eq? (car mood) #:root) + (let ((val (cdr mood))) + (run-query "INSERT INTO irregular_root (verb,voice,thema,root) \ +VALUES (~A,~A,~A,~A);~%" + (verb-get-sql #:verb) + (sql-val vstr) + (sql-val (car val)) + (sql-val (cdr val)))) + (let ((mood-str (mood-key->string (car mood)))) + (for-each + (lambda (p) + (let ((key (car p))) + (debug 1 "flush-mood: " p) + (cond + ((empty-conjugation? (cdr p)) + (run-query "INSERT INTO individual_verb (verb,voice,mood,tense,ident) \ +VALUES (~A,~A,~A,~A,~A);~%" + (verb-get-sql #:verb) + (sql-val vstr) + (sql-val mood-str) + (sql-val key) + "0")) + (else + (let ((num (next-flect-ident)) + (l (cdr p))) + (run-query "INSERT INTO verbflect VALUES (~A,~A,~A,~A,~A,~A,~A);~%" + num + (sql-val (list-ref l 0)) + (sql-val (list-ref l 1)) + (sql-val (list-ref l 2)) + (sql-val (list-ref l 3)) + (sql-val (list-ref l 4)) + (sql-val (list-ref l 5))) + (run-query "INSERT INTO individual_verb (verb,voice,mood,tense,ident) \ +VALUES (~A,~A,~A,~A,~A);~%" + (verb-get-sql #:verb) + (sql-val vstr) + (sql-val mood-str) + (sql-val key) + num) ))))) + (cdr mood))))) + +(define (flush-voice vstr conj-list) + (if conj-list + (for-each + (lambda (mood) + (flush-mood mood vstr)) + conj-list))) + +;;; Fush verb definition to the database +(define (verb-flush) + ;; + (case (verb-get #:action) + ((insert) + (run-query "INSERT INTO verb (verb,conj,augment,accmap,suffix_aor_path) \ +VALUES (~A,~A,~A,~A,~A);~%" + (verb-get-sql #:verb) + (verb-get-sql #:class) + (verb-get-sql #:augment) + (verb-get-sql #:accmap) + (verb-get-sql #:suffix)) + (flush-voice "act" (verb-get #:act)) + (flush-voice "pas" (verb-get #:pas))) + ((delete update) + (xmltrans:parse-error #f + "Sorry update and delete are not yet supported")))) + +;;;; XML definitions + +;;; Set the default handler +(define tag-list '()) + +(define (lingua:default-start tag attr) + (xmltrans:set-attr #f "__START__" 1) + #f) + +(xmltrans:set-default-start-handler lingua:default-start) + +(define (lingua:default-end tag attr text) + (if (xmltrans:attr attr "__START__") + (xmltrans:parse-error #f "Unhandled element " tag)) + (set! tag-list + (cons + (xmltrans:make-tag tag attr text) + tag-list)) + #f) + +(xmltrans:set-default-end-handler lingua:default-end) + +;; <i> +(xmltrans:end-tag + "i" + (tag attr text) + #f) + + +;; <v>...</v> - Verb definition +(xmltrans:end-tag + "v" + (tag attr text) + (check-parent tag "i") + (if (verbdef-validate) + (verb-flush)) + (verb-init) + #f) + +;; <a>verb</a> - Verb in dictionary form +(xmltrans:end-tag + "a" + (tag attr text) + (check-parent tag "v") + (cond ((verb-get #:verb) + (xmltrans:parse-error #f "Verb was already defined") + (mark-invalid))) + (verb-set #:verb text) + #f) + +;;; <c>class</c> - Set conjugation class +(xmltrans:end-tag + "c" + (tag attr text) + (check-parent tag "v") + (cond + ((verb-get #:class) + (xmltrans:parse-error #f "Verb class was already defined") + (mark-invalid)) + ((not (or (string=? text "A") + (string=? text "B1") + (string=? text "B2") + (string=? text "I"))) + (xmltrans:parse-warning #f "Unknown or misspelled verb class"))) + (verb-set #:class text) + #f) + +;;; <action>insert|delete|update</action> - Define action +(xmltrans:end-tag + "action" + (tag attr text) + (check-parent tag "v") + (cond + ((verb-get #:action) + (xmltrans:parse-error #f "Action was already defined") + (mark-invalid))) + (let ((act (string->symbol text))) + (case act + ((insert delete update) + (verb-set #:action act)) + (else + (xmltrans:parse-error #f "Unknown action ~A~%" text)))) + #f) + +;;; <augment>C</augment> - Define augment +(xmltrans:end-tag + "augment" + (tag attr text) + (check-parent tag "v") + (cond + ((verb-get #:augment) + (xmltrans:parse-error #f "Augment was already defined") + (mark-invalid)) + ((not (or (string= text "η") + (string= text "ε"))) + (xmltrans:parse-warning #f "Suspicious augment"))) + (verb-set #:augment text) + #f) + +;;; <suffix>S</suffix> - Define aorist suffix for B verbs +(xmltrans:end-tag + "suffix" + (tag attr text) + (check-parent tag "v") + (cond + ((verb-get #:suffix) + (xmltrans:parse-error #f "Suffix was already defined") + (mark-invalid))) + (verb-set #:suffix text) + #f) + +;;; +(define accmap-char-set + (char-set-adjoin (char-set-copy char-set:digit) #\s #\f #\-)) + +(define (valid-accent-map? accmap) + (let* ((acclist (string->list accmap)) + (len (length acclist))) + (and + (or (= len 6) (= len 7)) + (fold + (lambda (ch prev) + (char-set-contains? accmap-char-set ch)) + #t + (list-head acclist 6)) + (or (= len 6) (char=? (list-ref acclist 6) #\+))))) + +;;; <accmap>MAP</suffix> - Define accent map +(xmltrans:end-tag + "accmap" + (tag attr text) + (check-parent tag "v") + (cond + ((verb-get #:accmap) + (xmltrans:parse-error #f "Accmap was already defined") + (mark-invalid)) + ((not (valid-accent-map? text)) + (xmltrans:parse-error #f "Invalid accent map") + (mark-invalid)) + (else + (verb-set #:accmap text))) + #f) + +;;; <act>...</act> - Define conjugation in active voice +(xmltrans:end-tag + "act" + (tag attr text) + (check-parent tag "v") + (cond + ((verb-get #:act) + (xmltrans:parse-error #f "Active voice was already defined") + (mark-invalid))) + (verb-set #:act (get-conjugation)) + #f) + +;;; <pas>...</pas> - Define conjugation in passive voice +(xmltrans:end-tag + "pas" + (tag attr text) + (check-parent tag "v") + (cond + ((verb-get #:pas) + (xmltrans:parse-error #f "Passive voice was already defined") + (mark-invalid))) + (verb-set #:pas (get-conjugation)) + #f) + +;;; <ind>...</ind> - Indicative +(xmltrans:end-tag + "ind" + (tag attr text) + (check-parent tag "act" "pas") + (conjugation-set #:ind (get-mood)) + #f) + +;;; <sub>...</sub> - Subjunctive +(xmltrans:end-tag + "sub" + (tag attr text) + (check-parent tag "act" "pas") + (conjugation-set #:sub (get-mood)) + #f) + +;;; <imp>...</imp> - Imperative +(xmltrans:end-tag + "imp" + (tag attr text) + (check-parent tag "act" "pas") + (conjugation-set #:imp (get-mood)) + #f) + +;;; <aor>root</aor> - Define aorist root +(xmltrans:end-tag + "aor" + (tag attr text) + (check-parent tag "act" "pas") + (conjugation-set #:root (cons "aor" text)) + #f) + +;;; <root theme="aor|sub|pres">root</root> - Define aorist root +(xmltrans:end-tag + "root" + (tag attr text) + (check-parent tag "act" "pas") + (let ((theme (xmltrans:attr attr "theme"))) + (cond + ((not theme) + (xmltrans:parse-error #f "Required attribute `theme' not specified") + (mark-invalid)) + ((or (string=? theme "aor") + (string=? theme "sub") + (string=? theme "pres")) + (conjugation-set #:root (cons theme text))) + (else + (xmltrans:parse-error #f "Unknown verb theme") + (mark-invalid)))) + #f) + + +;;; <t name="S">...</t> - Define a tense +(xmltrans:start-tag + "t" + (tag attr) + (check-parent tag "ind" "sub" "imp") + (tense-init) + #f) + +(xmltrans:end-tag + "t" + (tag attr text) + (let ((name (xmltrans:attr attr "name"))) + (if (not name) + (begin + (xmltrans:parse-error #f "Required attribute `name' not specified") + (mark-invalid))) + (mood-set name (get-tense))) + #f) + +;;; <p n="[sp]" n="[123]">...</p> - Define a person +(xmltrans:end-tag + "p" + (tag attr text) + (check-parent tag "t") + (call-with-current-continuation + (lambda (return) + (let ((number (xmltrans:attr attr "n")) + (person (xmltrans:attr attr "p")) + (elt #f)) + (cond + ((not number) + (xmltrans:parse-error #f "Required attribute `n' not specified") + (return)) + ((not person) + (xmltrans:parse-error #f "Required attribute `p' not specified") + (return)) + ((string=? person "1") + (set! elt 0)) + ((string=? person "2") + (set! elt 1)) + ((string=? person "3") + (set! elt 2)) + (else + (xmltrans:parse-error #f "Invalid value for `p'") + (return))) + (cond + ((string=? number "s") 0) + ((string=? number "p") + (set! elt (+ 3 elt))) + (else + (xmltrans:parse-error #f "Invalid value for `n'") + (return))) + (tense-set elt text)))) + #f) + + + +;;; DB functions +(define (escape-string str) + (let loop ((lst '()) + (str str)) + (cond + ((string-index str #\") => + (lambda (pos) + (loop (append lst (list (substring str 0 pos) + "\\\"")) + (substring str (1+ pos))))) + (else + (apply string-append (append lst (list str))))))) + + +;;;; Main +(define grammar + `((check (single-char #\c)) + (cleanup) + (database (single-char #\d) (value #t)) + (host (single-char #\h) (value #t)) + (port (single-char #\P) (value #t)) + (password (single-char #\p) (value #t)) + (user (single-char #\u) (value #t)) + (dry-run (single-char #\n)) + (interface (value #t)) + (verbose (single-char #\v)) + (debug (value #t)) + (help))) + +(define (usage) + (display "usage: verbop OPTIONS FILES + +General options: + + --check Only check input syntax and consistency. Do not + update the database. This means that the program will + not access the database at all, so some errors + (mistyped parts of speech and the like) may slip in + unnoticed. + --verbose Verbosely display SQL queries and their results. + --debug NUMBER Set debugging level (0 < NUMBER <= 100) + --dry-run Do nothing, display what would have been done. + +SQL related options: + + --interface STRING Select SQL interface to use. STRING may be + either \"mysql\" (the default) or \"postgres\". + --host HOST-OR-PATH Set name or IP address of the host running SQL + database, or path to the database I/O socket. + --database NAME Set name of the database to use. + --port NUMBER Set the SQL port number + --user USER-NAME Set SQL user name. + --password STRING Set the SQL password + + --cleanup Clean up the database (delete all entries from all the + tables) before proceeding. Use this option with care. + +Informational options: + + --help Output this help info +\n")) + +(define (cons? p) + (and (pair? p) (not (list? p)))) + +(for-each + (lambda (x) + (cond + ((cons? x) + (case (car x) + ((cleanup) + (set! cleanup-option #t)) + ((database) + (add-conn-param #:db (cdr x))) + ((host) + (add-conn-param #:host (cdr x))) + ((port) + (add-conn-param #:port (string->number (cdr x)))) + ((password) + (add-conn-param #:pass (cdr x))) + ((user) + (add-conn-param #:user (cdr x))) + ((interface) + (add-conn-param #:iface (cdr x))) + ((verbose) + (set! verbose-option #t)) + ((preserve) + (set! preserve-option #t)) + ((debug) + (set! debug-level (string->number (cdr x)))) + ((dry-run) + (set! verbose-option #t) + (set! dry-run-option #t)) + ((help) + (usage) + (exit 0)))) + (else + (set! input-files (cdr x))))) + (getopt-long (command-line) grammar)) + +(if (null? input-files) + (begin + (display "Input files not specified\n" (current-error-port)) + (exit 1))) + +(cond + ((not dry-run-option) + (set! connection (sql-open-connection ellinika-sql-connection)) + (if (not connection) + (begin + (display "Cannot connect to the database\n" (current-error-port)) + (exit 1))) + (run-query "SET NAMES utf8") + (set! flect-ident (query-number "SELECT MAX(ident) FROM verbflect")))) + +(cond + (cleanup-option + (run-query "DELETE FROM verbflect where ident > 99") + (run-query "DELETE FROM verb") + (run-query "DELETE FROM irregular_root") + (run-query "DELETE FROM individual_verb"))) + +(for-each + (lambda (x) + (if (not (xmltrans:parse-file x)) + (exit 1))) + input-files) + +(if connection + (sql-close-connection connection)) + + + |