(use-modules (xlat))

(define (active-aorist-root present-root)
  (let ((last-syllable (car present-root)))
    (case (car last-syllable)
      ((#\@)
       (set-car! last-syllable #\s))
      ((#\z)
       (set-car! last-syllable #\s)) ;; FIXME: not always
      ((#\k)
       (cond
	((and (not (null? (cdr last-syllable)))
	      (char=? (cadr last-syllable) #\s))
	 (set! last-syllable (cons #\x (cddr last-syllable))))
	(else
	 (set-car! last-syllable #\x))))
      ((#\n)
       (cond
	((and (not (null? (cdr last-syllable)))
	      (char=? (cadr last-syllable) #\h))
	 (set! last-syllable (cons #\x (cddr last-syllable))))
	(else
	 (set-car! last-syllable #\s))))
      ((#\g #\h)
       (set-car! last-syllable #\x))
      ((#\p #\b #\f)
       (set-car! last-syllable #\*))
      ((#\y)
       (cond
	((and (not (null? (cdr last-syllable)))
	      (or (char=? (cadr last-syllable) #\a)
		  (char=? (cadr last-syllable) #\e)))
	 (set! last-syllable (cons #\* (cddr last-syllable))))))
      (else
       (throw 'grammar "Dont't know how to handle " present-root)))
    (cons last-syllable (cdr present-root))))


(define (aor str)
  (active-aorist-root (cdr (greek-normalize str))))


(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))))))
    (cons
     (if (> 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)))
      
(define verbal-flect-table
  (list
   (cons "Α"
	 (list 
	  (cons "ενεργητηκή"
		(list
		 (cons "οριστική"
		       (list
			(cons "ενεστώτας"
			      (flect-list #f
				    (list "ω")
				    (list "εις")
				    (list "ει")
				    (list "ουμε")
				    (list "ετε")
				    (list "ουν" "ουνε")))
			(cons "παρατατικός"
			      (flect-list (lambda (x flect)
				      (shift-accent
				       (add-flection x flect)))
				    (list "α")
				    (list "ες")
				    (list "ε")
				    (list "αμε")
				    (list "ατε")
				    (list "αν" "ανε")))
			(cons "μέλλοντας διαρκείας"
			      (flect-list (lambda (x)
				      (list "θα" x))
				    (list "ω")
				    (list "εις")
				    (list "ει")
				    (list "ουμε")
				    (list "ετε")
				    (list "ουν" "ουνε")))))))))))
  

;; ("άω")
;; ("άς")
;; ("ά" "άει")
;; ("άμε")
;; ("άτε")
;; ("ούν" "ούνε")
;;
;; ("ώ")
;; ("είς")
;; ("εί")
;; ("ούμε")
;; ("είτε")
;; ("ούν" "ούνε")


(define (verbal-flect-table-lookup table form-list)
  (if (null? form-list)
      table 
      (let ((entry (assoc (car form-list) table)))
	(if entry
	    (verbal-flect-table-lookup (cdr entry) (cdr form-list))
	    #f))))
  
(define (find-verbal-form . rest)
  (verbal-flect-table-lookup verbal-flect-table rest))


(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)))
      (map
       (lambda (x)
	 (func root x))
       (list-ref tab pers)))))
       

(do ((i 1 (1+ i)))
    ((> i 6) #f)
  (map
   (lambda (x)
     (display (xlat->greek x))(display ","))
   (conjugate (greek->xlat "βεβαίων")
	      i "Α" "ενεργητηκή" "οριστική"  "ενεστώτας"))
  (newline))
(newline)