From bee3becef44e298f59d72cee3c8e552bccb10d65 Mon Sep 17 00:00:00 2001
From: Sergey Poznyakoff <gray@gnu.org.ua>
Date: Tue, 14 Jun 2011 02:21:00 +0300
Subject: Improve verb database structure for better handling of individual
 verbs.

* data/dbverb.struct (verbflect): Split alternative flections
into separate groups.
(conjugation): Set fold values for imp.
Add missing accmaps
(verb): Drop table.
(verbclass,verbtense): New tables.
* data/irregular-verbs.xml: Update.
* scm/verbop.scm: Rewrite for the new database structure.
* src/ellinika/conjugator.scm: Likewise.
* src/ellinika/tests/conj/ntynv.scm: Fix typo.
* src/ellinika/tests/conj/bastv.scm: New file.
* src/ellinika/tests/conj/kauomai.scm: New file.
---
 src/ellinika/conjugator.scm         | 427 +++++++++++++++++++++---------------
 src/ellinika/tests/conj/bastv.scm   |   3 +
 src/ellinika/tests/conj/kauomai.scm |   4 +
 src/ellinika/tests/conj/ntynv.scm   |   2 +-
 4 files changed, 255 insertions(+), 181 deletions(-)
 create mode 100644 src/ellinika/tests/conj/bastv.scm
 create mode 100644 src/ellinika/tests/conj/kauomai.scm

(limited to 'src/ellinika')

diff --git a/src/ellinika/conjugator.scm b/src/ellinika/conjugator.scm
index c8fd012..25ae255 100644
--- a/src/ellinika/conjugator.scm
+++ b/src/ellinika/conjugator.scm
@@ -30,68 +30,102 @@
   (let ((res (sql-query conn query)))
 ;    (format #t "R: ~A~%" res)
     res))
+
+;; Verb info
+;;  #:verb  - Verb in dictionary form
+;;  #:conj  - Conjugation class
+;;
+;; Verb structure:
+;;  (class verb flag assoc)
+;; class      - Verb class
+;; verb       - the verb itself
+;; properties - associative list of properties
+;; attested
 
-(define verb-info-template
-  (list
-   (list "A"
-	 #f
-	 "ε"
-	 #f
-	 #f
-	 #f)
-   (list "B1"
-	  #f
-	  #f
-	  #f
-	  #f
-	  #f)
-   (list "B2"
-	  #f
-	  #f
-	  #f
-	  #f
-	  #f)))
-
-(define (guess-verb-info verb)
+(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))))
+       (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)
+     (list-ref verb 1))
+    ((#:attested)
+     (list-ref verb 3))
+    (else
+     (assoc-ref (list-ref verb 2) key))))
+
+   
+(define (guess-verb-class verb)
   (cond
    ;; FIXME
-   ((elstr-suffix? verb "άω")
-    (assoc "B1" verb-info-template))
-   ((elstr-suffix? verb "ώ")
-    (assoc "B2" verb-info-template))
+   ((elstr-suffix? verb "άω")    "B1")
+   ((elstr-suffix? verb "ώ")     "B2")
    ;; FIXME: deponentia?
-   (else
-    (assoc "A" verb-info-template))))
+   (else                         "A")))
 
-(define (get-verb-info conn verb . rest)
+(define (create-basic-verb-info conn verb proplist . rest)
+;  (format #t "PROPLIST ~A~%" proplist)
   (let ((class (if (null? rest)
 		   ""
 		   (string-append " AND conj='" (car rest) "'"))))
     (let ((vdb (my-sql-query
 		conn
 		(string-append
-		 "SELECT conj,accmap,augment,suffix FROM verb \
-WHERE verb='" (force-string verb) "'"
-                  class))))
+		 "SELECT conj FROM verbclass WHERE verb='" (force-string verb) "'"
+		 class))))
       (cond
-       ((and vdb (not (null? vdb)))
-	(let ((x (car vdb)))
-	  (list
-	   (list-ref x 0)
-	   (list-ref x 1)
-	   (or (list-ref x 2) "ε")
-	   (list-ref x 3)
-	   #f
-	   '(class))))
+       ((and vdb (not (null? vdb)));FIXME
+	(list (caar vdb) verb proplist '(class)))
        ((elstr-suffix? verb "άω")
-	(get-verb-info conn (elstr-append
-			(elstr-trim verb -2) "ώ") "B1"))
+	(create-basic-verb-info conn (elstr-append
+				      (elstr-trim verb -2) "ώ") "B1"))
        ((null? rest)
-	(guess-verb-info verb))
+	(list (guess-verb-class verb) verb proplist '()))
        (else
-	(assoc (car rest) verb-info-template))))))
+	(list (car rest) verb '() '()))))))
+
+(define (load-verb-info conn verb voice mood tense)
+;  (format #t "LOAD ~A~%" verb)
+  (let ((verbprop (my-sql-query
+		   conn
+		   (string-append
+		    "SELECT property,value FROM verbtense WHERE "
+		    "verb=\"" verb "\" AND voice=\"" voice
+		    "\" AND mood=\"" mood "\" AND tense=\"" tense "\""))))
+    (create-basic-verb-info conn 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)))))
+    
 	
