diff options
Diffstat (limited to 'scm/verbop.scm')
-rw-r--r-- | scm/verbop.scm | 332 |
1 files changed, 244 insertions, 88 deletions
diff --git a/scm/verbop.scm b/scm/verbop.scm index 621ea6c..ff30892 100644 --- a/scm/verbop.scm +++ b/scm/verbop.scm @@ -1,3 +1,22 @@ +#! =GUILE_BINDIR=/guile -s +=AUTOGENERATED= +!# +;;;; This file is part of Ellinika +;;;; Copyright (C) 2011 Sergey Poznyakoff +;;;; +;;;; Ellinika 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. +;;;; +;;;; Ellinika 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/>. +;;;; (use-modules (srfi srfi-1) (xmltools xmltrans) (ellinika elmorph) @@ -17,6 +36,8 @@ (set! flect-ident (1+ flect-ident)) flect-ident) +(define class-list '()) ; List of defined verb classes. + (define connection #f) ; SQL connection (define sysconf-dir "=SYSCONFDIR=") @@ -83,17 +104,23 @@ ;;; Tense is a list of 6 elements or #f (define tense #f) +(define tense-prop '()) (define (tense-init) - (set! tense (make-list 6 #f))) + (set! tense (make-list 6 #f)) + (set! tense-prop '())) (define (tense-set n val) (if (not tense) (tense-init)) (list-set! tense n val)) (define (get-tense) - (let ((ret tense)) - (set! tense #f) + (let ((ret (append tense + (if (and (empty-conjugation? tense) + (not (null? tense-prop))) + (cons (cons "default" #t) tense-prop) + tense-prop)))) + (tense-init) ret)) ;;; Mood is an associative list. Possible keys are: @@ -110,15 +137,19 @@ ;;; Conjugation is an associative list of moods -(define conjugation '()) +(define conjugation #f) (define (get-conjugation) (let ((ret conjugation)) - (set! conjugation '()) + (set! conjugation #f) ret)) (define (conjugation-set key val) - (set! conjugation (append conjugation (list (cons key val))))) + (set! conjugation + (if conjugation + (append conjugation (list (cons key val))) + (list (cons key val))))) + ;;; Verb structure: (define verbdef '()) @@ -138,9 +169,15 @@ (error "Unknown index " c)))) (define (verb-get what) - (if (null? verbdef) - #f - (list-ref verbdef (verbdef:index what)))) + (cond + ((null? verbdef) + #f) + ((eq? what #:override) + (if (verb-get #:suffix) + "suffix" + #f)) + (else + (list-ref verbdef (verbdef:index what))))) (define (verb-get-sql what) (sql-val (verb-get what))) @@ -152,6 +189,8 @@ (define (verb-init) (set! verbdef (make-list 9 #f)) + (verb-set #:act '()) + (verb-set #:pas '()) (verb-set #:validity #t) (verb-set #:action 'insert)) @@ -179,14 +218,6 @@ (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) @@ -194,7 +225,7 @@ (lambda (x) (if x (return #f))) - conj) + (list-head conj 6)) (return #t)))) (define (insert-individual-verb voice mood tense ident) @@ -210,44 +241,66 @@ VALUES (~A,~A,~A,~A,~A);~%" (if (eq? (car mood) #:root) (let ((val (cdr mood))) (run-query "INSERT INTO irregular_root (verb,voice,thema,root) \ -VALUES (~A,~A,~A,~A);~%" +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)))) + (let ((mood-str (car mood))) (let ((lst (cdr mood))) - (if (null? lst) - (for-each - (lambda (tense) - (insert-individual-verb vstr mood-str tense 0)) - (assoc-ref ellinika-tense-list mood-str)) - - (for-each - (lambda (p) - (let ((key (car p))) - (debug 1 "flush-mood: " p) - (cond - ((empty-conjugation? (cdr p)) - (insert-individual-verb vstr mood-str 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))) - (insert-individual-verb vstr mood-str key num) ))))) - lst)))))) + (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 + (lambda (p) + (let ((tense (car p))) + (debug 1 "flush-mood: " p) + (cond + ((assoc-ref (list-tail p 7) "default") #t) + ((empty-conjugation? (cdr p)) + (insert-individual-verb vstr mood-str tense 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))) + (insert-individual-verb vstr mood-str tense num) ))) + + (for-each + (lambda (prop) +; (format #t "PROP ~A~%" prop) + (let ((key (car prop))) + (cond + ((string=? key "default")) + (else + (run-query + "INSERT INTO verbtense VALUES (~A,~A,~A,~A,~A,~A)" + (verb-get-sql #:verb) + (sql-val vstr) + (sql-val mood-str) + (sql-val tense) + (sql-val (car prop)) + (sql-val (cdr prop))))))) + (list-tail p 7)))) + lst))))))) (define (flush-voice vstr conj-list) +; (format #t "VOICE ~A~%" conj-list) (cond - ((null? conj-list) + ((not conj-list) (for-each (lambda (vp) (let ((mood (car vp))) @@ -262,20 +315,91 @@ VALUES (~A,~A,~A,~A);~%" (flush-mood mood vstr)) conj-list)))) +;;; +(define (preprocess-voice voice attrlist) +; (format #t "VOICE ~A~%" voice) + (if voice + (for-each + (lambda (arg) + (let* ((key (car arg)) + (mtlist (cdr arg)) + (value (verb-get key))) +; (format #t "KEY ~A / VALUE ~A; MTLIST ~A~%" key value mtlist) + (if value + (let ((attr (symbol->string (keyword->symbol key)))) + (for-each + (lambda (mood-tenses) + (let* ((mood-name (car mood-tenses)) + (mood-ref (or (assoc mood-name voice) + (begin + (set! voice + (cons (cons mood-name '()) + voice)) + (car voice))))) +; (format #t "MOOD ~A~%" mood-ref) + (for-each + (lambda (tense-name) + (let* ((tense (or (assoc tense-name (cdr mood-ref)) + (begin + (append! + mood-ref + (list + (cons tense-name + (append + (make-list 6 #f) + (list + (cons "default" #t)))))) +; (format #t "NM ~A~%" mood-ref) + (assoc tense-name + (cdr mood-ref))))) + (prop (begin +; (format #t "TENSE ~A~%" tense) + (list-tail tense 7)))) +; (format #t "PROP ~A ~A~%" tense prop) + (if (not (assoc attr prop)) + (append! tense + (list + (cons attr value)))))) + (cdr mood-tenses)))) + mtlist))))) + attrlist)) +; (format #t "BVOICE ~A~%" voice) + voice) + ;;; Fush verb definition to the database (define (verb-flush) ;; (case (verb-get #:action) ((insert) - (run-query "INSERT INTO verb (verb,conj,augment,accmap,suffix) \ -VALUES (~A,~A,~A,~A,~A);~%" + (run-query "INSERT INTO verbclass (verb,conj) VALUES (~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))) + (verb-get-sql #:class)) + (flush-voice "act" + (preprocess-voice + (verb-get #:act) + (list + (cons #:suffix + '(("ind" . ("Αόριστος" + "Παρακείμενος" + "Υπερσυντέλικος" + "Συντελεσμένος μέλλοντας" + "Μέλλοντας στιγμιαίος")) + ("sub" . ("Αόριστος")) + ("imp" . ("Αόριστος")))) + (cons #:accmap ellinika-tense-list) + (cons #:augment + '(("ind" . ("Αόριστος" + "Παρακείμενος"))))))) + + (flush-voice "pas" + (preprocess-voice + (verb-get #:pas) + (list + (cons #:suffix + '(("imp" . ("Αόριστος")))) + (cons #:override + '(("imp" . ("Αόριστος")))) + (cons #:accmap ellinika-tense-list))))) ((delete update) (xmltrans:parse-error #f "Sorry update and delete are not yet supported")))) @@ -339,10 +463,7 @@ VALUES (~A,~A,~A,~A,~A);~%" ((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"))) + ((not (member text class-list)) (xmltrans:parse-warning #f "Unknown or misspelled verb class"))) (verb-set #:class text) #f) @@ -368,27 +489,40 @@ VALUES (~A,~A,~A,~A,~A);~%" (xmltrans:end-tag "augment" (tag attr text) - (check-parent tag "v") + + (if (not (or (string= text "η") + (string= text "ε"))) + (xmltrans:parse-warning #f "Suspicious augment")) + (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) + ((xmltrans:parent? "v") + (cond + ((verb-get #:augment) + (xmltrans:parse-error #f "Augment was already defined") + (mark-invalid)) + (verb-set #:augment text))) + ((xmltrans:parent? "t") + (set! tense-prop (cons (cons "augment" text) tense-prop))) + (else + (xmltrans:parse-error #f elt " not a child of v or t"))) #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) + ((xmltrans:parent? "v") + (cond + ((verb-get #:suffix) + (xmltrans:parse-error #f "Suffix was already defined") + (mark-invalid)) + (else + (verb-set #:suffix text)))) + ((xmltrans:parent? "t") + (set! tense-prop (cons (cons "suffix" text) tense-prop))) + (else + (xmltrans:parse-error #f elt " not a child of v or t"))) #f) ;;; @@ -411,16 +545,24 @@ VALUES (~A,~A,~A,~A,~A);~%" (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)) + ((xmltrans:parent? "v") + (cond + ((> (string-length text) 6) + (xmltrans:parse-error #f "Use of augment not allowed in global accent map") + (mark-invalid)) + ((verb-get #:accmap) + (xmltrans:parse-error #f "Accmap was already defined") + (mark-invalid)) + (else + (verb-set #:accmap text)))) + ((xmltrans:parent? "t") + (set! tense-prop (cons (cons "accmap" text) tense-prop))) (else - (verb-set #:accmap text))) + (xmltrans:parse-error #f elt " not a child of v or t"))) #f) ;;; <act>...</act> - Define conjugation in active voice @@ -429,10 +571,12 @@ VALUES (~A,~A,~A,~A,~A);~%" (tag attr text) (check-parent tag "v") (cond - ((verb-get #:act) + ((null? (verb-get #:act)) + (verb-set #:act (get-conjugation))) + (else (xmltrans:parse-error #f "Active voice was already defined") (mark-invalid))) - (verb-set #:act (get-conjugation)) + #f) ;;; <pas>...</pas> - Define conjugation in passive voice @@ -441,10 +585,11 @@ VALUES (~A,~A,~A,~A,~A);~%" (tag attr text) (check-parent tag "v") (cond - ((verb-get #:pas) + ((null? (verb-get #:pas)) + (verb-set #:pas (get-conjugation))) + (else (xmltrans:parse-error #f "Passive voice was already defined") (mark-invalid))) - (verb-set #:pas (get-conjugation)) #f) ;;; <ind>...</ind> - Indicative @@ -452,7 +597,7 @@ VALUES (~A,~A,~A,~A,~A);~%" "ind" (tag attr text) (check-parent tag "act" "pas") - (conjugation-set #:ind (get-mood)) + (conjugation-set "ind" (get-mood)) #f) ;;; <sub>...</sub> - Subjunctive @@ -460,7 +605,7 @@ VALUES (~A,~A,~A,~A,~A);~%" "sub" (tag attr text) (check-parent tag "act" "pas") - (conjugation-set #:sub (get-mood)) + (conjugation-set "sub" (get-mood)) #f) ;;; <imp>...</imp> - Imperative @@ -468,7 +613,7 @@ VALUES (~A,~A,~A,~A,~A);~%" "imp" (tag attr text) (check-parent tag "act" "pas") - (conjugation-set #:imp (get-mood)) + (conjugation-set "imp" (get-mood)) #f) ;;; <aor>root</aor> - Define aorist root @@ -518,7 +663,7 @@ VALUES (~A,~A,~A,~A,~A);~%" (mood-set name (get-tense))) #f) -;;; <p n="[sp]" n="[123]">...</p> - Define a person +;;; <p n="[sp]" n="[123]">...</p> - Define a (grammatical) person (xmltrans:end-tag "p" (tag attr text) @@ -674,10 +819,21 @@ Informational options: (cond (cleanup-option (run-query "DELETE FROM verbflect where ident > 99") - (run-query "DELETE FROM verb") + (run-query "DELETE FROM verbclass") + (run-query "DELETE FROM verbtense") (run-query "DELETE FROM irregular_root") (run-query "DELETE FROM individual_verb"))) - + +(set! class-list + (cons "I" + (if dry-run-option + (list "A" "B1" "B2") + (map + car + (run-query + "SELECT DISTINCT conj FROM conjugation ORDER BY 1"))))) + + (for-each (lambda (x) (if (not (xmltrans:parse-file x)) |