diff options
Diffstat (limited to 'src/ellinika/conjugator.scm')
| -rw-r--r-- | src/ellinika/conjugator.scm | 354 |
1 files changed, 189 insertions, 165 deletions
diff --git a/src/ellinika/conjugator.scm b/src/ellinika/conjugator.scm index bffc6be..eae4ad0 100644 --- a/src/ellinika/conjugator.scm +++ b/src/ellinika/conjugator.scm @@ -39,3 +39,3 @@ -(define (verb-set! verb key value) +(define (vinfo-set! verb key value) ; (format #t "VERB ~A KEY ~A VALUE ~A~%" verb key value) @@ -62,3 +62,3 @@ -(define (verb-get verb key) +(define (vinfo-get verb key) (case key @@ -105,4 +105,4 @@ verb=\"~A\" AND voice=\"~A\" AND mood=\"~A\" AND tense=\"~A\"" - (verb-get vinfo #:verb) voice mood tense))) - (verb-set! + (vinfo-get vinfo #:verb) voice mood tense))) + (vinfo-set! vinfo #:proplist @@ -196,2 +196,7 @@ verb=\"~A\" AND voice=\"~A\" AND mood=\"~A\" AND tense=\"~A\"" +(define (thema-aoristou-prostaktikhs stem) + (if (elstr-suffix? stem "β" "γ" "θ" "ν") + (elstr-append stem "ε") + stem)) + (define (lookup-verb-info verb voice thema) @@ -212,2 +217,3 @@ WHERE verb=\"~A\" AND voice=\"~A\" AND thema=\"~A\"" +;; FIXME: Use vinfo #:verb instead of the verb argument. (define (complement-verb-info vinfo verb voice thema) @@ -219,8 +225,8 @@ WHERE verb=\"~A\" AND voice=\"~A\" AND thema=\"~A\"" tmpres)))) - (verb-set! vinfo #:stem + (vinfo-set! vinfo #:stem (cond ((not (null? result)) - (verb-set! vinfo #:attested 'stem) + (vinfo-set! vinfo #:attested 'stem) (map car result)) - ((string=? (verb-get vinfo #:conj) "A") + ((string=? (vinfo-get vinfo #:conj) "A") (let ((stem (verb-A-stem elverb))) @@ -228,11 +234,16 @@ WHERE verb=\"~A\" AND voice=\"~A\" AND thema=\"~A\"" ((string=? thema "pres") - (verb-set! vinfo #:attested 'stem) + (vinfo-set! vinfo #:attested 'stem) stem) ((or (string=? thema "aor") (string=? thema "sub")) - (if (string=? voice "act") - (elstr-thema-aoristoy stem) - (thema-aoristoy-mesapathitikis-A stem))) + (cond + ((string=? voice "act") + (elstr-thema-aoristoy stem)) + ((string=? voice "pas") + (thema-aoristoy-mesapathitikis-A stem)) + (else + (throw 'conjugator-error 'conjugator-error-db + "invalid voice ~A" (list voice))))) (else #f)))) - ((string=? (verb-get vinfo #:conj) "A-depon") + ((string=? (vinfo-get vinfo #:conj) "A-depon") (let ((stem (verb-A-stem elverb))) @@ -240,3 +251,3 @@ WHERE verb=\"~A\" AND voice=\"~A\" AND thema=\"~A\"" ((string=? thema "pres") - (verb-set! vinfo #:attested 'stem) + (vinfo-set! vinfo #:attested 'stem) stem) @@ -246,3 +257,3 @@ WHERE verb=\"~A\" AND voice=\"~A\" AND thema=\"~A\"" #f)))) - ((string=? (verb-get vinfo #:conj) "B1") + ((string=? (vinfo-get vinfo #:conj) "B1") (let ((stem (if (elstr-suffix? elverb "άω") @@ -252,3 +263,3 @@ WHERE verb=\"~A\" AND voice=\"~A\" AND thema=\"~A\"" ((or (string=? voice "act") (string=? thema "pres")) - (verb-set! vinfo #:attested 'stem) + (vinfo-set! vinfo #:attested 'stem) stem) @@ -258,6 +269,6 @@ WHERE verb=\"~A\" AND voice=\"~A\" AND thema=\"~A\"" (thema-aoristoy-mesapathitikis-B stem aor)) - (conjugate verb "act" "ind" "Αόριστος"))) + (conjugate vinfo "act" "ind" "Αόριστος"))) (else #f)))) - ((string=? (verb-get vinfo #:conj) "B2") + ((string=? (vinfo-get vinfo #:conj) "B2") (let ((stem (elstr-trim elverb -1))) @@ -265,3 +276,3 @@ WHERE verb=\"~A\" AND voice=\"~A\" AND thema=\"~A\"" ((or (string=? voice "act") (string=? thema "pres")) - (verb-set! vinfo #:attested 'stem) + (vinfo-set! vinfo #:attested 'stem) stem) @@ -345,3 +356,3 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" ;; (define (get-property conj vinfo key default) -;; (if ((override (verb-get vinfo +;; (if ((override (vinfo-get vinfo ;; (symbol->keyword @@ -354,5 +365,5 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" ;; (if t -;; (or (verb-get vinfo key) +;; (or (vinfo-get vinfo key) ;; t) -;; (or (verb-get vinfo key) +;; (or (vinfo-get vinfo key) ;; (conj-info key conj) @@ -362,3 +373,3 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" (define (get-suffix conj vinfo) - (let ((ret (let ((override (verb-get vinfo #:override))) + (let ((ret (let ((override (vinfo-get vinfo #:override))) (if (and override @@ -367,6 +378,6 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" (if t - (or (verb-get vinfo #:suffix) + (or (vinfo-get vinfo #:suffix) t) "")) - (or (verb-get vinfo #:suffix) + (or (vinfo-get vinfo #:suffix) (conj-info #:suffix conj) @@ -377,3 +388,3 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" (define (get-accmap conj vinfo) - (let ((override (verb-get vinfo #:override))) + (let ((override (vinfo-get vinfo #:override))) (if (and override @@ -382,5 +393,5 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" (if t - (or (verb-get vinfo #:accmap) + (or (vinfo-get vinfo #:accmap) t))) - (or (verb-get vinfo #:accmap) + (or (vinfo-get vinfo #:accmap) (conj-info #:accmap conj) @@ -396,4 +407,4 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" (set! accmap (list-head accmap 6)) - (set! augment (or (verb-get vinfo #:augment) "ε")))) -; (format #t "AUGMENT ~A ~A~%" vinfo (verb-get vinfo #:augment)) + (set! augment (or (vinfo-get vinfo #:augment) "ε")))) +; (format #t "AUGMENT ~A ~A~%" vinfo (vinfo-get vinfo #:augment)) (let ((forms @@ -402,3 +413,3 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" (cond - ((verb-get vinfo (symbol->keyword + ((vinfo-get vinfo (symbol->keyword (string->symbol @@ -470,3 +481,3 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" -(define (individual-verb verb voice mood tense) +(define (individual-verb vinfo voice mood tense) (let ((res (ellinika:sql-query @@ -476,8 +487,12 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" AND i.tense=\"~A\" AND i.ident=f.ident" - verb voice mood tense))) - (if (not (null? res)) - (append (car res) - (list "I" - '(class stem))) - #f))) + (vinfo-get vinfo #:verb) voice mood tense))) + (if (null? res) + #f + (map + (lambda (elt) + (append + elt + (list "I" + '(class stem)))) + res)))) @@ -489,137 +504,146 @@ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" -(define (conjugate verb voice mood tense . rest) +(define (conjugate vinfo voice mood tense . rest) (cond - ((individual-verb verb voice mood tense) => + ((individual-verb vinfo voice mood tense) => (lambda (res) - (list res))) + res)) (else - (let* ((vinfo (load-verb-info verb voice mood tense)) - (conj-list (get-conj-info (or - (verb-get vinfo #:class) - (verb-get vinfo #:conj)) - voice mood tense)) - (verb (force-string (verb-get vinfo #:verb)))) - (format #t "VINFO ~A~%" vinfo) - (if (not conj-list) - (list (list #f #f #f #f #f #f #f #f)) - (map car - (fold - (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))))) - '() - (fold - (lambda (conj prev) + (let ((vinfo (copy-tree vinfo))) + (if (not (member #:noload rest)) + (load-proplist vinfo voice mood tense)) +; (format #t "VINFO ~A~%" vinfo) + (let ((conj-list (get-conj-info (or + (vinfo-get vinfo #:class) + (vinfo-get vinfo #:conj)) + voice mood tense)) + (verb (force-string (vinfo-get vinfo #:verb)))) +; (format #t "VINFO ~A~%" vinfo) + (if (not conj-list) + (list (list #f #f #f #f #f #f #f #f)) + (map car + (fold + (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))))) + '() + (fold + (lambda (conj prev) ; (format #t "CONJ ~A~%" conj) - (if (member #:nopart rest) - (conj-info-set! #:particle conj #f)) - (cond - ((and (string=? (conj-info #:thema conj) "synt") - (conj-info #:aux conj)) - (let ((aparemfato-list - (map - (lambda (x) - (let ((t (conjugation:table x))) - (if t + (if (member #:nopart rest) + (conj-info-set! #:particle conj #f)) + (cond + ((and (string=? (conj-info #:thema conj) "synt") + (conj-info #:aux conj)) + (let ((aparemfato-list + (map + (lambda (x) + (let ((t (conjugation:table x))) + (if t + (cons + (list-ref t 2) + (conjugation:attested x)) + #f))) + (conjugate vinfo voice "sub" "Αόριστος" + #:nopart))) + (part (conj-info #:particle conj)) + (fold-id (conj-info #:fold conj))) + (fold + (lambda (param prev) + (if (not param) + prev + (let ((aparemfato (car param)) + (attested (cdr param))) + (cons (cons - (list-ref t 2) - (conjugation:attested x)) - #f))) - (conjugate verb voice "sub" "Αόριστος" - #:nopart))) - (part (conj-info #:particle conj)) - (fold-id (conj-info #:fold conj))) - (fold - (lambda (param prev) - (if (not param) - prev - (let ((aparemfato (car param)) - (attested (cdr param))) - (cons - (cons - (append - (map - (lambda (aux flag) - (if (char=? flag #\-) - #f - (elstr->string - (if part - (elstr-append part " " aux " " - aparemfato) - (elstr-append aux " " aparemfato))))) - (conjugation:table - (car (conjugate (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) - attested)) - fold-id) - prev)))) - prev - aparemfato-list))) - ((and (string=? (conj-info #:thema conj) "synt") - (conj-info #:auxtense conj)) - (let ((part (conj-info #:particle conj))) - (fold-right - (lambda (tenses prev) - (cons - (cons - (append - (map - (lambda (t) - (elstr->string (elstr-append part " " t))) - (list-head tenses 6)) - (list-tail tenses 6)) - (conj-info #:fold conj)) - prev)) - prev - (conjugate verb voice "ind" - (conj-info #:auxtense conj))))) - (else - (let ((vinfo (copy-tree vinfo))) - (if (verb-get vinfo #:stem) - (verb-set! vinfo #:attested 'stem) - (let ((thema (string-split (conj-info #:thema conj) #\:))) -; (format #t "THEMA ~A~%" thema) - (complement-verb-info vinfo verb - (if (null? (cdr thema)) - voice - (car (cdr thema))) - (car thema)))) - - (fold - (lambda (suffix prev) - (append - (fold - (lambda (stem prev) - (cons - (cons - (append (apply-flect conj vinfo verb stem suffix) - (list (verb-get vinfo #:conj) - (verb-get vinfo #:attested))) - (conj-info #:fold conj)) - prev)) - '() - (verb-get vinfo #:stem)) - prev)) - prev - (get-suffix conj vinfo)))))) - '() - conj-list)))))))) + (append + (map + (lambda (aux flag) + (if (char=? flag #\-) + #f + (elstr->string + (if part + (elstr-append part " " aux " " + aparemfato) + (elstr-append aux " " aparemfato))))) + (conjugation:table + (car (conjugate + (conjugator:open-verb + (conj-info #:aux conj)) + "act" "ind" + (conj-info #:auxtense conj)))) + (string->list (or (vinfo-get vinfo #:accmap) + (conj-info #:accmap conj) + "000000"))) + (list (vinfo-get vinfo #:conj) + attested)) + fold-id) + prev)))) + prev + aparemfato-list))) + ((and (string=? (conj-info #:thema conj) "synt") + (conj-info #:auxtense conj)) + (let ((part (conj-info #:particle conj))) + (fold-right + (lambda (tenses prev) + (cons + (cons + (append + (map + (lambda (t) + (elstr->string (elstr-append part " " t))) + (list-head tenses 6)) + (list-tail tenses 6)) + (conj-info #:fold conj)) + prev)) + prev + (conjugate vinfo voice "ind" + (conj-info #:auxtense conj) #:noload)))) + (else + (let ((vinfo (copy-tree vinfo))) + (if (vinfo-get vinfo #:stem) + (vinfo-set! vinfo #:attested 'stem) + (let ((thema (string-split + (conj-info #:thema conj) #\:))) +; (format #t "THEMA ~A~%" thema) + (complement-verb-info vinfo verb + (if (null? (cdr thema)) + voice + (car (cdr thema))) + (car thema)))) + + (fold + (lambda (suffix prev) + (append + (fold + (lambda (stem prev) + (cons + (cons + (append (apply-flect conj vinfo verb stem suffix) + (list (vinfo-get vinfo #:conj) + (vinfo-get vinfo #:attested))) + (conj-info #:fold conj)) + prev)) + '() + (vinfo-get vinfo #:stem)) + prev)) + prev + (get-suffix conj vinfo)))))) + '() + conj-list))))))))) + +(define-public (conjugator:open-verb verb) + (create-basic-verb-info verb)) (define-public (conjugator verb voice mood tense) - (conjugate verb voice mood tense)) + (conjugate (conjugator:open-verb verb) voice mood tense)) |