aboutsummaryrefslogtreecommitdiff
path: root/scm/verbop.scm
diff options
context:
space:
mode:
Diffstat (limited to 'scm/verbop.scm')
-rw-r--r--scm/verbop.scm332
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))

Return to:

Send suggestions and report system problems to the System administrator.