Updated

git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@122 941c8c0f-9102-463b-b60b-cd22ce0e6858

2 files changed, 220 insertions, 77 deletions

diff --git a/scm/conj.scm b/scm/conj.scm
index 781d630..3c2e96a 100644
--- a/scm/conj.scm
+++ b/scm/conj.scm
@@ -30,7 +30,7 @@
 	((and (not (null? (cdr last-syllable)))
 	      (or (char=? (cadr last-syllable) #\a)
 		  (char=? (cadr last-syllable) #\e)))
-	 (set! last-syllable (cons #\* (cddr last-syllable))))))
+	 (set! last-syllable (cons #\* (cdr last-syllable))))))
       (else
        (throw 'grammar "Dont't know how to handle " present-root)))
     (cons last-syllable (cdr present-root))))
@@ -42,26 +42,15 @@
 
 (define (add-flection word flect)
   (let* ((syl-list (append (cdr flect) (cdr word)))
-	 (acc-pos (if (car flect)
-		      (car flect)
-		      (+ (car word) (length (cdr flect))))))
+	 (acc-pos (or (car flect)
+		      (and (car word)
+			   (+ (car word) (length (cdr flect)))))))
     (cons
-     (if (> acc-pos 3)
+     (if (and acc-pos (> acc-pos 3))
 	 3
 	 acc-pos)
      syl-list)))
 
-(define (flect-list fun . p)
-  (cons
-   fun
-   (map
-    (lambda (pers)
-      (map
-       (lambda (f)
-	 (cons #f (cdr (greek->xlat f))))
-       pers))
-    p)))
-
 ; FIXME: Should return real augment!
 (define (get-augment root)
   #\e)
@@ -74,6 +63,50 @@
 	      (append (cdr word) (list (list (get-augment root))))
 	      (cdr word)))))
 
+(define (create-paratatikos-B root flect)
+  (add-flection root (add-flection (greek->xlat "ούσ")
+				   (cons
+				    #f
+				    (cdr flect)))))
+
+(define (create-prostaktiki-enestota root flect)
+  (let ((w (add-flection root flect)))
+    (cond
+     ((car flect)
+      (cons (car flect) (cdr w)))
+     ((>= (length (cdr w)) 3)
+      (cons 3 (cdr w)))
+     ((not (car w))
+      (cons (length (cdr w)) (cdr w)))
+     (else
+      w))))
+
+;; Verbal form Accessors
+(define (vtab-root tab)
+  (car tab))
+
+(define (vtab-analizer tab)
+  (list-ref tab 2))
+
+(define (vtab-composer tab)
+  (or (list-ref tab 1)
+      add-flection))
+
+(define (vtab-flection tab person)
+  (list-ref tab (+ person 2)))
+
+;;
+(define (flect-list root composer analizer . p)
+  (append
+   (list root composer analizer)
+   (map
+    (lambda (pers)
+      (map
+       greek->xlat
+       pers))
+    p)))
+
+;;
 (define verbal-flect-table
   (list
    (cons "Α"
@@ -84,6 +117,8 @@
 		       (list
 			(cons "ενεστώτας"
 			      (flect-list
+			       #:present-root
+			       #f
 			       #f
 			       (list "ω")
 			       (list "εις")
@@ -93,7 +128,9 @@
 			       (list "ουν" "ουνε")))
 			(cons "παρατατικός"
 			      (flect-list
+			       #:present-root
 			       create-paratatikos-A
+			       #f
 			       (list "α")
 			       (list "ες")
 			       (list "ε")
@@ -102,30 +139,121 @@
 			       (list "αν" "ανε")))
 			(cons "μέλλοντας διαρκείας"
 			      (flect-list
-			       (lambda (x)
-				 (list "θα" x))
+			       #:present-root
+			       #f ;; FIXME: "θα"
+			       #f
 			       (list "ω")
 			       (list "εις")
 			       (list "ει")
 			       (list "ουμε")
 			       (list "ετε")
-			       (list "ουν" "ουνε")))))))))))
-  
+			       (list "ουν" "ουνε")))))
 
