#| 
   Database routines for PostgreSQL.
   
   Author: Dmitri Hrapof <yavannadil@yahoo.com>
   Version: 0.4
   Copyright (C) 2004, 2009 Dmitri Hrapof

This file is part of Geiriadur.

Geiriadur 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 2, or (at your option)
any later version.

Geiriadur 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 Geiriadur; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  
|#

(in-package geiriadur)

(defparameter *log-sql* nil)

(defun stroqa (stream arg colon dog &rest params)
  (declare (ignore colon dog params))
  (princ #\' stream)
  (map nil
       #'(lambda (c) (if (char= c #\') (princ "''" stream) (princ c stream)))
       arg)
  (princ #\' stream))

(defun jo (stream arg colon dog &rest params)
  (declare (ignore colon dog params))
  (princ "'^" stream)
  (map nil
       #'(lambda (c) 
	   (case c
	     (#\' (princ "''" stream))
	     (#\е (princ "[её]" stream))
	     (t (princ c stream))))
       arg)
  (princ "$'" stream))

(defun set-languages (conn)
  (setf *date* (multiple-value-list (get-decoded-time)))
  (pg:pg-for-each
   conn "select l.id, name, coalesce(max(length(e.val)),0) from languages as l left join e on l.id=e.lang group by l.id, name order by l.id"
   #'(lambda (lt)
       (setf 
	(gethash (first lt) *languages*) 
	(make-lang 
	 :id (first lt) :name (second lt) :maxelen (third lt)
	 :mutable (cdr (assoc (first lt) +mutations+)))))))

(defun connect-to-db ()
  (setf *conn*
	(pg:pg-connect  "geiriadur" "geiriadur"))
  (setf (pg:pg-client-encoding *conn*) "UNICODE"))

(defun db-exec (conn sql) (pg:pg-result (pg:pg-exec conn sql) :tuples))

#+clisp
(defun db-call (conn sql)
  (when *log-sql* (format t "~a~%" sql) (finish-output t))
  (handler-case
      (db-exec conn sql)
    (system::simple-os-error (oe)
      (format *error-output* "~a~%" oe)
      (handler-case
	  (progn (connect-to-db) (db-exec conn sql))
	(system::simple-os-error (oe)
	  (format *error-output* "~a~%" oe) (values nil nil))))))

#-clisp
(defun db-call (conn sql)
  (handler-case
      (db-exec conn sql)
    (error (oe)
      (format *error-output* "~a~%" oe)
      (handler-case
	  (progn (connect-to-db) (db-exec conn sql))
	(error (oe)
	  (format *error-output* "~a~%" oe) (values nil nil))))))

(defmacro db-ask (&rest args)
  `(db-call conn (format nil ,@args)))

(defmacro doquery (var args &rest body)
  `(dolist (,var (db-ask ,@args))
     ,@body))

(defun db-tree (tree h id-sql table)
  (pg:pg-for-each
   *conn* id-sql
   #'(lambda (id)
       (setf (gethash (car id) h) (cadr id))
       (coeden:inoculate tree id #'levenshtein-metric :key #'cadr))))

(defun db-init (nc)
  (if nc 
      (progn 
	(connect-to-db) (set-languages *conn*) (setf *gone* t)
;	#+sbcl
;	(maphash
;	 #'(lambda (k lng)
;	     (db-tree 
;	      (lang-sree lng) 
;	      (format nil "select id, val from s where lang=~a" k) 
;	      "s")
;	     (db-tree 
;	      (lang-free lng) 
;	      (format 
;	       nil 
;	       "select f.id, f.val from f, s where f.word=s.id and s.lang=~a" k)
;	      "f"))
;	 *languages*)
	)
      (progn
      (pg:with-pg-connection
     (conn "geiriadur" "geiriadur")
     (setf (pg:pg-client-encoding conn) "UNICODE")
     (set-languages conn)
     (setf *r5k* (caar (db-ask "select count(*) from rf where num<5001 and exists (select 1 from p, s where p.first=rf.id and p.second=s.id and s.lang=1)")))
     (setf *r30k* (caar (db-ask "select count(*) from rf where num<30001 and exists (select 1 from p, s where p.first=rf.id and p.second=s.id and s.lang=1)")))
     (setf *c5k* (caar (db-ask "select count(*) from cf where num<5001 and exists (select 1 from p, s where p.first=cf.id and p.second=s.id and s.lang=0)")))
     (setf *c30k* (caar (db-ask "select count(*) from cf where num<30001 and exists (select 1 from p, s where p.first=cf.id and p.second=s.id and s.lang=0)")))
     (let ((lc (hash-table-count *languages*)))
       (setf *p-count* (make-array `(,lc ,lc) :initial-element 0))
       (setf *s-count* (make-array `(,lc ,lc) :initial-element 0))
       (setf *p-by-1st* (make-array `(,lc ,lc)))
       (setf *p-by-2nd* (make-array `(,lc ,lc)))
       (dotimes (i lc)
	 (let ((lng (gethash i *languages*)) sl fl)
	   (doquery tuple ("select * from s where lang=~a" i)
	     (push tuple sl)
	     (setf (gethash (first tuple) *s-by-id*) tuple)
	     (incf (lang-wcount lng))
	     (push tuple (gethash (fourth tuple) (lang-sbyv lng))))
	   (coeden:grow (lang-sree lng) sl #'levenshtein-metric :key #'fourth)
	   (format t "s ~a~%" (lang-name lng))
	   (doquery 
	    tuple ("select k.* from k, s where k.word=s.id and s.lang=~a" i)
	    (setf (fourth tuple) (read-from-string (fourth tuple)))
	    (push tuple (gethash (third tuple) (lang-kbyv lng)))
	    (push tuple (gethash (second tuple) (lang-kbyw lng))))
	   (format t "k ~a~%" (lang-name lng))
	   ;(doquery 
	   ; tuple ("select f.* from f, s where f.word=s.id and s.lang=~a" i)
	   ; (push tuple fl)
	   ; (push tuple (gethash (third tuple) (lang-fbyv lng)))
	   ; (push tuple (gethash (second tuple) *f-by-word*)))
	   ;(coeden:grow (lang-free lng) fl #'levenshtein-metric :key #'third)
	   (format t "f ~a~%" (lang-name lng))
	   (doquery 
	    tuple ("select * from e where lang=~a" i)
	    (let ((duple 
		   (append 
		    tuple 
		    (list 
		     (string-trim 
		      "()" (substitute #\Space #\| (fifth tuple)))))))
	      (setf (fifth duple) (read-from-string (fifth tuple)))	    
	      (push duple (gethash (fourth tuple) (lang-ebyv lng)))
	      (push duple (gethash (third tuple) (lang-ebyp lng)))))
	   (format t "e ~a~%" (lang-name lng)))
	 (dotimes (j lc)
	   (setf (aref *p-by-1st* i j) (make-hash-table))
	   (setf (aref *p-by-2nd* j i) (make-hash-table))
	   (doquery 
	    tuple ("select p.* from p, s, s as ss where p.first=s.id and p.second=ss.id and s.lang=~a and ss.lang=~a" i j)
	    (incf (aref *p-count* i j))
	    (when (null (gethash (second tuple) (aref *p-by-1st* i j))) (incf (aref *s-count* i j)))
	    (push tuple (gethash (second tuple) (aref *p-by-1st* i j)))
	    (if (< 10 (third tuple))
		(push tuple (gethash (third tuple) (aref *p-by-2nd* j i)))))
	   (format t "p ~a ~a~%" i j))))
     (doquery tuple ("select x.* from x order by tran, id desc")
	      (push tuple (gethash (second tuple) *x-by-tran*)))
     (format t "x ~%"))
      (connect-to-db))))

(defmethod select-examples ((conn pg::pgcon) tran)
  (db-ask "select * from x where tran = ~a order by id" tran))

(defun test-find-by-flexion (conn word from)
  (let (res)
    (dolist (dbl (blow-up word 10) res)
      (doquery 
       otup ("select * from e where lang = ~a and val = ~/gdr:stroqa/" from (cdr dbl))
       (setf (fifth otup) (read-from-string (fifth otup)))
       (doquery 
	ktup ("select k.* from k,s where k.word = s.id and s.lang = ~a and k.val = ~/gdr:stroqa/" from (car dbl))
	(setf (fourth ktup) (read-from-string (fourth ktup)))
	(let ((s (car (db-ask "select * from s where id = ~a" (second ktup)))))
	  (if (and (= (third otup) (third s))
		   (scheme (fourth ktup) (fifth otup)))
	      (push s res))))))))

(defun sql-mut (wlist weq)
  (reduce
   #'(lambda (x y) (format nil "~a or ~a" x y))
   (mapcar #'(lambda (w) (format nil "~a~/gdr:stroqa/" weq w)) wlist)))

(defmethod select-translations ((conn pg::pgcon) word from to fwrd)
  (let ((wlist 
	 (cons 
	  word (unmutate word (lang-mutable (gethash from *languages*))))))
    (db-ask "select p.id, s.id, s.lang, s.part, s.val, s.attr, s.pron, ss.id, ss.lang, ss.part, ss.val, ss.attr, ss.pron, p.comment, p.usuality from p, s, s as ss where p.~a in (select s.id from s where s.lang = ~a and (~a) union select s.id from s, f where s.id = f.word and s.lang = ~a and (~a)) and p.first = s.id and p.second = ss.id and ~a.lang = ~a order by p.usuality" (if fwrd "first" "second") from (sql-mut wlist "s.val=") from (sql-mut wlist "f.val=") (if fwrd "ss" "s") to)))

(defmethod find-translations ((conn pg::pgcon) word to)
  (db-ask "select p.id, s.id, s.lang, s.part, s.val, s.attr, s.pron, ss.id, ss.lang, ss.part, ss.val, ss.attr, ss.pron, p.comment, p.usuality from p, s, s as ss where p.first = ~a and p.first = s.id and p.second = ss.id and ss.lang = ~a" word to))

(defmethod cross-translations ((conn pg::pgcon) word from to via)
  (let ((wlist 
	 (cons 
	  word (unmutate word (lang-mutable (gethash from *languages*))))))
    (db-ask "select distinct on (ss.id) 1, s.id, s.lang, s.part, s.val, s.attr, s.pron, ss.id, ss.lang, ss.part, ss.val, ss.attr, ss.pron, coalesce(p.comment,'')||'|{'||sss.val||'}', 0 from p join p as pp on p.second=pp.first, s, s as ss, s as sss where p.first in (select s.id from s where s.lang = ~a and (~a) union select s.id from s, f where s.id = f.word and s.lang = ~a and (~a)) and p.first = s.id and pp.second = ss.id and ss.lang = ~a and pp.first = sss.id and sss.lang = ~a and ss.lang <> ss.id" from (sql-mut wlist "s.val=") from (sql-mut wlist "f.val=") to via)))

(defun pgenerate-forms (conn w)
  (let ((end 
	 (mapcar
	  #'(lambda (e)
	      (let ((n (append e (list (string-trim "()" (substitute #\Space #\| (fifth e)))))))
		(setf (fifth n) (read-from-string (fifth n)))
		n))
	  (db-ask "select * from e where lang = ~a and part = ~a" 
		  (second w) (third w))))
	(res ()))
    (doquery 
     k ("select * from k where word = ~a" (first w))
     (dolist (e end)
       (if (scheme (read-from-string (fourth k)) (fifth e))
	   (push 
	    `(0 ,(second w) ,(third w)
		,(format nil "~a~a" (third k) (fourth e))
		,(seventh e) "")
	    res))))
    res))

(defmethod find-forms ((conn pg::pgcon) word)
  (let ((w (db-ask "select id, lang, part, val, attr, pron from s where id=~a" 
		   word)))
    (append 
     w
     (db-ask "select f.id, s.lang, s.part, f.val, f.attr, f.pron from f, s where f.word = ~a and f.word = s.id" word)
     (pgenerate-forms conn (car w)))))

(defmethod find-words ((conn pg::pgcon) word from)
  (db-ask "select s.id, s.lang, s.part, s.val, s.attr, s.pron from s where s.val = ~/gdr:stroqa/ and s.lang = ~a" word from))