aboutsummaryrefslogtreecommitdiff
path: root/src/ellinika/dico.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/ellinika/dico.scm')
-rw-r--r--src/ellinika/dico.scm66
1 files changed, 59 insertions, 7 deletions
diff --git a/src/ellinika/dico.scm b/src/ellinika/dico.scm
index 9383d1f..c156862 100644
--- a/src/ellinika/dico.scm
+++ b/src/ellinika/dico.scm
@@ -221,8 +221,57 @@ Invariant Sections, no Front-Cover and Back-Cover Texts"))
"\" AND dict.ident=articles.ident "
"AND articles.lang='" (dbh:lang dbh) "' ORDER BY 1")))
-(define (match-basic-regex dbh strat word)
- #f) ;FIXME
+;; Implementation of a Common LISP mapcan function
+(define (mapcan fun list)
+ (apply (lambda ( . slist)
+ (let loop ((elt '())
+ (slist slist))
+ (cond
+ ((null? slist)
+ (reverse elt))
+ ((not (car slist))
+ (loop elt (cdr slist)))
+ (else
+ (loop (cons (car slist) elt) (cdr slist))))))
+ (map fun list)))
+
+;; Convert SLIST, which is a list of strings, into a string of
+;; comma-separated values.
+(define (list->csv slist)
+ (apply string-append
+ (let loop ((elt '())
+ (slist slist))
+ (cond
+ ((null? (cdr slist))
+ (reverse
+ (cons "\"" (cons (car slist) (cons "\"" elt)))))
+ (else
+ (loop (cons "\"," (cons (car slist) (cons "\"" elt)))
+ (cdr slist)))))))
+
+(define (match-selector dbh strat key)
+ (let* ((sound (ellinika:sounds-like key))
+ (dlist (mapcan
+ (lambda (elt)
+ (let ((word (car elt)))
+ (and (dico-strat-select? strat word sound)
+ word)))
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.sound FROM dict,articles "
+ "WHERE dict.ident=articles.ident "
+ "AND articles.lang='" (dbh:lang dbh)
+ "' ORDER BY 1")))))
+ (if (not (null? dlist))
+ (my-sql-query
+ (dbh:conn dbh)
+ (string-append
+ "SELECT DISTINCT dict.word FROM dict "
+ "WHERE dict.sound IN ("
+ (list->csv dlist)
+ ")"))
+ #f)))
(define (match-default dbh strat word)
(my-sql-query
@@ -238,14 +287,17 @@ Invariant Sections, no Front-Cover and Back-Cover Texts"))
(list (cons "exact" match-exact)
(cons "prefix" match-prefix)
(cons "suffix" match-suffix)
- (cons "re" match-extnd-regex)
- (cons "regexp" match-basic-regex)))
+ (cons "re" match-extnd-regex)))
(define (match-word dbh strat word)
(let ((sp (assoc (dico-strat-name strat) strategy-list)))
- (let ((res (if sp
- ((cdr sp) dbh strat word)
- (match-default dbh strat word))))
+ (let ((res (cond
+ (sp
+ ((cdr sp) dbh strat word))
+ ((dico-strat-selector? strat)
+ (match-selector dbh strat word))
+ (else
+ (match-default dbh strat word)))))
(if res
(cons #f (map car res))
#f))))

Return to:

Send suggestions and report system problems to the System administrator.