;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;  Interface
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




(defun pluralize-region (start end)
;  "Pluralize marked region."
  (interactive "r")
  (save-excursion 
  (open-database)
  (goto-char start)
  (let ((word (get-next-word)) user-command)
    (while (< (point) end)
      (if (get-options word) 	
	  (progn (show-choices word (get-options word))
		 (message "pluralize command: ")
		 (setq user-command (downcase (read-char)))
;		 (setq user-command (read-input "pluralize command:")) 
		 (if (equal ?s user-command)
		     (progn  (forward-char 1) 
			    (setq word (get-next-word))) 
		       (if (equal ?r user-command)
			   (progn (kill-word -1)
				  (insert (type-replacement word))
				  (forward-char 1)	 
				  (setq word (get-next-word))) 
			 (if (and (>= ?9 user-command)
				   (<= ?0 user-command)) 
			     (progn (kill-word -1)
				  (insert (elt (get-options word) 
					       (- user-command ?0)))
		                   (forward-char 1)	 
				  (setq word (get-next-word))))))
		 (delete-other-windows))
	(progn (forward-char 1) 
	       (setq word (get-next-word)))))
    (kill-buffer "morpho-db-test.lisp")
    (message "region pluralized")
)))



(defun open-database () 
  (save-excursion 
    (find-file "morpho-db-test.lisp")
    (bury-buffer)))




(defun get-next-word ()	
  (let ((word (downcase
	       (buffer-substring (point)
				 (progn (forward-word 1) (point))))))  
    word))

 

(defun get-options (word) 
  (save-excursion 
    (get-pluralize-options word)))




(defun type-replacement (word)
  "Prompt the user to type a replacement for the current word." 
  (read-input (concat 
		 "Type in a replacement for \'" word "\':")))



(defun show-choices (word message)
  ;;if there is only one window on the screen, make the 
  ;;messages window be small.  otherwise just use the other window
  (let* ((selwin (selected-window))
	 (resize (eq selwin (next-window)))
	 (buf (get-buffer-create "*choices*"))
	 w)
    (setq w (display-buffer buf))
    (buffer-flush-undo buf)
    (if resize
	(unwind-protect
	    (progn
	      (select-window w)
	      (enlarge-window (- 6 (window-height w))))
	  (select-window selwin)))
    (save-excursion
      (set-buffer buf)
      (bury-buffer buf)
      (set-window-point w (point-min))
      (set-window-start w (point-min))
      (erase-buffer)
      (insert (concat "Please choose one of the following options for \'" 
		      word "\' \n"))
      (insert
       "S skip; DIGIT select; R replace \n")
      (cond ((not (null message))
	     (let ((i 0))
	       (while (< i 3)
		 (let ((j 0))
		   (while (< j 3)
		     (let* ((n (+ (* j 3) i))
			    (choice (nth n message)))
		       (cond (choice
		      (let ((str (format "%d %s" n choice)))
				(insert str)
				(insert-char ?  (- 20 (length str)))))))
		     (setq j (+ j 1))))
		 (insert "\n")
		 (setq i (+ i 1)))))))))

(show-choices "this" '("these"))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;  Morphology 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;This program uses "morpho-db-test.lisp", a small 
;;database that contains the words in of "test".




(defun ignore-ending-spaces (string) 
  (let ((start 0) (end (- (length string) 1)))  
    (while (or (equal (elt string start)
		      (elt " " 0))
	       (equal (elt string start)
		      (elt "\n" 0))) 
      (setq start (+ 1 start)))
    (while (or (equal (elt string end)
		      (elt " " 0))
	       (equal (elt string end)
		      (elt "\n" 0))) 
      (setq end (- end 1)))
    (substring string start (+ 1 end))))



(defun get-morphological-info (word)
  (save-excursion 
    (set-buffer "morpho-db-test.lisp")
    (goto-char (point-min))
    (let (info 
	  (line (read (get-buffer "morpho-db-test.lisp"))))
      (while (not (equal '(eof) line))
	(if (equal (ignore-ending-spaces word) 
                   (ignore-ending-spaces (car line))) 
	    (if (equal (elt line 1) "") 
		(setq info (cons (cdr (cdr line)) info))
	      (setq info (cons (cdr line) info))))
	(setq line (read (get-buffer "morpho-db-test.lisp")))) 
      info)))

;(get-morphological-info "is")
;=> (("be" "V 3sg PRES aux"))



(defun member (element list)
  (if (null list) nil 
      (if (equal element (car list)) t 
          (member element (cdr list)))))



(defun remove-duplicates-aux (list set)
  (cond ((null list) set)
	((member (car list) set)  
	 (remove-duplicates-aux (cdr list) set))
	(t (remove-duplicates-aux (cdr list) 
			      (cons (car list) set)))))
	 
(defun remove-duplicates (list) 
  (remove-duplicates-aux list nil))



(defun plural (string) 
  (cond   
    ((equal string "N 3sg") "N 3pl")
    ((equal string "V 3sg PRES aux") "V PRES pl")
    ((equal string "V 3sg PRES") "V INF")
    ((equal string "Pron 1sg nom") "Pron 1pl nom")
    ((equal string "Det sg") "Det pl")))




(defun changes (l) 
  (if (null l) nil 
      (if (plural (elt (car l) 1)) 
	  (cons (cons (car (car l)) 
                    (list (plural (elt (car l) 1))))
              (changes (cdr l)))
        (changes (cdr l)))))

;(changes '(("be" "V 3sg PRES")))
;=> (("be" "V INF"))



(defun get-inflected-form (item)
  (save-excursion 
  (set-buffer "morpho-db-test.lisp")
  (goto-char (point-min))
  (let (form 
	(line (read (get-buffer "morpho-db-test.lisp"))))
    (while (not (equal '(eof) line)) 
      (if (equal (cdr line) item) 
	  (setq form (ignore-ending-spaces (car line))) 
	(if (equal (cdr (cdr line)) item) 
	    (setq form (ignore-ending-spaces (car line)))))
      (setq line (read (get-buffer "morpho-db-test.lisp"))))
    form)))

;(get-inflected-form '("be" "V PRES pl"))
;=> "are"



(defun get-pluralize-options (word) 
  (remove-duplicates 
   (mapcar 'get-inflected-form 
           (changes (get-morphological-info word)))))


;(get-pluralize-options "percent")
;=> ("are")