-(define (thema-aoristoy-mesapathitikis root)
+(define (thema-aoristoy-mesapathitikis-A root)
   (cond
    ((elstr-suffix? root "αίν")
     (elstr-append (elstr-trim root -3) "ανθ")) ;; FIXME: Also αθ, ηθ
@@ -121,6 +155,24 @@ WHERE verb='" (force-string verb) "'"
    (else
     #f)))
 
+(define (thema-aoristoy-mesapathitikis-B root conj-aor)  
+  (let ((root-aor (elstr-trim (list-ref conj-aor 0) -1)))
+    (cond
+     ((elstr-suffix? root-aor "σ")
+      (elstr-append root
+		    (elstr-slice root-aor -2 1)
+		    "θ"))
+     ((elstr-suffix? root-aor "ξ")
+      (elstr-append root
+		    (elstr-slice root-aor -2 1)
+		    "χτ"))
+     ((elstr-suffix? root-aor "ψ")
+      (elstr-append root
+		    (elstr-slice root-aor -2 1)
+		    "φτ"))
+     (else
+      (elstr-append root "ηθ")))))
+
 (define (lookup-verb-info conn verb voice thema)
   (my-sql-query
    conn
@@ -144,50 +196,54 @@ WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'")))
 		  (if (and (null? tmpres) (string=? thema "sub"))
 		      (lookup-verb-info conn verb voice "aor")
 		      tmpres))))
-    (verb-info-set! #:root vinfo
+    (verb-set! vinfo #:root
 	       (cond
 		((not (null? result))
-		 (verb-info-set! #:attested vinfo 'root)
+		 (verb-set! vinfo #:attested 'root)
 		 (caar result))
-		((string=? (verb-info #:conj vinfo) "A")
+		((string=? (verb-get vinfo #:conj) "A")
 		 (let ((root (verb-A-root elverb)))
 		   (cond
 		    ((string=? thema "pres")
-		     (verb-info-set! #:attested vinfo 'root)
+		     (verb-set! vinfo #:attested 'root)
 		     root)
 		    ((or (string=? thema "aor") (string=? thema "sub"))
 		     (if (string=? voice "act")
 			 (elstr-thema-aoristoy root)
-			 (thema-aoristoy-mesapathitikis root)))
+			 (thema-aoristoy-mesapathitikis-A root)))
 		    (else
 		     #f))))
-		((string=? (verb-info #:conj vinfo) "A-depon")
+		((string=? (verb-get vinfo #:conj) "A-depon")
 		 (let ((root (verb-A-root elverb)))
 		   (cond
 		    ((string=? thema "pres")
-		     (verb-info-set! #:attested vinfo 'root)
+		     (verb-set! vinfo #:attested 'root)
 		     root)
 		    ((or (string=? thema "aor") (string=? thema "sub"))
 		     #f) ; FIXME
 		    (else
 		     #f))))		 
-		((string=? (verb-info #:conj vinfo) "B1")
+		((string=? (verb-get vinfo #:conj) "B1")
 		 (let ((root  (if (elstr-suffix? elverb "άω")
 				  (elstr-trim elverb -2)
 				  (elstr-trim elverb -1))))
 		   (cond
 		    ((or (string=? voice "act") (string=? thema "pres"))
-		     (verb-info-set! #:attested vinfo 'root)
+		     (verb-set! vinfo #:attested 'root)
 		     root)
 		    ((or (string=? thema "aor") (string=? thema "sub"))
-		     (elstr-append root "ηθ")) ;; FIXME: guesswork
+		     (thema-aoristoy-mesapathitikis-B
+		      root
+		      (list-ref
+		       (conjugate conn verb "act" "ind" "Αόριστος")
+		       0)))
 		    (else
 		     #f))))
-		((string=? (verb-info #:conj vinfo) "B2")
+		((string=? (verb-get vinfo #:conj) "B2")
 		 (let ((root (elstr-trim elverb -1)))
 		   (cond
 		    ((or (string=? voice "act") (string=? thema "pres"))
-		     (verb-info-set! #:attested vinfo 'root)
+		     (verb-set! vinfo #:attested 'root)
 		     root)
 		    ((or (string=? thema "aor") (string=? thema "sub"))
 		     (elstr-append root "ηθ")) ;; FIXME: guesswork
@@ -196,40 +252,6 @@ WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'")))
 		(else
 		 #f)))))
 
-(define-syntax verb-info
-  (syntax-rules ()
-    ((verb-info #:conj v)
-     (list-ref v 0))
-    ((verb-info #:accmap v)
-     (list-ref v 1))
-    ((verb-info #:augment v)
-     (list-ref v 2))
-    ((verb-info #:suffix v)
-     (list-ref v 3))
-    ((verb-info #:root v)
-     (list-ref v 4))
-    ((verb-info #:attested v)
-     (list-ref v 5))))
-
-(define-syntax verb-info-set!
-  (syntax-rules ()
-    ((verb-info-set! #:root v val)
-     (list-set! v 4 val))
-    ((verb-info-set! #:attested v val)
-     (list-set! v 5
-		(if (not val)
-		    val
-		    (let ((oldval (list-ref v 5)))
-		      (cond
-		       ((not oldval)
-			(list val))
-		       ((boolean? oldval)
-			(list val))
-		       ((member val oldval)
-			oldval)
-		       (else
-			(cons val oldval)))))))))
-
 (define-syntax conj-info
   (syntax-rules ()
     ((conj-info #:thema v)
@@ -264,7 +286,11 @@ WHERE verb='" verb "' AND voice='" voice "' AND thema='" thema "'")))
 (define-syntax conj-info-set!
   (syntax-rules ()
     ((conj-info-set! #:particle v val)
-     (list-set! v 3 val))))
+     (list-set! v 3 val))
+    ((conj-info-set! #:suffix v)
+     (list-set! v 1 val))
+    ((conj-info-set! #:accmap v)
+     (list-set! v 2 val)) ))
 
 (define (get-conj-info conn conj voice mood tense)
   (let ((answer (my-sql-query
@@ -296,22 +322,61 @@ WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mood='" mood
 	syl
 	(+ (- len syl) 1))))
 
+;; (define (get-property conj vinfo key default)
+;;   (if ((override (verb-get vinfo
+;; 			   (symbol->keyword
+;; 			    (string->symbol
+;; 			     (string-append
+;; 			      (symbol->string (keyword->symbol key))
+;; 			      "-override"))))))
+;;       (if override
+;; 	  (let ((t (conj-info key conj)))
+;; 	    (if t
+;; 		(or (verb-get vinfo key)
+;; 		    t)
+;; 		(or (verb-get vinfo key)
+;; 		    (conj-info key conj)
+;; 		    default))))))
+
+
+(define (get-suffix conj vinfo)
+  (let ((override (verb-get vinfo #:override)))
+    (if (and override
+	     (member "suffix" override))
+	(let ((t (conj-info #:suffix conj)))
+	  (if t
+	      (or (verb-get vinfo #:suffix)
+		  t)
+	      ""))
+	(or (verb-get vinfo #:suffix)
+	    (conj-info #:suffix conj)
+	    ""))))
+	
+
+(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)
 ;  (format #t "VINFO ~A~%" vinfo)
-  (let ((root (verb-info #:root vinfo))
-	(suffix (let ((s (conj-info #:suffix conj)))
-		  (if s
-		      (or (verb-info #:suffix vinfo) s)
-		      "")))
-	(accmap (string->list (or (verb-info #:accmap vinfo)
-				  (conj-info #:accmap conj)
-				  "000000")))
+  (let ((root (verb-get vinfo #:root))
+	(suffix (get-suffix conj vinfo))
+	(accmap (string->list (get-accmap conj vinfo)))
 	(augment ""))
-;    (format #t "ROOT ~S, ACCMAP ~S, SUFFIX: ~S~%" root accmap suffix)
+;    (format #t "ROOT ~A, ACCMAP ~S, SUFFIX: ~A~%" root accmap suffix)
     (cond
      ((> (length accmap) 6)
       (set! accmap (list-head accmap 6))
-      (set! augment (verb-info #:augment vinfo))))
+      (set! augment (or (verb-get vinfo #:augment) "ε"))))
+;    (format #t "AUGMENT ~A ~A~%" vinfo (verb-get  vinfo #:augment))
     (let ((forms
 	   (map
 	    (lambda (flect acc)
@@ -339,10 +404,12 @@ WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mood='" mood
 		 (elstr-deaccent (elstr-append root suffix))
 		 flect))
 	       ((char=? acc #\s)
-		(elstr-append
-		 (elstr-deaccent root)
-		 suffix
-		 (elstr-deaccent flect)))
+		(let ((nsyl (elstr-number-of-syllables flect)))
+		  (elstr-set-accent
+		   (elstr-append root suffix flect)
+		   (if (< nsyl 2)
+		       (+ nsyl 1)
+		       3))))
 	       ((char=? acc #\-)
 		#f)
 	       ((char-numeric? acc)
@@ -367,7 +434,8 @@ WHERE c.conj='" conj "' AND c.voice='" voice "' AND c.mood='" mood
 	   (lambda (w)
 	     (if w
 		 (string-append
-		  (conj-info #:particle conj) " " (force-string w))))
+		  (conj-info #:particle conj) " " (force-string w))
+		 #f))
 	   forms)
 	  (map force-string forms)))))
 
@@ -390,86 +458,85 @@ WHERE i.verb='" verb "' AND i.voice='" voice "' AND i.mood='" mood
    (lambda (a b)
      (or a b))
    lista listb))
-   
+
 (define (conjugate conn verb voice mood tense . rest)
   (cond
    ((individual-verb conn verb voice mood tense) =>
     (lambda (res)
       (list res)))
    (else
-    (map car
-     (let* ((vinfo (get-verb-info conn verb))
-	    (conj-list (get-conj-info conn
-				      (verb-info #:conj vinfo)
-				      voice mood tense)))
-       (if (not conj-list)
-	   (error "cannot obtain conjugation information for "
-		  (verb-info #:conj vinfo) voice mood tense))
-       (fold-right
-	(lambda (elt prev)
-;	  (format #t "ELT ~A~%" elt)
-	  (if (null? prev)
-	      (list elt)
-	      (let ((top (car prev)))
-		(if (let ((a (cdr elt))
-			  (b (cdr top)))
-		      (and (string? a) (string? b) (string=? a b)))
-		    (cons (cons
-			   (merge-conjugated-forms (car top) (car elt))
-			   (cdr top))
-			  (cdr prev))
-		    (cons elt prev)))))
-	'()
-	(map
-	 (lambda (conj)
-;	 (format #t "CONJ ~S~%" conj)
-	   (if (member #:nopart rest)
-	       (conj-info-set! #:particle conj #f))
-	   (cons
-	    (cond
-	     ((string=? (conj-info #:thema conj) "synt")
-	      (let* ((verb-conj
-		      (car (conjugate conn verb voice "sub" "Αόριστος"
-				      #:nopart)))
-		     (form (list-ref verb-conj 2))
-		     (part (conj-info #:particle conj)))
+    (let* ((vinfo (load-verb-info conn verb voice mood tense))
+	   (conj-list (get-conj-info conn
+				     (verb-get vinfo #:conj)
+				     voice mood tense)))
+      (if (not conj-list)
+	  (list (list #f #f #f #f #f #f) #f #f)
+	  (map car
+	   (fold-right
+	    (lambda (elt prev)
+;	      (format #t "ELT ~A~%" elt)
+	      (if (null? prev)
+		  (list elt)
+		  (let ((top (car prev)))
+		    (if (let ((a (cdr elt))
+			      (b (cdr top)))
+			  (and (string? a) (string? b) (string=? a b)))
+			(cons (cons
+			       (merge-conjugated-forms (car top) (car elt))
+			       (cdr top))
+			      (cdr prev))
+			(cons elt prev)))))
+	    '()
+	    (map
+	     (lambda (conj)
+;	       (format #t "CONJ ~S~%" conj)
+	       (if (member #:nopart rest)
+		   (conj-info-set! #:particle conj #f))
+	       (cons
 		(cond
-		 (form
-;		  (format #t "FORM ~A FROM ~A~%" form verb-conj);;FIXME
-		  (append
-		   (map
-		    (lambda (aux flag)
-		      (if (char=? flag #\-)
-			  #f
-			  (elstr->string
-			   (if part
-			       (elstr-append part " " aux " " form)
-			       (elstr-append aux " " form)))))
-		    (conjugation:table
-		     (car (conjugate conn
-				     (conj-info #:aux conj) "act" "ind"
-				     (conj-info #:auxtense conj))))
-		    (string->list (or (verb-info #:accmap vinfo)
-				      (conj-info #:accmap conj)
-				      "000000")))
-		   (list (verb-info #:conj vinfo)
-			 (conjugation:attested verb-conj))))
+		 ((string=? (conj-info #:thema conj) "synt")
+		  (let* ((verb-conj
+			  (car (conjugate conn verb voice "sub" "Αόριστος"
+					  #:nopart)))
+			 (form (list-ref verb-conj 2))
+			 (part (conj-info #:particle conj)))
+		    (cond
+		     (form
+;		      (format #t "FORM ~A FROM ~A~%" form verb-conj);;FIXME
+		      (append
+		       (map
+			(lambda (aux flag)
+			  (if (char=? flag #\-)
+			      #f
+			      (elstr->string
+			       (if part
+				   (elstr-append part " " aux " " form)
+				   (elstr-append aux " " form)))))
+			(conjugation:table
+			 (car (conjugate conn
+					 (conj-info #:aux conj) "act" "ind"
+					 (conj-info #:auxtense conj))))
+			(string->list (or (verb-get vinfo #:accmap)
+					  (conj-info #:accmap conj)
+					  "000000")))
+		       (list (verb-get vinfo #:conj)
+			     (conjugation:attested verb-conj))))
+		     (else
+		      #f))))
 		 (else
-		  #f))))
-	     (else
-	      (let ((thema (string-split (conj-info #:thema conj) #\:)))
-;		(format #t "THEMA ~A~%" thema)
-		(complement-verb-info conn vinfo verb
-				      (if (null? (cdr thema))
-					  voice
-					  (car (cdr thema)))
-				      (car thema))
-;		(format #t "VINFO ~A~%" vinfo)
-		(append (apply-flect conj vinfo verb)
-			(list (verb-info #:conj vinfo)
-			      (verb-info #:attested vinfo))))))
-	    (conj-info #:fold conj)))
-	 conj-list)))))))
+		  (let ((thema (string-split (conj-info #:thema conj) #\:)))
+;		    (format #t "THEMA ~A~%" thema)
+		    (complement-verb-info conn vinfo verb
+					  (if (null? (cdr thema))
+					      voice
+					      (car (cdr thema)))
+					  (car thema))
+;		    (format #t "VINFO ~A~%" vinfo)
+		    (append (apply-flect conj vinfo verb)
+			    (list (verb-get vinfo #:conj)
+				  (verb-get vinfo #:attested))))))
+		(conj-info #:fold conj)))
+	     conj-list))))))))
 
 (define-public (conjugator conn verb voice mood tense)
   (conjugate conn verb voice mood tense))
diff --git a/src/ellinika/tests/conj/bastv.scm b/src/ellinika/tests/conj/bastv.scm
new file mode 100644
index 0000000..f8a173f
--- /dev/null
+++ b/src/ellinika/tests/conj/bastv.scm
@@ -0,0 +1,3 @@
+(use-modules ((ellinika test-conjugation)))
+
+(test-conjugation:verb "βαστώ")
diff --git a/src/ellinika/tests/conj/kauomai.scm b/src/ellinika/tests/conj/kauomai.scm
new file mode 100644
index 0000000..000b19c
--- /dev/null
+++ b/src/ellinika/tests/conj/kauomai.scm
@@ -0,0 +1,4 @@
+(use-modules ((ellinika test-conjugation)))
+
+(test-conjugation:verb "κάθομαι")
+;(test-conjugation:tense "κάθομαι" "pas" "ind" "Αόριστος")
diff --git a/src/ellinika/tests/conj/ntynv.scm b/src/ellinika/tests/conj/ntynv.scm
index 160832d..1fd1545 100644
--- a/src/ellinika/tests/conj/ntynv.scm
+++ b/src/ellinika/tests/conj/ntynv.scm
@@ -1,3 +1,3 @@
-(use-modules ((ellinika test-conjugation)))
+(use-modules (ellinika test-conjugation))
 
 (test-conjugation:verb "ντύνω")
-- 
cgit v1.2.1