-;; ("άω")
-;; ("άς")
-;; ("ά" "άει")
-;; ("άμε")
-;; ("άτε")
-;; ("ούν" "ούνε")
-;;
-;; ("ώ")
-;; ("είς")
-;; ("εί")
-;; ("ούμε")
-;; ("είτε")
-;; ("ούν" "ούνε")
+		 (cons "προστακτική"
+		       (list
+			(cons "ενεστώτας"
+			      (flect-list
+			       #:present-root
+			       create-prostaktiki-enestota
+			       #f
+			       '()
+			       (list "ε")
+			       '()
+			       '()
+			       (list "ετε")
+			       '())))) ))))
+   (cons "Β1"
+	 (list 
+	  (cons "ενεργητηκή"
+		(list
+		 (cons "οριστική"
+		       (list
+			(cons "ενεστώτας"
+			      (flect-list
+			       #:present-root
+			       #f
+			       #f
+			       (list "άω")
+			       (list "άς")
+			       (list "ά" "άει")
+			       (list "άμε")
+			       (list "άτε")
+			       (list "ούν" "ούνε")))
+			(cons "παρατατικός"
+			      (flect-list
+			       #:present-root
+			       create-paratatikos-B
+			       #f
+			       (list "α")
+			       (list "ες")
+			       (list "ε")
+			       (list "αμε")
+			       (list "ατε")
+			       (list "αν" "ανε")))
+			(cons "μέλλοντας διαρκείας"
+			      (flect-list
+			       #:present-root
+			       #f ;; FIXME: "θα"
+			       #f
+			       (list "άω")
+			       (list "άς")
+			       (list "ά" "άει")
+			       (list "άμε")
+			       (list "άτε")
+			       (list "ούν" "ούνε"))) ))
 
+		 (cons "προστακτική"
+		       (list
+			(cons "ενεστώτας"
+			      (flect-list
+			       #:present-root
+			       create-prostaktiki-enestota
+			       #f
+			       '()
+			       (list "α")
+			       '()
+			       '()
+			       (list "άτε")
+			       '())))) ))))
+   (cons "Β2"
+	 (list 
+	  (cons "ενεργητηκή"
+		(list
+		 (cons "οριστική"
+		       (list
+			(cons "ενεστώτας"
+			      (flect-list
+			       #:present-root
+			       #f
+			       #f
+			       (list "ώ")
+			       (list "είς")
+			       (list "εί")
+			       (list "ούμε")
+			       (list "είτε")
+			       (list "ούν" "ούνε")))
+			(cons "παρατατικός"
+			      (flect-list
+			       #:present-root
+			       create-paratatikos-B
+			       #f
+			       (list "α")
+			       (list "ες")
+			       (list "ε")
+			       (list "αμε")
+			       (list "ατε")
+			       (list "αν" "ανε")))
+			(cons "μέλλοντας διαρκείας"
+			      (flect-list
+			       #:present-root
+			       #f ;; FIXME: "θα"
+			       #f
+			       (list "ώ")
+			       (list "είς")
+			       (list "εί")
+			       (list "ούμε")
+			       (list "είτε")
+			       (list "ούν" "ούνε"))) ))))))))
 
 (define (verbal-flect-table-lookup table form-list)
   (if (null? form-list)
@@ -139,53 +267,69 @@
   (verbal-flect-table-lookup verbal-flect-table rest))
 
 
-(define (conjugate root pers . forms)
+(define (conjugate root pers forms)
   (let ((tab (verbal-flect-table-lookup verbal-flect-table forms)))
     (if (not tab)
 	(throw 'grammar "Verbal form not found " forms))
-    (let ((func (or (car tab)
-		    add-flection)))
+    (let ((func (vtab-composer tab))
+	  (root-selector (vtab-root tab)))
+      
       (map
        (lambda (x)
 	 (func root x))
-       (list-ref tab pers)))))
+       (vtab-flection tab pers)))))
        
+(define (conjugate-v root pers . forms)
+  (conjugate root pers forms))
+
+;; Test
 
-(do ((i 1 (1+ i)))
-    ((> i 6) #f)
-  (map
-   (lambda (x)
-     (display (xlat->greek x))(display ","))
-   (conjugate (greek->xlat "βεβαίων")
-	      i "Α" "ενεργητηκή" "οριστική"  "ενεστώτας"))
-  (newline))
-(newline)
+(define (conj-all root . rest)
+  (map (lambda (x)
+	 (display x)(display "/"))
+       rest)
+  (newline)
+  (do ((i 1 (1+ i)))
+      ((> i 6) #f)
+    (map
+     (lambda (x)
+       (display (xlat->greek x))(display ","))
+     (conjugate (greek->xlat root) i rest))
+    (newline)))
+  
 
-(do ((i 1 (1+ i)))
-    ((> i 6) #f)
-  (map
-   (lambda (x)
-     (display (xlat->greek x))(display ","))
-   (conjugate (greek->xlat "βεβαίων")
-	      i "Α" "ενεργητηκή" "οριστική"  "παρατατικός"))
-  (newline))
-(newline)
+;(conj-all "βεβαίων" "Α" "ενεργητηκή" "οριστική"  "ενεστώτας")
+;(newline)
 
-(do ((i 1 (1+ i)))
-    ((> i 6) #f)
-  (map
-   (lambda (x)
-     (display (xlat->greek x))(display ","))
-   (conjugate (greek->xlat "λύν")
-	      i "Α" "ενεργητηκή" "οριστική"  "παρατατικός"))
-  (newline))
+;(conj-all "βεβαίων" "Α" "ενεργητηκή" "οριστική"  "παρατατικός")
+;(newline)
 
+;(conj-all "ντυν" "Α" "ενεργητηκή" "προστακτική" "ενεστώτας")
+;(newline)
+;(conj-all "βεβαίων" "Α" "ενεργητηκή" "προστακτική" "ενεστώτας")
+;(newline)
+;(conj-all "διαβάζ" "Α" "ενεργητηκή" "προστακτική" "ενεστώτας")
+;(newline)
 
+;(conj-all "λύν" "Α" "ενεργητηκή" "οριστική"  "παρατατικός")
+;(newline)
 
+;(conj-all "νικ" "Β1" "ενεργητηκή" "οριστική"  "ενεστώτας")
+;(newline)
 
+;(conj-all "νικ" "Β1" "ενεργητηκή" "οριστική"  "παρατατικός")
+;(newline)
 
+;(conj-all "νικ" "Β1" "ενεργητηκή" "προστακτική" "ενεστώτας")
+;(newline)
+
+;(conj-all "θεωρ" "Β2" "ενεργητηκή" "οριστική"  "ενεστώτας")
+;(newline)
        
-    
-    
+;(conj-all "θεωρ" "Β2" "ενεργητηκή" "οριστική"  "παρατατικός")
+;(newline)
+
+;(display (xlat->greek (cons #f (active-aorist-root (cdr (greek->xlat "ιατρευ"))))))
+;(newline)
 	
 
diff --git a/scm/xlat.scm b/scm/xlat.scm
index 7548e54..37028b3 100644
--- a/scm/xlat.scm
+++ b/scm/xlat.scm
@@ -101,7 +101,7 @@
    (cons  "Ϋ" #\Y )
    (cons  "ΰ" (cons #\Y #t))))
 
-(define (greek->xlat0 str)
+(define-public (greek->xlat0 str)
   "Convert the greek STRing into its latin transliteration. Returns
 
      (list AP XLAT)
@@ -116,9 +116,8 @@ Secondary accents are ignored"
 	 (lcnt 0 (1+ lcnt))
 	 (sl '()))
 	((= i len) (cons
-		    (if accent-pos
-			(- (length sl) accent-pos 1)
-			0)
+		    (and accent-pos
+			 (- (length sl) accent-pos 1))
 		    (reverse sl)))
       (letrec ((get-trans (lambda (x) 
 			    (let ((y (cdr x)))
@@ -225,7 +224,7 @@ Secondary accents are ignored"
 	(set! wl (cdr wl))
 	(set! syl (cons a syl))
 	(cond
-	 ((= ap (length wl))
+	 ((and ap (= ap (length wl)))
 	  (set! accented (length sl)))
 	 (else
 	  (case a
@@ -235,7 +234,7 @@ Secondary accents are ignored"
 		    (or (char=? (car wl) #\i) (char=? (car wl) #\y)))
 	       (set! syl (cons (car wl) syl))
 	       (set! wl (cdr wl))
-	       (if (= ap (length wl))
+	       (if (and ap (= ap (length wl)))
 		   (set! accented (length sl))))))
 	    ((#\i)
 	     (if (not (null? wl))
@@ -244,19 +243,19 @@ Secondary accents are ignored"
 		       (char=? (car wl) #\a))
 		   (set! syl (cons (car wl) syl))
 		   (set! wl (cdr wl))
-		   (if (= ap (length wl))
+		   (if (and ap (= ap (length wl)))
 		       (set! accented (length sl))))
 		  ((char=? (car wl) #\o)
 		   ;; "ιο" ή "ιου"
 		   (set! syl (cons (car wl) syl))
 		   (set! wl (cdr wl))
 		   (cond
-		    ((= ap (length wl))
+		    ((and ap (= ap (length wl)))
 		     (set! accented (length sl)))
 		    ((and (not (null? wl)) (char=? (car wl) #\y))
 		     (set! syl (cons (car wl) syl))
 		     (set! wl (cdr wl))
-		     (if (= ap (length wl))
+		     (if (and ap (= ap (length wl)))
 		      (set! accented (length sl)))))))))
 	    ((#\y)
 	     (cond
@@ -264,7 +263,7 @@ Secondary accents are ignored"
 		    (char=? (car wl) #\i))
 	       (set! syl (cons (car wl) syl))
 	       (set! wl (cdr wl))
-	       (if (= ap (length wl))
+	       (if (and ap (= ap (length wl)))
 		   (set! accented (length sl))))))
 	    ((#\Y #\I)
 	     (set! accented (length sl))))))
@@ -273,9 +272,9 @@ Secondary accents are ignored"
 	     
 (define-public (greek->xlat str)
   (let* ((wl (greek->xlat0 str))
-	 (sl (prosodia (car wl) (cdr wl) 0 '())))
+	 (sl (prosodia (car wl) (cdr wl) #f '())))
     (cons
-     (- (length (cdr sl)) (car sl))
+     (and (car sl) (- (length (cdr sl)) (car sl)))
      (cdr sl))))
 
 ;;;; End of file
\ No newline at end of file