#| 
   Dictionary import utility.

   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.  

(("слово"
  ("часть речи" ["аттрибуты" "транскрипция"])
  ((("словоформа" ["аттрибуты" "транскрипция"])
    ("словоформа" ["аттрибуты" "транскрипция"]))
   (("корень" "аттрибуты") 
    ("корень" "аттрибуты")))
  (("перевод" ["комментарий"
		     ("пример" "перевод примера")
		     ("пример" "перевод примера")])
   ("перевод" ["комментарий"
		     ("пример" "перевод примера")
		     ("пример" "перевод примера")]))
  (("перевод" ["комментарий"
		     ("пример" "перевод примера")
		     ("пример" "перевод примера")])))

; сменить директорию в Slime: , cd

|#

(defpackage geiriadur-import
   (:use common-lisp))
(in-package geiriadur-import)

(defparameter *orb* (CORBA:ORB_init))

(defun file-to-object (fn)
  (op:string_to_object 
   *orb* (with-open-file (rd fn :direction :input) (read-line rd))))

(defvar *dict* nil)
(defvar *master* nil)
(defvar *from* nil)
(defvar *to* nil)
(defvar *password* nil)
(defvar *once* nil)
(defvar *user* nil)
(defvar *password*)
(defvar *test* t)
(defvar *create* :create)
(defvar *oes* nil)
(defvar *oesto* :append)
(defvar *entry* nil)
(defvar *log* nil)
(defvar *langs* nil)
(defvar *parts* nil)
(defvar *attrs* nil)

(defun connect-to-dictionary ()
  (setf *master* (file-to-object "gweithdy.ior")
	*dict* (file-to-object "geiriadur.ior")))

(defun init ()
  (with-open-file (pr "priodoledd.lisp")
    (setf *langs* (read pr))
    (setf *parts* (read pr))
    (setf *attrs* (read pr)))
  (connect-to-dictionary))

(defun corba-call (fn &rest args)
  (handler-case
      (apply fn args)
    (omg.org/corba:object_not_exist () 
      (progn (connect-to-dictionary) (apply fn args)))
    (omg.org/corba:comm_failure () 
      (progn (connect-to-dictionary) (apply fn args)))
    (omg.org/corba:transient () 
      (progn (connect-to-dictionary) (apply fn args)))))

(defun add-writers-digest (args)
  (append
   args
   (list 
    *user*
    (md5:md5sum-sequence (format nil "~a~a~a" *user* *once* *password*)))))

(defun secure-corba-call (&rest fargus)
  (multiple-value-bind (ret once)
      (handler-case (apply #'corba-call (add-writers-digest fargus))
	(dictionary:nopermission ()
	  (progn
	    (setf *once* (corba-call #'op:once *master* *user*))
	    (apply #'corba-call (add-writers-digest fargus)))))
    (setf *once* once)
    ret))

(defun drop-and-create-word (id lang part word attr pron drop/create use)
  (let ((w (dictionary:word 
	    :id 0 :lang lang :prt part :value word :attr attr :pron pron)))
    (if (null id)
	(if drop/create (secure-corba-call #'op:create *master* :s w t) lang)
	(if drop/create
	    (progn
	      (secure-corba-call #'op:destroy *master* :s id)
	      (secure-corba-call #'op:create *master* :s w t))
	    (if (or use (zerop (length (op:find *dict* id *to*)))) id)))))

(defun ensure-word (lang part word attr pron
		    &key if-exists (if-does-not-exist :create))
  (let* ((words (op:list 
		 *master* :s lang (format nil "^~a$" word) t 
		 (or part 0) (not (null part)) 0 1000))  
	 (len (length words)))
    (cond 
      ((zerop len) 
       (drop-and-create-word 
	nil lang part word attr pron (eq if-does-not-exist :create) nil))
      ((= 1 len)
       (drop-and-create-word 
	(op:id (svref words 0))
	lang part word attr pron 
	(eq if-exists :supersede) (eq if-exists :append)))
      (*log* nil)
      (t 
       (let ((ids))
	 (format t "~a~%" *entry*)
	 (dotimes (i len)
	   (let ((w (svref words i)))
	     (format 
	      t "~a ~a ~a ~a ~a ~a~%" 
	      (op:id w) (op:lang w) (op:prt w) (op:value w) (op:pron w) 
	      (op:attr w))
	     (push (op:id w) ids)))
	 (drop-and-create-word
	  (do ((id (read) (read)))
	      ((member id ids) id))
	  lang part word attr pron 
	  (eq if-exists :supersede) (eq if-exists :append)))))))
	   
(defun create-translation (f first s second comment us)
  (if *test* (format t "~a ~a ~a ~a ~a ~a~%" us f first s second comment)
      (secure-corba-call 
       #'op:pcreate *master* f s
       (if (> 10 s) (format nil "(~a)~@[|(~a)~]" second comment)
	   (format nil "~@[(~a)~]" comment))
       us)))

(defun check-part (part)
  (or
   (loop for i below (array-dimension *parts* 0) 
      thereis (if (or (string= part (aref *parts* i 0))
		      (string= part (aref *parts* i 3))) i))
   (error part)))

(defun check-attr (aaa)
  (map 
   nil
   #'(lambda (a)
       (if (not 
	    (or (char= #\( (schar a 0))
		(member 
		 a *attrs* :test #'string= :key #'(lambda (a) (svref a 0)))))
	   (error a)))
   (cl-ppcre:split "[ ]+|[|]+" aaa)))

(defun import-entry (entry)
  (destructuring-bind (word (part &optional attr pron) fruits . trans) entry
    (let ((*entry* entry) (prt (check-part part)))
      (check-attr attr)
      (let ((w 
	     (if (consp word) (car word)
		 (ensure-word 
		  *from* prt word attr pron 
		  :if-does-not-exist (if *test* nil *create*) 
		  :if-exists
		  (if (eq *oes* :supersede) 
		      (if *test* nil :supersede) *oes*)))))
	(if (null w)
	    (format (or *log* *error-output*) "~s~%" *entry*)
	    (loop for u from (if (second trans) 10 0) by 10 
		 for group in trans do
		 (loop for v from 1
		      for tran in group do
		      (let ((us (if (consp word) (cadr word) (+ u (min v 9)))))
			(destructuring-bind (second &optional comment examples)
			    tran
			  (if (position #\Space second)
			      (create-translation w word *to* second comment us)
			      (let ((s (ensure-word 
					*to* nil second nil nil
					:if-does-not-exist nil
					:if-exists 
					(if (eq *oesto* :supersede) 
					    nil *oesto*))))
				(if (null s)
				    (format 
				     *log* "~s~%" 
				     `((,w ,us ,word ,prt) (nil) () (,tran)))
				    (handler-case
					(create-translation 
					 w word s second comment us)
				      (dictionary:oes ()
					(format 
					 (or *log* *error-output*) 
					 "~s~%" 
					 `((,w ,us ,word ,prt e) (nil) () 
					   (,tran)))))))))))))))))

(defun import-file (user password from to log file &key (start 0) (test t))
  (assert (not (equal log file)))
  (with-open-file (lg (or log file) :direction (if log :output :input) :if-exists (if log :supersede) :if-does-not-exist (if log :create))
    (let ((*from* from) (*to* to) (*user* user) (*password* password) 
	  (*test* test) (*log* (if log lg)))
      (with-open-file (f file)
	(let* ((entries (read f))
	       (len (length entries)))
	  (loop for n from (1+ start)
	     for e in (subseq entries start) do
	       (progn
		 (import-entry e)
		 (format t "~a/~a~%" n len)
		 (finish-output))))))))