;;;; Verb Conjugator for modern Greek (δημοτική). ;;;; This file is part of Ellinika project. ;;;; 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 . (define-module (ellinika conjugator)) (use-modules (srfi srfi-1) (ellinika elmorph) (ellinika i18n) (ellinika tenses) (ellinika sql)) (use-syntax (ice-9 syncase)) ;; 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-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))) (value (if (and (eq? key #:stem) (not (list? value))) (list value) value))) (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 "άω") "B1") ((elstr-suffix? verb "ώ") "B2") ;; FIXME: deponentia? (else "A"))) (define (create-basic-verb-info verb proplist . rest) ; (format #t "PROPLIST ~A~%" proplist) (let ((vdb (if (null? rest) (ellinika:sql-query "SELECT conj FROM verbclass WHERE verb=\"~A\"" verb) (ellinika:sql-query "SELECT conj FROM verbclass WHERE verb=\"~A\" AND conj=~Q" verb (car rest))))) (cond ((and vdb (not (null? vdb))) (list (caar vdb) verb proplist '(class))) ((elstr-suffix? verb "άω") (create-basic-verb-info (elstr-append (elstr-trim verb -2) "ώ") proplist "B1")) ((null? rest) (list (guess-verb-class verb) verb proplist '())) (else (list (car rest) verb '() '()))))) (define (load-verb-info verb voice mood tense) ; (format #t "LOAD ~A~%" verb) (let ((verbprop (ellinika:sql-query "SELECT property,value FROM verbtense WHERE \ verb=\"~A\" AND voice=\"~A\" AND mood=\"~A\" AND tense=\"~A\"" verb voice mood tense))) (create-basic-verb-info verb (let loop ((inlist (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))) (stemlist '()) (outlist '())) ; (format #t "ARGS: ~A/~A/~A~%" inlist stemlist outlist) (cond ((null? inlist) (if (null? stemlist) outlist (cons (cons #:stem stemlist) outlist))) ((eq? (caar inlist) #:stem) (loop (cdr inlist) (cons (cdar inlist) stemlist) outlist)) (else (loop (cdr inlist) stemlist (cons (car inlist) outlist)))))))) (define (thema-aoristoy-mesapathitikis-A stem) (cond ((elstr-suffix? stem "αίν") (elstr-append (elstr-trim stem -3) "ανθ")) ;; FIXME: Also αθ, ηθ ((and (elstr-suffix? stem "ν") (logand (elstr-char-prop-bitmask stem -2) elmorph:vowel)) (elstr-append (elstr-trim stem -1) "θ")) ;; FIXME: also στ, νθ, θ ((and (elstr-suffix? stem "δ" "θ" "ζ" "ν") ;; FIXME: see above (logand (elstr-char-prop-bitmask stem -2) elmorph:vowel)) (elstr-append (elstr-trim stem -1) "στ")) ((elstr-suffix? stem "γγ" "σσ" "ττ" "χν" "γ" "ζ" "κ" "χ") => (lambda (suf) (elstr-append (elstr-trim stem (- 0 (elstr-length (string->elstr suf)))) "χτ"))) ;; also χθ ((elstr-suffix? stem "π" "β" "φ" "πτ" "φτ") => (lambda (suf) (elstr-append (elstr-trim stem (- 0 (elstr-length (string->elstr suf)))) "φτ"))) ;; also φθ ((elstr-suffix? stem "αύ" "εύ") => (lambda (suf) (elstr-append stem "τ"))) ((elstr-suffix? stem "άρ" "ίρ") ((elstr-append stem "ιστ"))) ((logand (elstr-char-prop-bitmask stem -1) elmorph:vowel) (elstr-append stem "θ")) (else #f))) (define (thema-aoristoy-mesapathitikis-B stem conj-aor) (let ((stem-aor (elstr-trim (list-ref conj-aor 0) -1))) (cond ((elstr-suffix? stem-aor "σ") (elstr-append stem (elstr-slice stem-aor -2 1) "θ")) ((elstr-suffix? stem-aor "ξ") (elstr-append stem (elstr-slice stem-aor -2 1) "χτ")) ((elstr-suffix? stem-aor "ψ") (elstr-append stem (elstr-slice stem-aor -2 1) "φτ")) (else (elstr-append stem "ηθ"))))) (define (lookup-verb-info verb voice thema) (ellinika:sql-query "SELECT stem FROM irregular_stem \ WHERE verb=\"~A\" AND voice=\"~A\" AND thema=\"~A\"" verb voice thema)) (define (verb-A-stem verb) (cond ((elstr-suffix? verb "ω") (elstr-trim verb -1)) ((elstr-suffix? verb "ομαι") (elstr-trim verb -4)) (else (throw 'conjugator-error 'conjugator-error-input "cannot handle ~A" (list (force-string verb)))))) (define (complement-verb-info vinfo verb voice thema) ; (format #t "COMPLEMENT ~A~%" vinfo) (let ((elverb (string->elstr verb)) (result (let ((tmpres (lookup-verb-info verb voice thema))) (if (and (null? tmpres) (string=? thema "sub")) (lookup-verb-info verb voice "aor") tmpres)))) (verb-set! vinfo #:stem (cond ((not (null? result)) (verb-set! vinfo #:attested 'stem) (map car result)) ((string=? (verb-get vinfo #:conj) "A") (let ((stem (verb-A-stem elverb))) (cond ((string=? thema "pres") (verb-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))) (else #f)))) ((string=? (verb-get vinfo #:conj) "A-depon") (let ((stem (verb-A-stem elverb))) (cond ((string=? thema "pres") (verb-set! vinfo #:attested 'stem) stem) ((or (string=? thema "aor") (string=? thema "sub")) #f) ; FIXME (else #f)))) ((string=? (verb-get vinfo #:conj) "B1") (let ((stem (if (elstr-suffix? elverb "άω") (elstr-trim elverb -2) (elstr-trim elverb -1)))) (cond ((or (string=? voice "act") (string=? thema "pres")) (verb-set! vinfo #:attested 'stem) stem) ((or (string=? thema "aor") (string=? thema "sub")) (thema-aoristoy-mesapathitikis-B stem (list-ref (conjugate verb "act" "ind" "Αόριστος") 0))) (else #f)))) ((string=? (verb-get vinfo #:conj) "B2") (let ((stem (elstr-trim elverb -1))) (cond ((or (string=? voice "act") (string=? thema "pres")) (verb-set! vinfo #:attested 'stem) stem) ((or (string=? thema "aor") (string=? thema "sub")) (elstr-append stem "ηθ")) ;; FIXME: guesswork (else #f)))) (else #f))))) (define-syntax conj-info (syntax-rules () ((conj-info #:thema v) (list-ref v 0)) ((conj-info #:suffix v) (list-ref v 1)) ((conj-info #:accmap v) (list-ref v 2)) ((conj-info #:particle v) (list-ref v 3)) ((conj-info #:aux v) (list-ref v 4)) ((conj-info #:auxtense v) (list-ref v 5)) ((conj-info #:fold v) (list-ref v 6)) ((conj-info #:flect v) (list-tail v 7)) ((conj-info #:sing 1 v) (list-ref v 8)) ((conj-info #:sing 2 v) (list-ref v 9)) ((conj-info #:sing 3 v) (list-ref v 10)) ((conj-info #:plur 1 v) (list-ref v 11)) ((conj-info #:plur 1 v) (list-ref v 12)) ((conj-info #:plur 1 v) (list-ref v 13)))) (define-syntax conj-info-set! (syntax-rules () ((conj-info-set! #:particle v 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 conj voice mood tense) (let ((answer (ellinika:sql-query "SELECT c.thema,c.suffix,c.accmap,c.particle,c.aux,c.auxtense,c.fold AS fold,\ f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \ FROM conjugation c, verbflect f \ WHERE c.conj=\"~A\" AND c.voice=\"~A\" AND c.mood=\"~A\" \ AND c.tense=\"~A\" AND c.flect = f.ident ORDER by fold" conj voice mood tense))) (if (null? answer) #f answer))) (define (force-string str) (if (elstr? str) (elstr->string str) str)) (define (force-elstr str) (if (string? str) (string->elstr str) str)) (define (accented-syllable-0 str) (let ((syl (elstr-accented-syllable str)) (len (elstr-number-of-syllables str))) (if (= syl 0) 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 stem) ; (format #t "VINFO ~A~%" vinfo) (let ((suffix (get-suffix conj vinfo)) (accmap (string->list (get-accmap conj vinfo))) (augment "")) ; (format #t "STEM ~A, ACCMAP ~S, SUFFIX: ~A~%" stem accmap suffix) (cond ((> (length accmap) 6) (set! accmap (list-head accmap 6)) (set! augment (or (verb-get vinfo #:augment) "ε")))) ; (format #t "AUGMENT ~A ~A~%" vinfo (verb-get vinfo #:augment)) (let ((forms (map (lambda (flect acc person) (cond ((verb-get vinfo (symbol->keyword (string->symbol (number->string person)))) => (lambda (personal-form) personal-form)) ((not flect) #f) ((char=? acc #\0) (let* ((rs (force-elstr stem)) (suf (elstr-deaccent (elstr-append suffix flect))) (result (elstr-append rs suf)) (nsyl (elstr-number-of-syllables result)) (acc-syl (+ (- nsyl (let ((n (accented-syllable-0 rs))) (if (= 0 n) (accented-syllable-0 verb) n))) 1))) (cond ((= nsyl 1) (elstr-deaccent result)) ((> acc-syl 3) (elstr-set-accent result 3)) ; FIXME (else (elstr-set-accent result acc-syl))))) ((char=? acc #\f) (elstr-append (elstr-deaccent (elstr-append stem suffix)) flect)) ((char=? acc #\s) (let ((nsyl (elstr-number-of-syllables flect))) (elstr-set-accent (elstr-append stem suffix flect) (if (< nsyl 2) (+ nsyl 1) 3)))) ((char=? acc #\-) #f) ((char-numeric? acc) (let ((num (- (char->integer acc) (char->integer #\0)))) (let ((obj (elstr-append stem suffix flect))) (if (and augment (= (+ (elstr-number-of-syllables obj) 1) num)) (set! obj (elstr-append augment obj))) (let ((nsyl (elstr-number-of-syllables obj))) (elstr-set-accent! obj (cond ((< num nsyl) num) ((< nsyl 3) nsyl) (else 3))) obj)))) (else (throw 'conjugator-error 'conjugator-error-db "invalid accent character ~A" (list acc))))) (conj-info #:flect conj) accmap '(1 2 3 4 5 6)))) (if (conj-info #:particle conj) (map (lambda (w) (if w (string-append (conj-info #:particle conj) " " (force-string w)) #f)) forms) (map force-string forms))))) (define (individual-verb verb voice mood tense) (let ((res (ellinika:sql-query "SELECT f.sing1,f.sing2,f.sing3,f.plur1,f.plur2,f.plur3 \ FROM individual_verb i,verbflect f \ WHERE i.verb=\"~A\" AND i.voice=\"~A\" AND i.mood=\"~A\"\ 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))) (define (merge-conjugated-forms lista listb) (map (lambda (a b) (or a b)) lista listb)) (define (conjugate verb voice mood tense . rest) (cond ((individual-verb verb voice mood tense) => (lambda (res) (list res))) (else (let* ((vinfo (load-verb-info verb voice mood tense)) (conj-list (get-conj-info (verb-get vinfo #:conj) voice mood tense))) (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 (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)))) ; (format #t "VINFO ~A~%" vinfo) (fold (lambda (stem prev) (cons (cons (append (apply-flect conj vinfo verb stem) (list (verb-get vinfo #:conj) (verb-get vinfo #:attested))) (conj-info #:fold conj)) prev)) prev (verb-get vinfo #:stem)))))) '() conj-list)))))))) (define-public (conjugator verb voice mood tense) (conjugate verb voice mood tense)) (define-public (conjugation:table conj) (cond ((not conj) #f) (else (list-head conj 6)))) (define-public (conjugation:class conj) (cond ((not conj) #f) (else (list-ref conj 6)))) (define-public (conjugation:attested conj) (cond ((not conj) #f) (else (list-ref conj 7)))) (define-public (empty-conjugation? conj) (or (not conj) (call-with-current-continuation (lambda (return) (for-each (lambda (x) (if x (return #f))) conj) (return #t)))))