;;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Tue Jul 18 10:31:25 2006 +0530 <enometh@net.meer>
;;;   Time-stamp: <06/07/25 14:13:43 madhu>
;;;   Bugs-To: <enometh@net.meer>
;;;   Status: Experimental. DO NOT REDISTRIBUTE
;;;
;;;   Copyright (C) 2006 Madhu. All Rights Reserved.
;;;   $Id: tag.lisp,v 3.4 2006/07/25 08:45:53 madhu Exp $
;;;
(defpackage "SKT-TAGGER" (:use "CL"))
(in-package "SKT-TAGGER")

(defpackage "SKTCHAR"
  (:use)
  (:export
   "a" "aa" "i" "ii" "u" "uu" ".r" ".r.r" ".l" ".l.l" ; simple-vowels
   "e" "ai" "o" "au"				      ; diphthongs
   "k" "kh" "g" "gh" "\"n"			      ; "ka.n.thya"
   "c" "ch" "j" "jh"  "~n"			      ; "taalavya"
   ".t" ".th" ".d" ".dh" ".n"			      ; "murdhnya"
   "t" "th" "d" "dh" "n"			      ; "dantya"
   "p" "ph" "b" "bh" "m"			      ; "o.s.tya"
   "y" "r" "l" "v"
   "\"s" ".s" "s" "h"
   ".h" ".m" ".a" ".o"
   " "))

#+cmu
(let ((pkg (find-package "SKTCHAR")))
  (setf (ext:package-definition-lock pkg) t
	(ext:package-lock pkg) t))



;;;; ----------------------------------------------------------------------
;;;;
;;;; SKTCHAR PACKAGE IMPL.
;;;;

;;;
;;;
;;;
(defvar *sktchar-table*
  '( ;; vowels
    ("a" 	:simple-vowel :short :vowel)
    ("aa"	:simple-vowel :long :vowel)
    ("i"	:simple-vowel :short :vowel)
    ("ii"	:simple-vowel :long :vowel)
    ("u"	:simple-vowel :short :vowel)
    ("uu"	:simple-vowel :long :vowel)
    (".r"	:simple-vowel :short :vowel)
    (".r.r"	:simple-vowel :long :vowel)
    (".l"	:simple-vowel :short :vowel)
    (".l.l"	:simple-vowel :long :vowel)
    ("e"	:diphthong :vowel)
    ("ai"	:diphthong :vowel)
    ("o"	:diphthong :vowel)
    ("au"	:diphthong :vowel)
    ;; consonants
    ("k"	:guttural :hard :non-aspirate :mute :consonant)
    ("kh"	:guttural :hard :aspirate :mute :consonant)
    ("g"	:guttural :soft :non-aspirate :mute :consonant)
    ("gh"	:guttural :soft :aspirate :mute :consonant)
    ("\"n"	:guttural :soft :nasal :mute :consonant)
    ("c"	:palatal :hard :non-aspirate :mute :consonant)
    ("ch"	:palatal :hard :aspirate :mute :consonant)
    ("j"	:palatal :soft :non-aspirate :mute :consonant)
    ("jh" 	:palatal :soft :aspirate :mute :consonant)
    ("~n" 	:palatal :soft :nasal :mute :consonant)
    (".t" 	:cerebral :hard :non-aspirate :mute :consonant)
    (".th"	:cerebral :hard :aspirate :mute :consonant)
    (".d"	:cerebral :soft :non-aspirate :mute :consonant)
    (".dh" 	:cerebral :soft :aspirate :mute :consonant)
    (".n"	:cerebral :soft :nasal :mute :consonant)
    ("t"	:dental :hard :non-aspirate :mute :consonant)
    ("th"	:dental :hard :aspirate :mute :consonant)
    ("d"	:dental :soft :non-aspirate :mute :consonant)
    ("dh"	:dental :soft :aspirate :mute :consonant)
    ("n"	:dental :soft :nasal :mute :consonant)
    ("p"	:labial :hard :non-aspirate :mute :consonant)
    ("ph"	:labial :hard :aspirate :mute :consonant)
    ("b"	:labial :soft :non-aspirate :mute :consonant)
    ("bh"	:labial :soft :aspirate :mute :consonant)
    ("m"	:labial :soft :nasal :mute :consonant)
    ("y"	:palatal :soft :semi-vowel :sonorant :consonant)
    ("r"	:cerebral :soft :semi-vowel :sonorant :consonant)
    ("l"	:dental :soft :semi-vowel :sonorant :consonant)
    ("v"	:labial :soft :semi-vowel :sonorant :consonant)
    ("\"s"	:palatal :hard :sibilant :consonant)
    (".s"	:cerebral :hard :sibilant :consonant)
    ("s"	:dental :hard :sibilant :consonant)
    ("h"	:guttural :aspirate :semi-vowel :consonant)
    ;; misc
    (".h"	:visarga)
    ;; double-dot -- standing for final s or r
    (".m"	:anusvara)
    ;; dot above vowel. standing for final m or for any of the five
    ;; nasals followed by the first four mutes of its own class
    (".a"	:avagraha)
    (".o"	:om)
    ;; additions
    (" "	:space)))

(defvar *sktchar-trie*
    (let ((trie (trie:make-trie)))
 (loop for (code . properties) in *sktchar-table*
	    for sym = (find-symbol code "SKTCHAR")
	    do (assert sym)
	    (setf (trie:gettrie code trie) sym)
	    (loop for property in properties do
		  (setf (get sym property) t)))
      trie))


#||
(find-package "SKTCHAR")
(use-package "SKTCHAR")
(progn (delete-package "SKT-TAGGER") (delete-package "SKTCHAR"))
||#


;;; ----------------------------------------------------------------------
;;;
;;; walks string and trie, collects values from tries as output tokens.
;;;
(defun segment-sentence (trie string &optional (start 0)
			 (end (length string)) output
			 fail)
  "Internal.  FAIL can be NIL (in which case it is ignored) or a
function of 2 arguments: (tok revtoks), which returns T if
parsing ought to fail on that branch (in which case tok is
rejected)"
  (declare (special *solutions*))
  (let ((p start) (sub-trie trie) resumptions)
    (tagbody
     loop (assert (< p end) nil "Start index ~A > end index ~A" start end)
       #+nil(warn "string=~a p=~a" (subseq string start end) p)
       (setq sub-trie (trie::trie-descend sub-trie  (aref string p)))
       (cond (sub-trie
	      (cond ((car sub-trie)
		     (let ((parsed-word (car sub-trie)
			     #+nil(subseq string start (1+ p))))
		       #+nil
		       (warn "matched ~a" (subseq string start (1+ p)))
		       (unless (and fail (funcall fail parsed-word output))
			 (cond ((= (1+ p) end)
				(let ((soln (reverse (cons parsed-word
							   output))))
				  #+debug-segmenter
				  (warn "SOLUTION: ~A" soln)
				  (push soln *solutions*)
				  (go cont)))
			       (t (cond ((cdr sub-trie) ; choice-point
					 (push (list (cons parsed-word output)
						     (1+ p) end)
					       resumptions)
					 (incf p) (go loop))
					(t (push parsed-word output)
					   (setq sub-trie trie start (1+ p))
					   (incf p) (go loop))))))))
		    (t (cond ((= (1+ p) end) ; fail at end-of-input
			      (go cont))
			     (t (incf p) (go loop))))))
	     (t (go cont)))		; fail at end-of-trie
       ;; TODO maybe replace call to segment-sentence to a jump within
       ;; tagbody and remove special *solutions*
     cont (loop for (output1 start1 end1) in resumptions
		do (segment-sentence trie string start1 end1 output1 fail)))))


;;;
;;;
(defun single-match-failer (tok revtoks)
  (declare (special *solutions*) (ignorable tok revtoks))
  (cond (*solutions*
	 #+debug-segmenter-failures
	 (warn "SMF: Rejecting ~A." (reverse (cons tok revtoks)))
	 T)))

(defun all-purpose-failer (tok revtoks)
  (cond ((get tok :vowel)
	 (cond
	   ((and (get tok :short)
		 (eq tok (car revtoks)))
	    #+debug-segmenter-failures
	    (warn "APF: failing double ~A." (list tok revtoks))
	    T)))
	((get tok :anusvara)
	 (cond
	   ((not (get (car revtoks) :vowel))
	    #+debug-segmenter-failures
	    (warn "APF: failing anusvara ~A without vowel."
		  (list tok revtoks))
	    T)))))
;;;
;;;
(defun parse-skt (string)
  "Parse ascii STRING into a list of SKTCHAR symbols."
  (let ((*solutions*))
    (declare (special *solutions*))
    (segment-sentence  *sktchar-trie* string
		       0 (length string) nil
		       #+nil
		       'all-purpose-failer
		       (lambda (tok revtoks)
			 (or (all-purpose-failer tok revtoks)
			     (single-match-failer tok revtoks))))
    (setq *solutions* (nreverse *solutions*))
    (values (car *solutions*) (cdr *solutions*))))

#||
(parse-skt "ka.n.thya")			; guttural
(parse-skt "taalavya") 			; palatal
(parse-skt "murdhnya")			; cerebral
(parse-skt "dantya")			; dental
(parse-skt "o.s.tya")			; labial
(parse-skt "a.mo.s.tya")
(parse-skt "lak.mos")
(parse-skt "va.h")
(get 'sktchar:|.m| :anusvara)
(apply 'concatenate 'string
       (mapcar (lambda (x) (symbol-name x))
	       (parse-skt "bhvaadi")))
||#


;;;; ---------------------------------------------------------------------
;;;;
;;;; EXTERNAL SANDHI IMPL.
;;;;

;;;
;;;
;;;
(defun match-external-visarga-sandhi-rule (final initial preceeding-final)
  "Internal. 27 and 54."
  (ecase final ((sktchar:|r| sktchar:|.h|)))
  #+NIL(assert (get preceeding-final :vowel)) ; XXX
  ;; when final visarga: is preceeded by any vowel and followed by a
  ;; hard consonant: 15.2
  (cond ((and (get initial :consonant)		 (get initial :hard))
	 (ecase initial
	   ;; remains unchanged before...
	   ((sktchar:|k| sktchar:|kh| sktchar:|p| sktchar:|ph|
		     sktchar:|"s| sktchar:|.s| sktchar:|s|)
	    (if (eq final 'sktchar:|.h|) ; XXX pretty. don't return FINAL
		'(sktchar:|.h| sktchar:| |)
		'(sktchar:|.h|)))
	   ;; NOTE final visarga was unchanged. when followed by a
	   ;; sibilant "s, .s or s, it is optionally changed to the
	   ;; sibilant. TODO
	   ((sktchar:|c| sktchar:|ch|)		  'sktchar:|"s|)
	   ((sktchar:|.t| sktchar:|.th|)	  'sktchar:|.s|)
	   ((sktchar:|t| sktchar:|th|)		  'sktchar:|s|)))
	;; ========================================================-
	;; exception for final r: Visarga standing for final r even
	;; when preceeded by a or aa and followed by a vowel or soft
	;; consonant is changed to r. 54.
	;;
	;; When visarga is changed to r and is followed by r the first
	;; r is dropped and the preceeding vowel, if short, is
	;; lengthened. 54.2
	;;
	((and (eq final 'sktchar:|r|)
	      (or (get initial :vowel)
		  (and (get initial :consonant)
		       (get initial :soft))))
	 (cond ((eq initial 'sktchar:|r|) ; 54.2 visarga changed to r
		(values :zero nil
			(if (and #+NIL(get preceeding-final :vowel)
				 (get preceeding-final :short))
			    (ecase preceeding-final
			      (sktchar:|a| 'sktchar:|aa|)
			      (sktchar:|i| 'sktchar:|ii|)
			      (sktchar:|u| 'sktchar:|uu|)))))
	       (t 'sktchar:|r|)))
	;; -=========================================================
	;; When final visarga is preceeded by any vowel except a or
	;; aa, followed by vowel or soft consonant, is changed to
	;; r. 26.
	((and (not (case preceeding-final ((sktchar:|a| sktchar:|aa|) T)))
	      (or (and (get initial :consonant)
		       (get initial :soft))
		  (get initial :vowel)))
	 (cond ((eq initial 'sktchar:|r|) ; 54.2 visarga changed to r
		(values :zero nil
			(if (and #+NIL(get preceeding-final :vowel)
				 (get preceeding-final :short))
			    (ecase preceeding-final
			      (sktchar:|a| 'sktchar:|aa|)
			      (sktchar:|i| 'sktchar:|ii|)
			      (sktchar:|u| 'sktchar:|uu|)))))
	       (t 'sktchar:|r|)))
	;; when preceeded by aa and followed by a soft consonant, it
	;; is dropped.
	((and (eq preceeding-final 'sktchar:|aa|)
	      (or (and (get initial :consonant)
		       (get initial :soft))
		  (get initial :vowel)))
	 :zero)
	;; when preceeded by a
	((eq preceeding-final 'sktchar:|a|)
	 (cond ((and (get initial :consonant)
		     (get initial :soft))
		;; and followed by a soft consonant, a.h becomes o
		(values 'sktchar:|o| nil :zero))
	       ;; and followed by any vowel except a, it is
	       ;; dropped. when followed by a, a.h becomes a and the
	       ;; following a is elided.
	       ((get initial :vowel)
		(if (eq initial 'sktchar:|a|)
		    (values 'sktchar:|o| 'sktchar:|.a| :zero)
		    :zero))))))

;;; 31.
(defun match-external-vowel-sandhi-rule  (final initial preceeding-final)
  "Internal."
  (declare (ignore preceeding-final))
  (assert (get final :vowel))
  (assert (get initial :vowel))
  (ecase final
    ((sktchar:|a| sktchar:|aa|)
     (ecase initial
       ((sktchar:|a| sktchar:|aa|) (values 'sktchar:|aa| :zero))
       ((sktchar:|i| sktchar:|ii|) (values 'sktchar:|e| :zero))
       ((sktchar:|u| sktchar:|uu|) (values 'sktchar:|o| :zero))
       ((sktchar:|.r|  sktchar:|.r.r|) (values 'sktchar:|a| 'sktchar:|r|))
       (sktchar:|e| (values 'sktchar:|ai| :zero))
       (sktchar:|o| (values 'sktchar:|au| :zero))
       (sktchar:|ai| (values 'sktchar:|ai| :zero))
       (sktchar:|au| (values 'sktchar:|au| :zero))))
    ;; i and ii followed by a dissimilar vowel is changed to y.
    ((sktchar:|i| sktchar:|ii|)
     (ecase initial
       ((sktchar:|a| sktchar:|aa| sktchar:|u| sktchar:|uu| sktchar:|e|
		 sktchar:|o| sktchar:|ai| sktchar:|au|
		 sktchar:|.r| sktchar:|.l|) ; XXX
	(values 'sktchar:|y|))
       ((sktchar:|i| sktchar:|ii|) (values 'sktchar:|ii| :zero))))
    ;; u and uu followed by a dissimilar vowel is changed to v.
    ((sktchar:|u| sktchar:|uu|)
     (ecase initial
       ((sktchar:|u| sktchar:|uu|) (values 'sktchar:|uu| :zero))
       ((sktchar:|a| sktchar:|aa| sktchar:|i| sktchar:|ii| sktchar:|e|
		 sktchar:|o| sktchar:|ai| sktchar:|au|
		 sktchar:|.r| sktchar:|.l|) ; XXX
	(values 'sktchar:|v|))))
    ;; .r and .r.r followed by a dissimilar vowel is changed to r.
    ((sktchar:|.r| sktchar:|.r.r|)
     (ecase initial
       ((sktchar:|.r|  sktchar:|.r.r|) (values 'sktchar:|.r.r| :zero))
       ((sktchar:|a| sktchar:|aa| sktchar:|i| sktchar:|ii|
		 sktchar:|u| sktchar:|uu| sktchar:|e|
		 sktchar:|o| sktchar:|ai| sktchar:|au|
		 sktchar:|.r| sktchar:|.l|) ; XXX
	(values 'sktchar:|r|))))
    ;; e and o followed by any vowel except a are changed to ay and
    ;; av. when followed by a, they remain unchanged while the a is
    ;; elided.
    ((sktchar:|e| sktchar:|o|)
     (case initial
       (sktchar:|a| (values final 'sktchar:|.a|))
       (otherwise (ecase final		; XXX
		    (sktchar:|e|  '(sktchar:|a| sktchar:|y|))
		    (sktchar:|o|  '(sktchar:|a| sktchar:|y|))))))
    ;; before any vowel except a, ay and av may optionally drop the y
    ;; and v. TODO
    ;;
    ;; ai and au followed by any vowel are changed to aay and aav but
    ;; aay and aav may optionally drop the y and v. TODO
    ;;;
    (sktchar:|ai| '(sktchar:|aa| sktchar:|y|))
    (sktchar:|au| '(sktchar:|aa| sktchar:|v|))))

(defun match-external-n-sandhi-rule (final initial preceeding)
  "Internal."
  (assert (eq final 'sktchar::|n|))
  ;; final n preceeded by a short vowel and followed by any
  ;; vowel is doubled. 87.1
  (cond ((and (and (get preceeding :vowel)
		   (get preceeding :short))
	      (get initial :vowel))
	'(sktchar:|n| sktchar:|n|))
	(t (case initial 	;; 87.2:
	     ((sktchar:|c| sktchar:|ch|) '(sktchar:|.m| sktchar:|"s|))
	     ((sktchar:|.t| sktchar:|.th|) '(sktchar:|.m| sktchar:|.s|))
	     ((sktchar:|t| sktchar:|th|) '(sktchar:|.m| sktchar:|s|))
	     ;; n followed by l is changed to nasalized ~m.l. 88.5
	     ;; TODO sktchar:|~m|
	     (sktchar:|l| '(sktchar:|.n| sktchar:|l|))))))


(defun match-further-or-return (final initial preceeding-final)
  "Internal."
  (multiple-value-bind (replacement next prev)
      (match-external-sandhi-rule final initial preceeding-final)
    (cond ((null replacement) (assert (null next)) (assert (null prev))
	   (values final initial preceeding-final))
	  (t (values replacement next prev)))))

(defun match-external-dpcl-sandhi-rule (final initial preceeding-final)
  "Internal."
  ;; any dental coming in contact with a palatal is changed to the
  ;; corresponding palatal. 88.1
  (let (dental palatal cerebral)
    (cond ((or (and (get initial :dental) (get final :palatal)
		    (setq dental initial palatal final))
	       (and (get initial :palatal) (get final :dental)
		    (setq dental final palatal initial)))
	   (let ((corresponding-palatal
		  (ecase dental
		    (sktchar:|t| 'sktchar:|c|)
		    (sktchar:|th| 'sktchar:|ch|)
		    (sktchar:|d| 'sktchar:|j|)
		    (sktchar:|dh| 'sktchar:|bh|)
		    (sktchar:|n| 'sktchar:|~n|)
		    (sktchar:|l| 'sktchar:|y|)
		    (sktchar:|s| 'sktchar:|"s|))))
	     (match-further-or-return
		  (if (eq dental final) corresponding-palatal final)
		  (if (eq dental final) initial corresponding-palatal)
		  preceeding-final)))
	  ;;
	  ;; initial "s preceeded by any of the first four letters of
	  ;; a class is optionally changed to ch. 88.2. TODO
	  ;;
	  ;; any dental coming in contact with a cerebral is changed
	  ;; to the corresponding cerebral. 88.3
	  ;;
	  ((and (or (and (get initial :dental) (get final :cerebral)
			 (setq dental initial cerebral final))
		    (and (get initial :cerebral) (get final :dental)
			 (setq dental final cerebral initial)))
		;; the preceeding rule does not apply when a dental is
		;; followed by .s. 88.4
		(not (and (eq dental final) (eq initial 'sktchar:|.s|))))
	   (let ((corresponding-cerebral
		  (ecase dental
		    (sktchar:|t| 'sktchar:|.t|)
		    (sktchar:|th| 'sktchar:|.th|)
		    (sktchar:|d| 'sktchar:|.d|)
		    (sktchar:|dh| 'sktchar:|.dh|)
		    (sktchar:|n| 'sktchar:|.n|)
		    (sktchar:|l| 'sktchar:|r|)
		    (sktchar:|s| 'sktchar:|.s|))))
	     (if (eq dental final)
		 (match-further-or-return corresponding-cerebral
					     initial preceeding-final) ;XXX
		 (match-further-or-return final corresponding-cerebral
					     preceeding-final))))
	  ;;
	  ;; any dental followed by a l is changed to l. 88.4
	  ;;
	  ((and (get final :dental) (eq initial 'sktchar:|l|))
	   initial))))

;;
(defun match-external-consonant-sandhi-rule  (final initial preceeding-final)
  "Internal."
  (declare (ignore preceeding-final))
  (assert (get final :consonant))
  ;; a final hard consonant becomes soft before a vowel or a soft
  ;; consonant. 72.4.
  (cond ((and (get final :hard)
	      (or (get initial :vowel)
		  (and (get initial :consonant)
		       (get initial :soft))))
	 (case final; madhu 060725 ecase does not handle s
	   (sktchar:|k| 'sktchar:|g|)
	   (sktchar:|kh| 'sktchar:|gh|)
	   (sktchar:|c| 'sktchar:|j|)
	   (sktchar:|ch| 'sktchar:|jh|)
	   (sktchar:|.t| 'sktchar:|.d|)
	   (sktchar:|.th| 'sktchar:|.dh|)
	   (sktchar:|t| 'sktchar:|d|)
	   (sktchar:|th| 'sktchar:|dh|)
	   (sktchar:|p| 'sktchar:|b|)
	   (sktchar:|ph| 'sktchar:|bh|)))
	;; a final soft consonant becomes hard before a hard
	;; consonant. 72.6
	((and (get final :soft)
	      (get initial :hard))
	 (case final ;; ; madhu 060722 ecase does not handle .n
	   (sktchar:|g| 'sktchar:|k|)
	   (sktchar:|gh| 'sktchar:|kh|)
	   (sktchar:|j| 'sktchar:|c|)
	   (sktchar:|jh| 'sktchar:|ch|)
	   (sktchar:|.d| 'sktchar:|.t|)
	   (sktchar:|.dh| 'sktchar:|.th|)
	   (sktchar:|d| 'sktchar:|t|)
	   (sktchar:|dh| 'sktchar:|th|)
	   (sktchar:|b| 'sktchar:|p|)
	   (sktchar:|bh| 'sktchar:|ph|)))))


(defun match-external-sandhi-rule (final initial preceeding-final)
  "Internal. Returns :zero indicating no replacement, or the
replacement for FINAL. First additional value indicates a
replacement for INITIAL. Second additional value indicates a
replacement for PRECEEDING-FINAL. Returns NIL if no known rule
matches."
  (cond
    ;; final m when followed by a consonant is changed to anusvara.
    ((and (eq final 'sktchar:|m|)
	  (get initial :consonant))
     'sktchar:|.m|)			; 15.1
    ((eq final 'sktchar:|n|)
     (match-external-n-sandhi-rule final initial preceeding-final))
    ((or (eq final 'sktchar:|.h|)
	 (eq final 'sktchar:|r|))	; final visarga
     (match-external-visarga-sandhi-rule final initial preceeding-final))
    ((and (get final :vowel) (get initial :vowel))
     (match-external-vowel-sandhi-rule
      final initial preceeding-final))
    (t (multiple-value-bind (repl next prev)
	   (match-external-dpcl-sandhi-rule final initial preceeding-final)
	 (cond (repl (values repl next prev))
	       ((get final :consonant)
		(match-external-consonant-sandhi-rule
		 final initial preceeding-final)))))))


(defun append-applying-external-sandhi-2 (final-word initial-word)
  (declare (optimize (debug 2) (safety 3)))
  (loop with initial = (car initial-word)
	for x on final-word
	for c = nil then preceeding-letter
	for (preceeding-letter final . rest) = x
	unless (endp rest) if c collect it into ret end
	else collect c into ret and return
	(multiple-value-bind (replacement next prev)
	    (match-external-sandhi-rule final initial preceeding-letter)
	  (cond ((null replacement)
		 (warn "Sandhi of ~A + ~A may have failed." final initial)
		 (assert (null next)) (assert (null prev))
		 (append ret (list preceeding-letter final 'sktchar:| |)
			initial-word))
		(t (append ret
			  (cond ((null prev) (list preceeding-letter))
				((eq prev :zero) nil)
				((consp prev) prev)
				(t (list prev)))
			  (cond ((eq replacement :zero)
				 (list 'sktchar:| |)) ;XXX
				((consp replacement) replacement)
				(t (list replacement)))
			  (cond ((null next) initial-word)
				((eq next :zero) (cdr initial-word))
				((consp next) (append next (cdr initial-word)))
				(t (cons next (cdr initial-word))))))))))


(defun test-sandhi (x y &rest rest)
  "Internal. Testing. Syntax:
  TEST-SANDHI STRING1 STRING2 [ STRING3 ... ] [ := RESULT ]"
  (cond ((endp rest)
	 (let ((ret (append-applying-external-sandhi-2
		     (parse-skt x) (parse-skt y))))
	   (apply 'concatenate 'string (mapcar 'symbol-name ret))))
	(t (let ((member (member ':= rest :test #'eq)) result)
	     (when member
	       (setq result (cadr member))
	       (assert (endp (cddr member)))
	       (setq rest (nbutlast rest 2)))
	     (push y rest) (push x rest)
	     (let ((ret (reduce (lambda (a b) (test-sandhi a b)) rest)))
	       (when result (assert (string= ret result)))
	       ret)))))

#||
(match-external-sandhi-rule 'sktchar:|.h| 'sktchar:|j| 'sktchar:|a|)
(match-external-sandhi-rule 'sktchar:|.h| 'sktchar:|s| 'sktchar:|a|)
;;; 31.1
(test-sandhi "muninaa" "ataami" := "muninaataami")
(test-sandhi "namasi" "ii\"svaram"  := "namasii\"svaram")
(test-sandhi "kintu" "uvaca" := "kintuuvaca")
(test-sandhi "kart.r" ".rju.h" := "kart.r.rju.h")
;;; 31.2
(test-sandhi "namatha" "ii\"svaram" := "namathe\"svaram")
(test-sandhi "munina" ".r.si.h" :=  "muninar.si.h")
(test-sandhi "ti.s.thatha" "eva" := "ti.s.thathaiva")
(test-sandhi "khaadatha" "odanam" := "khaadathaudanam")
(test-sandhi "indra.h" "ca" "eraavata.h" "ca" := "indra\"scairaavata\"sca")
(test-sandhi "pa\"syatha" "audham" "pasyathaudham")
(test-sandhi "dhavati" "a\"sva.h" := "dhavatya\"sva.h")
(test-sandhi "nanu" "eva" := "nanveva")
;;; 31.3
(test-sandhi "kart.r" "iti" := "kartriti")
(test-sandhi "munave" "anna.m" "yacchaami" := "munave.anna.m yacchaami")
(test-sandhi "prabho" "adhunaa" := "prabho.adhunaa")
#+nil
(trace match-external-sandhi-rule
       match-external-consonant-sandhi-rule
       match-external-dpcl-sandhi-rule
       match-external-vowel-sandhi-rule
       match-external-visarga-sandhi-rule
       match-external-n-sandhi-rule)
(untrace)
(test-sandhi "kave" "icchasi" )		; XXX
(test-sandhi "gure" "iti" )		; XXX
;;;
;;; 72.4
(test-sandhi "n.rpaat" "alabhat" := "n.rpaadalabhat")
(test-sandhi "gramaat" "gacchaami" := "gramaadgacchaami")
;;;  72.6
(test-sandhi "suh.rd" "su" := "suh.rtsu")
(test-sandhi "etad" "patati" := "etatpatati")
;;; 87.1
(test-sandhi "prahasan" "aagacchati")
(test-sandhi "balin" "ajaya.h" := "balinnajaya.h")
;;; 87.2
(test-sandhi "taan" "ca" := "taa.m\"sca")
(test-sandhi "dhiimaan" ".tiikaa.m" "pa.thati" :=
	     "dhiimaa.m.s.tiikaa.m pa.thati")
(test-sandhi "ariin" "taa.dayati")
;;; 88.1
(test-sandhi "suh.rt" "calati"  := "suh.rccalati")
(test-sandhi "aanayat" "jalam" := "aanayajjalam")
(test-sandhi "tat" "\"srutvaa")		; XXX
;;; 88.3
(test-sandhi "apibat" ".ta.nkam" := "apiba.t.ta.nkam")
(test-sandhi "pu.s" "ta" := "pu.s.ta")
(test-sandhi "abhak.sayat" ".sa.davam")	; fail
(test-sandhi "etad" "labhate")
(test-sandhi "v.rk.saan" "lumpati")

;;; 15
(test-sandhi "n.rpa.h" "jayati")
(test-sandhi "raamam" "viiram" "bodhaama.h" := "raama.mviira.mbodhaama.h")
(test-sandhi "putra.h" "khanati" := "putra.h khanati")
(test-sandhi "janaa.h" "patanti" := "janaa.h patanti")
(test-sandhi "baala.h" "sarati" := "baala.h sarati")
(test-sandhi "janaa.h" "calanti" := "janaa\"scalanti")
(test-sandhi "pa.thata.h" ".tiikaam" := "pa.thata.s.tiikaam")
(test-sandhi "putra.h" "tarati" := "putrastarati")
(test-sandhi "baalaa.h" "dhaavanti" := "baalaa dhaavanti")
(test-sandhi "janaa.h" "a.tanti" := "janaa a.tanti")
(test-sandhi "putra.h" "dhaavati" := "putrodhaavati")
(test-sandhi "dhaavata.h" "aakulau" := "dhaavata aakulau")
(test-sandhi "dhaavata.h" "a\"svau" := "dhaavato.a\"svau")

;; 54
(test-sandhi "puna.h" "api") ; XXX punarapi
(test-sandhi "punar" "api")
(test-sandhi "pita.h" "vadasi");; XXX pitarvadasi
(test-sandhi "pitar" "vadasi")
(test-sandhi "mata.h" "indu.m" "pa\"syasi") ;; XXX matarindu.m pa"syasi
||#




;;;; --------------------------------------------------------------------
;;;;
;;;; WORD SEGMENTER IMPL.
;;;;

;;;
;;;
;;;
(defun make-skt-sentence (string)
  "Parse ascii input string into a vector of sktchar symbols."
  (let ((parsed-string (parse-skt string)))
    (when parsed-string
      (make-array (length parsed-string)
		  :element-type 'symbol
		  :initial-contents parsed-string))))

#+nil
(make-skt-sentence "n.rpa.hjayati")


(defmacro collect-solutions (&body body)
  "Internal. Execute BODY with special *SOLUTIONS* bound to
NIL. Returns *SOLUTIONS*"
  `(let (*solutions*)
     (declare (special *solutions*))
     ,@body
     *solutions*))


;;; ----------------------------------------------------------------------
;;;
;;; sandhi non-determinisism.
;;;
(defstruct choice-point)

(defstruct (sandhi-choice-point (:include choice-point)) u v w)

(defvar *sandhi-choice-point-table* (make-hash-table :test #'equalp))

(defun intern-sandhi-choice-point (&key u v w)
  ;; TODO use three table lookup if needed.
  (or (gethash (list u v w) *sandhi-choice-point-table*)
      (setf (gethash (list u v w) *sandhi-choice-point-table*)
	    (make-sandhi-choice-point :u u :v v :w w))))

(defmethod print-object ((obj sandhi-choice-point) stream)
  (print-unreadable-object (obj stream :type nil :identity t)
    (call-next-method)))

(defun retrieve-choice-points (lexicon-entries)
  "Returns as values the partition of LEXICON-ENTRIES into two
sets: CHOICE-POINTS and remaining lexicon-entries."
  (loop for x in lexicon-entries
	if (choice-point-p x) collect x into choice-points
	else collect x into rest
	finally (return (values choice-points rest))))

#+nil
(retrieve-choice-points (list 10 20 (make-choice-point) 30
			      (make-choice-point)))


;;;
;;;
(defun delete-choice-points-from-lexicon (trie)
  "Internal. Testing."
  (trie:maptrie (lambda (parsed-word lexicon-entries)
		  (setf (trie:gettrie parsed-word trie)
			(delete-if (lambda (x) (choice-point-p x))
				   lexicon-entries)))
		trie))

;;;
;;;
(defun descend-trie (trie parsed-word)
  "Internal. Returns the sub-trie after descending TRIE walking
down PARSED-WORD."
  (map nil (lambda (x)
	     (unless (setq trie (trie::trie-descend trie x))
	       (return-from descend-trie nil)))
       parsed-word)
  trie)


;;;
;;;
;;;
(defun compute-resumption-for-choice-point
    (choice-point input-string start end sub-trie trie output
     &optional cookie)
  "If CHOICE-POINT is a valid choice point at the given parse
state, return a resumption of the form (output start end
&optional trie sub-trie cookie)."
  (when (sandhi-choice-point-p choice-point)
    (let* ((u (sandhi-choice-point-u choice-point))
	   (v (sandhi-choice-point-v choice-point))
	   (w (sandhi-choice-point-w choice-point))
	   (e (+ start (length w))))
      (when (< e end)
	(unless (loop for c in w for i from start
		      unless (eql c (aref input-string i)) return t)
	  (let ((trie-for-u (descend-trie sub-trie u)))
	    (assert trie-for-u)
	    (let ((ent
		   (nth-value 1 (retrieve-choice-points (car trie-for-u)))))
	    (assert ent)
	    (let ((trie-for-v (descend-trie trie v)))
	      (when trie-for-v
		#+nil
		(warn "CP: string=~a posw=~a w=~s u=~s v=~s ent=~a, descend v."
		      (subseq input-string start end) posw w u v obj)
		(list (cons ent output)			 ; output
		      e					 ; start
		      end				 ; end
		      trie				 ; trie
		      trie-for-v			 ; sub-trie
		      (cons				 ; cookie
		       choice-point
		       cookie)
		      ))))))))))


#||
(defun skt-reader1 (stream delim arg)
  "For dispatching reader like #%{ascii input}, where the input can contain
unescaped #\"s. (useless with slime)"
  (declare (ignore delim arg))
  (assert (char= (read-char stream t nil t) #\{))
  (let* ((input (loop for c = (read-char stream t nil t)
		      if (char= c #\}) do (return (coerce string 'string))
		      else collect c into string)))
    (make-skt-sentence input)))
(set-dispatch-macro-character #\# #\% 'skt-reader1)
(list #%{nrpaanjayati})
(collect-solutions (segment-sentence $lexicon #%{ n.rpa.hjayati}))
(setq $s   #%{n.rpojayati})
(length $s)
(setq $cpl (trie:gettrie (parse-skt "n.rp") $lexicon))
(setq $st (descend-trie $lexicon (parse-skt "n.rp")))
(setq $cp (elt $cpl 47))
(compute-resumption-for-choice-point $cp $s 3 10 $st $lexicon nil)
||#



;;;
;;;
;;;
(defun segment-sandhi (trie string &optional (start 0)
		       (end (length string)) output
		       sub-trie cookie	; mode 2
		       fail)
  "Internal."
  (declare (special *solutions*) (ignorable cookie))
  (let ((p start) resumptions)
    (unless sub-trie (setq sub-trie trie)) ; mode 1
    #+debug-sandhi-segmenter
    (warn "segment sandhi: mode ~A (start=~a end=~a) ~a~@[~% cookie=~a~]"
	  (if (endp sub-trie) 2 1)
	  start end
	  (subseq string start end) cookie)
    (tagbody
     loop (assert (< p end) nil "Start index ~A > end index ~A" start end)
       (setq sub-trie (trie::trie-descend sub-trie (aref string p)))
       (cond (sub-trie
	      (let (choice-points set)
		(when (car sub-trie)
		  (assert (consp (car sub-trie)))
		  (multiple-value-setq (choice-points set)
		    (retrieve-choice-points (car sub-trie)))
		  (loop for choice-point in choice-points
			for resumption =
			(compute-resumption-for-choice-point
			 choice-point string (1+ p) end sub-trie trie output
			 cookie)
			if resumption do (push resumption resumptions)))
		(cond (set
		       (unless (and fail (funcall fail set output))
			 (cond ((= (1+ p) end)
				(let ((soln (reverse (cons set
							   output))))
				  #+debug-sandhi-segmenter
				  (warn "SOLUTION: ~A.~@[~%cookie=~A~]" soln
					cookie)
				  (push soln *solutions*)
				  (go cont)))
			       (t (cond ((cdr sub-trie) ; choice-point
					 (push (list (cons set output)
						     (1+ p)
						     end
						     nil
						     nil
						     (cons :choice-point
							   cookie)
						     )
					       resumptions) ; Mode 1
					 (incf p) (go loop))
					(t (push set output)
					   #+debug-segmenter
					   (warn "collecting ~A" set)
					   (setq sub-trie trie start (1+ p))
					   (incf p) (go loop)))))))
		      (t (cond ((= (1+ p) end) ; fail at end-of-input
				(go cont))
			       (t (incf p) (go loop)))))))
	     (t (go cont)))		; fail at end-of-trie
       ;; TODO maybe replace call to segment-sentence to a jump within
       ;; tagbody and remove special *solutions*
     cont (loop for (output1 start1 end1 trie1 sub-trie1 cookie) in resumptions
		do (segment-sandhi (or trie1 trie) ; mode 1, 2
				   string start1 end1 output1
				   sub-trie1 ; non-NIL in mode 2
				   cookie
				   fail)))))


;;; ----------------------------------------------------------------------
;;;
;;;
(defun make-u-v-w-sandhi-rule (final initial preceeding-final)
  (flet ((ensure-list (x) (etypecase x
			    (keyword (ecase x (:zero nil)))
			    (symbol (list x))
			    (cons x))))
    (multiple-value-bind (replacement next prev)
	(match-external-sandhi-rule final initial preceeding-final)
      (cond ((null replacement) (assert (null next)) (assert (null prev)))
	    (t (cond ((and (null prev) (null next))
		      (intern-sandhi-choice-point
		       :u (list final)
		       :v (list initial)
		       :w (append (ensure-list replacement) (list initial))))
		     ((or (null prev) (eq preceeding-final  prev)) ; XXX
		      (intern-sandhi-choice-point
		       :u (list final)
		       :v (list initial)
		       :w (append (ensure-list replacement)
				  (if next
				      (ensure-list next)
				      (list initial)))))
		     (t (intern-sandhi-choice-point
			 :u (list preceeding-final final)
			 :v (list initial)
			 :w (append (ensure-list prev)
				    (ensure-list replacement)
				    (if next
					(ensure-list next)
					(list initial)))))))))))

#||
(make-u-v-w-sandhi-rule 'sktchar:|i| 'sktchar:|o| 'sktchar:|m|)
(make-u-v-w-sandhi-rule 'sktchar:|.h| 'sktchar:|k| 'sktchar:|a|)
(make-u-v-w-sandhi-rule 'sktchar:|.h| 'sktchar:|j| 'sktchar:|a|)
||#

(defvar *u-v-w-memo* (make-hash-table :test #'equal))


(defun make-u-v-w-sandhi-rule-memo (&rest args)
  "ARGS=(final initial preceeding-final).Returns a list: (u v w)"
  (multiple-value-bind (values foundp) (gethash args *u-v-w-memo*)
    (cond (foundp values)
	  (t (setf (gethash args *u-v-w-memo*)
		   (apply 'make-u-v-w-sandhi-rule args))))))

(defvar *collect-sandhi-rules-memo* (make-hash-table :test #'equal))

(let (trap)
  (defun collect-sandhi-rules (parsed-word initial-letters-list)
    "Returns a sequence of SANDHI-CHOICE-POINTS"
    (assert (cond ((null trap) (setq trap initial-letters-list))
		  (t (eq trap initial-letters-list)))
	    nil "This version caches values for a single INITIAL-LETTERS-LIST.")
    (loop for x on parsed-word
	  for (preceeding-final final . rest) = x
	  if (endp rest) return
	  (multiple-value-bind (value foundp)
	      (gethash x *collect-sandhi-rules-memo*)
	    (cond (foundp value)
		  (t (setf (gethash x *collect-sandhi-rules-memo*)
			   (loop for initial across initial-letters-list
				 if (make-u-v-w-sandhi-rule-memo
				     final initial preceeding-final)
				 collect it))))))))

#||
(collect-sandhi-rules (skt-tagger::parse-skt "namaami") *initial-letters*)
(collect-sandhi-rules (skt-tagger::parse-skt "n.rpaya.h") *initial-letters*)
||#




;;;; ---------------------------------------------------------------------
;;;;
;;;; INTERNAL SANDHI IMPL.
;;;;

;;;
;;;
;;;
(defvar *internal-sandhi-rules* nil
  "List of match functions of 2 arguments: (REVX Y). The match
function returns new values for REVX and Y if it applies. If
matched, The match function may modify or share the structure of
REVX. It may not modify Y but can share its structure.")

(defun add-internal-sandhi-rule (function)
  "Internal."
  (unless (find function *internal-sandhi-rules*)
    (setq *internal-sandhi-rules* (nconc *internal-sandhi-rules*
					 (list function)))))

(defun append-applying-internal-sandhi-2 (x y)
  "Internal. Appends lists X and Y applying rules of internal
sandhi. Second value is NON-NIL if rule was applied."
  (let ((revx (reverse x)))
    (flet ((apply-rule (f)
	     (multiple-value-bind (revx y) (funcall f revx y)
	       (when (or revx y)
		 (return-from append-applying-internal-sandhi-2
		   (values (nreconc revx y) f))))))
      (map nil #'apply-rule *internal-sandhi-rules*)
      (nreconc revx y))))


(defun match-internal-sandhi-rule-1 (revx  y)
  "Internal. When e and o are followed in the same word by any
vowel, they are changed resp. to ay and av. (9)"
  (when (and (and (get (car revx) :vowel)
		  (case (car revx) ((sktchar:|e| sktchar:|o|) t)))
	     (get (car y) :vowel))
    (ecase (car revx)
      (sktchar:|e| (setf (car revx) 'sktchar:|a|) (push 'sktchar:|y| revx))
      (sktchar:|o| (setf (car revx) 'sktchar:|a|) (push 'sktchar:|v| revx)))
    (values revx y)))


;; NOTE: This should be the first rule.
(add-internal-sandhi-rule 'match-internal-sandhi-rule-1)


(defun append-applying-internal-sandhi (&rest lists)
  (reduce 'append-applying-internal-sandhi-2 lists))


(defun test-internal-sandhi (x y &rest rest)
  "Internal. Testing."
  (let* (answer
	 (args
	  (loop for cons on rest
		unless (eq (car cons) ':=) collect (car cons)
		else do
		(assert (endp (cddr cons)))
		(setq answer (cadr cons))
		(return)))
	 (result
	  (apply
	   'concatenate 'string
	   (mapcar 'symbol-name
		   (apply 'append-applying-internal-sandhi
			  (mapcar 'parse-skt (cons x (cons y args))))))))
    (when answer (assert (string= answer result)))
    result))


(defun match-internal-sandhi-rule-2 (revx y)
  "Internal. When in the same word n is preceeded by .r, .r.r,
r or .s and followed by a vowel, n, m, y, or v, it is changed to
.n.

The rule applies even when n is separated from the preceeding .r,
.r.r, r or .s by several letters provided those intervening
letters be vowels, gutturals, labials, or y, v, h, and
anusvara. (17)."
  (flet ((test-following (c)
	   (or (get c :vowel)
	       (case c ((sktchar:|n| sktchar:|m| sktchar:|y| sktchar:|v|) t))))
	 (test-preceeding (c)
	   (case c ((sktchar:|.r| sktchar:|.r.r| sktchar:|r| sktchar:|.s|) t)))
	 (test-intervening (c)
	   (or (get c :vowel) (get c :labial) (get c :guttural)
	       (case c
		 ((sktchar:|y| sktchar:|v| sktchar:|h| sktchar:|.m|) t)))))
    (let* (rpi				; reverse of prefix of initial
	   (member2
	    (loop for cons on y
		  if (eq (car cons) 'sktchar:|n|) return cons
		  else if (test-intervening (car cons))
		  do (push (car cons) rpi)
		  else return nil)))
      (when (and (cdr member2) (test-following (cadr member2))
		 (loop for c in revx
		       if (test-preceeding c) return t
		       else unless (test-intervening c) return nil))
	(setq y (nreconc rpi (cons 'sktchar:|.n| (cdr member2))))
	(values revx y)))))

(add-internal-sandhi-rule 'match-internal-sandhi-rule-2)

;;;
;;;
;;;
(defun match-internal-sandhi-rule-3 (revx y)
  "Internal. When s is preceeded by a vowel except a or aa, or by k or r,
it is changed to .s when in the same word, t, th, m, .n, v or any
vowel follows. An anusvara or a visarga do not affect the
application of the rule. 45. (TODO CHECK .n)"
  (cond ((and (eq (car y) 'sktchar:|s|)
	      (and (cdr y) (or (get (cadr y) :vowel)
			       (case (cadr y)
				   ((sktchar:|t| sktchar:|th| sktchar:|m|
					     sktchar:|.n| sktchar:|v|) t)))))
	 (let ((c (case (car revx)
		    ((sktchar:|.m| sktchar:|.h|) (cadr revx))
		    (otherwise (car revx)))))
	   (when (or (and (get c :vowel)
			  (not (case c ((sktchar:|a| sktchar:|aa|) t))))
		     (case c ((sktchar:|k| sktchar:|r|) t)))
	     (setq y (cons 'sktchar:|.s| (cdr y)))
	     (values revx y))))))


(add-internal-sandhi-rule 'match-internal-sandhi-rule-3)

(defun match-internal-sandhi-rule-4 (revx y)
  "Internal. Apply external sandhi vowel rules for internal sandhi."
  (when (and (get (car revx) :vowel)
	     (get (car y) :vowel))
    (multiple-value-bind (replacement next prev)
	(match-external-vowel-sandhi-rule
	 (car revx) (car y) (cadr revx))
      (cond ((null replacement)
	     (assert (null next)) (assert (null prev)))
	    (t (assert (null prev))
	       (etypecase next
		 (null)
		 (keyword (ecase next
			    (:zero (setq y (cdr y)))))
		 (symbol (setq y (cons next (cdr y))))
		 (cons (setq y (append next (cdr y)))))
	       (etypecase replacement
		 (keyword (ecase replacement
			    (:zero
			     (setq revx (cdr revx)))))
		 (symbol (setf (car revx) replacement))
		 (cons
		  (setq revx (nconc
			      (reverse replacement)
			      (cdr revx)))))))))
  (values revx y))

(add-internal-sandhi-rule 'match-internal-sandhi-rule-4)


#||
(test-internal-sandhi "je" "a" := "jaya")
(test-internal-sandhi "bho" "a" := "bhava")
(test-internal-sandhi "pat" "aami" := "pataami")
(test-internal-sandhi "pit.r" "aani")
(test-internal-sandhi "putr" "aani")
;; Rule 2
(test-internal-sandhi "putr" "aani" := "putraa.ni")
(test-internal-sandhi "nar" "ena" := "nare.na")
(test-internal-sandhi "naraa" "n" := "naraan")
(test-internal-sandhi "pu.sy" "anti" := "pu.syanti")
(test-internal-sandhi "arjun" "ena" := "arjunena")
;; Rule 3
(test-internal-sandhi "nadii" "su" := "nadii.su")
(test-internal-sandhi "anu" "sa.nga" := "anu.sa.nga")
(test-internal-sandhi "dhanu.h" "su" := "dhanu.h.su")
(test-internal-sandhi "abhi" "seka" := "abhi.seka")
;;
(append-applying-internal-sandhi-2 '(sktchar:|a|) '(sktchar:|ii| sktchar:|th|
						  sktchar:|e|))
(match-external-vowel-sandhi-rule 'sktchar:|a| 'sktchar:|ii| nil)
(setq *internal-sandhi-rules* (nbutlast *internal-sandhi-rules*))
(match-internal-sandhi-rule-4 '(sktchar:|a|)
			      '(sktchar:|ii| sktchar:|th|
				sktchar:|e|))
(test-internal-sandhi "labha" "iithe")
(apply 'append-applying-internal-sandhi (mapcar 'parse-skt '("pat" "a" "aami")))
||#



;;;; ---------------------------------------------------------------------
;;;;
;;;; SKT-TAGGER IMPLEMENTATION
;;;;

;;; ----------------------------------------------------------------------
;;;
;;; gu.na and v.rddhi. 6.
;;;
(defun form-gu.na (vowel)
  (ecase vowel
    ((sktchar:|a| sktchar:|aa|) (list 'sktchar:|a|))
    ((sktchar:|i| sktchar:|ii|) (list 'sktchar:|e|))
    ((sktchar:|u| sktchar:|uu|) (list 'sktchar:|o|))
    ((sktchar:|.r| sktchar:|.r.r|) (list 'sktchar:|a| 'sktchar:|r|))
    (sktchar:|.l|  (list 'sktchar:|a| 'sktchar:|l|))))

(defun form-v.rddhi (vowel)
  (ecase vowel
    ((sktchar:|a| sktchar:|aa|) (list 'sktchar:|aa|))
    ((sktchar:|i| sktchar:|ii|) (list 'sktchar:|ai|))
    ((sktchar:|u| sktchar:|uu|) (list 'sktchar:|au|))
    ((sktchar:|.r| sktchar:|.r.r|)  (list 'sktchar:|aa| 'sktchar:|r|))
    (sktchar:|.l|  (list 'sktchar:|aa| 'sktchar:|l|))))

#||
(form-gu.na 'sktchar:|.l|)
(form-v.rddhi 'sktchar:|.l|)
||#




;;; ----------------------------------------------------------------------
;;;
;;; The First Conjugation (bhvaadi). 6.
;;;
(defun form-verbal-base-1 (root)
  "First conjugation: bhvaadi. For regular verbs. The final vowel
and short medial vowel take gu.na. 7."
  (let ((line root) c rest ret)
    (loop (cond ((endp line) (return (nreverse ret)))
		((setq c (car line) rest (cdr line))
		 (cond ((and (get c :consonant)	; short medial vowel check
			     (get (car rest) :vowel)
			     (get (car rest) :short)
			     (cadr rest) (get (cadr rest) :consonant)
			     ;; vowel deemed long if follwed by conjunct
			     (or (endp (cddr rest))
				 (not (get (caddr rest) :consonant))))
			(setq ret (nreconc (form-gu.na (car rest))
					   (cons c ret))
			      line (cddr line)))
		       ((setq ret (cons c ret) line (cdr line)))))
		((get c :vowel) (return (nreconc ret (form-gu.na c))))
		((return (nreverse (cons c ret))))))))


#||
(form-verbal-base-1 (parse-skt "nind"))
(form-verbal-base-1 (parse-skt "bhak.s")) ; conj.class 10
(form-verbal-base-1 (parse-skt "jiiv"))
(form-verbal-base-1 (parse-skt "pat"))
(form-verbal-base-1 (parse-skt "budh"))
(form-verbal-base-1 (parse-skt "k.r.s")) ; XXX classes 1 and 6
||#



;;; NOTES:
;;;
;;; DECLENSION TABLE |    0   	   1         2
;;; SCHEMA           | Sing.(1)  Dual.(2)  Pl.(3)
;;; -----------------+-----------------------------
;;; 0 1st Person (1) |
;;; 1 2nd Person (2) |
;;; 2 3rd Person (3) |


(defvar *verb-termination-table1*
  #2a(( ;; First person
       (sktchar:|m| sktchar:|i|)	; Sing.
       (sktchar:|v| sktchar:|a| sktchar:|.h|) ;Dual
       (sktchar:|m| sktchar:|a| sktchar:|.h|)) ;Pl.
      ( ;; Second person
       (sktchar:|s| sktchar:|i|)
       (sktchar:|th| sktchar:|a| sktchar:|.h|)
       (sktchar:|th| sktchar:|a|))
      ( ;; Third person
       (sktchar:|t| sktchar:|i|)
       (sktchar:|t| sktchar:|a| sktchar:|.h|)
       (sktchar:|a| sktchar:|n| sktchar:|t| sktchar:|i|)))
  "Terminations of the present tense active voice: lat
parasmaipadii under the First Conjugation, bhvaadi. (No. 8).")



(defun add-termination-1 (base termination)
  "Internal. First conjugation bhvaadi. The vowel a is added
before terminations. If the termination begins with a m or a v
that a becomes aa. That a is dropped before terminations begining
with an a. 7."
  (case (car termination)
    (sktchar:|a| (append-applying-internal-sandhi base termination))
    ((sktchar:|m| sktchar:|v|)
     (append-applying-internal-sandhi base '(sktchar:|aa|) termination))
    (otherwise
     (append-applying-internal-sandhi base '(sktchar:|a|) termination))))

#+nil
(add-termination-1 (parse-skt "pat")
		   (aref *verb-termination-table1* 0 0))

;;;
;;;
;;;
(defun map-declensions (base table &optional f (append-fn #'append))
  "Internal. Adds terminations in declension table TABLE to the
base and maps F if non-NIL on the declined forms, in which case F
should be a function taking 3 arguments: (declined-form rownum
colnum) where ROWNUM and COLNUM are integers indexed from 1."
  (destructuring-bind (rows cols) (array-dimensions table)
    (loop for row from 0 below rows for p from 1
	  do (loop for col from 0 below cols for n from 1
		   for termination = (aref table row col)
		   for declined-form = (funcall append-fn base termination)
		   if f do (funcall f declined-form p n)
		   else do (warn "~A ~A: ~A" p n declined-form)))))


;;; ----------------------------------------------------------------------
;;;
;;;
;;;
(defclass skt-word-mixin ()
  ((documentation-string :type string :initform "" :initarg :documentation)
   (string-form :type string :initarg :string)))

(defmethod print-object ((obj skt-word-mixin) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (with-slots (string-form documentation-string) obj
      (format stream "~A (~A)" string-form documentation-string))))

;;;
;;;
;;;
(defclass skt-root (skt-word-mixin) ())

(defclass skt-verbal-root (skt-root)		; dhatu
  ((conjugation-class
    :type integer :initarg :conjugation-class)
   (irregular-base
    :initform nil :initarg :irregular-base
    :reader irregular-base)
   (voice :initarg :voice :reader default-voice)))


(defmethod print-object ((obj skt-verbal-root) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (with-slots (string-form documentation-string) obj
      (with-slots (conjugation-class irregular-base) obj
	(format stream "~@R.~@[irr.~] ~A (~A)"
		conjugation-class irregular-base
		string-form
		documentation-string)))))


;;; ----------------------------------------------------------------------
;;;
;;;
;;;
(defun add-lexicon-entry (trie parsed-form obj &key default-action
			  (test #'equalp)
			  (if-exists :error))
  (let ((value (trie:gettrie parsed-form trie)))
    (cond ((null value) (push obj (trie:gettrie parsed-form trie)))
	  ((let ((member (member obj value :test test)))
	     (cond (member
		    (ecase if-exists
		      (:replace (rplaca member obj))
		      ((:ignore :soft))
		      (:warn (warn "~A: Not adding ~A: already in ~A"
				   parsed-form obj value))
		      (:error
		       (restart-case (error "~A: ~A exists in ~A"
					    parsed-form obj value)
			 (replace () (rplaca member obj))
			 (ignore ())))))
		   ((flet ((append-it () (nconc value (list obj)))
			   (replace-it ()
			     (setf (trie:gettrie parsed-form trie)(list obj)))
			   (prepend-it ()
			     (push obj (trie:gettrie parsed-form trie))))
		      (ecase default-action
			(:append (append-it))
			(:prepend (prepend-it))
			(:replace (replace-it))
			('nil (restart-case
				  (error "~A: add ~A to ~A"
					 parsed-form obj value)
				(append () (append-it))
				(ignore ())
				(prepend () (prepend-it))
				(replace () (replace-it)))))))))))))

(defun delete-lexicon-entry (trie parsed-word &optional obj &key
			     (test #'equalp) (if-does-not-exist :soft))
  (let ((value (trie:gettrie parsed-word trie)))
    (flet ((handle-missing-entry ()
	     (ecase if-does-not-exist
	       ((:soft nil))
	       (:error (error "~A: ~A not found in entries ~A" parsed-word
			      obj value))
	       (:warn (warn "~A: ~A not found in entries ~A" parsed-word
			    obj value)))))
      (cond ((null obj) (trie:remtrie parsed-word trie))
	    ((endp value)
	     (trie:remtrie parsed-word trie)
	     (handle-missing-entry))
	    ((funcall test obj (car value))
	     (setf (trie:gettrie parsed-word trie) (cdr value)))
	    ((loop for prev-cons = value then curr-cons
		   for curr-cons on (cdr value)
		   if (funcall test obj (car curr-cons))
		   return (prog1 (car curr-cons)
			    (setf (cdr prev-cons) (cdr curr-cons)))
		   finally (handle-missing-entry)))))))

(defun get-lexicon-entry (trie parsed-word &key all)
  (let ((value (trie:gettrie parsed-word trie)))
    (etypecase value
      (null)
      (cons (if all value (values (car value) (cdr value)))))))


;;;
;;;
;;;
(defun add-verb-vocabulary-1
    (vocab trie conjugation-class &optional (voice :active))
  "VOCAB is in a simple dictionary format: list (VERBAL-ROOT
MEANING) of type (string string), of the given
conjugation class.  Adds verbal-root to the roots lexicon TRIE
setting the value to a freshly instanciated SKT-VERBAL-ROOT
object. Returns VOCAB."
  (loop for (root doc) in vocab do
	(etypecase root (string))
	(let ((word (parse-skt root)))
	  (add-lexicon-entry
	   trie word (make-instance 'skt-verbal-root
				    :string root
				    :documentation doc
				    :voice voice
				    :conjugation-class conjugation-class))
	  (assert (string= (apply 'concatenate 'string
				  (mapcar (lambda (x) (symbol-name x)) word))
			   root))))
  vocab)

;;;
;;; Initialize verbal roots trie
;;;
(defvar *verbal-roots* (trie:make-trie))

(defvar *vocabulary2*
  (add-verb-vocabulary-1
   '(("kri.s" 	"to draw")
     ("krii.d" 	"to play")
     ("khan"	"to dig")
     ("khad"	"to eat")
     ("car"	"to move")
     ("cal"	"to move")
     ("ji"	"to conquer")
     ("jiiv"	"to live")
     ("tyaj"	"to abandon")
     ("dah"	"to burn")
     ("dru"	"to run, to melt")
     ("dhav"	"to run")
     ("nam"	"to salute")
     ("nii"	"to lead")
     ("pac"	"to cook")
     ("pat"	"to fall")
     ("budh"	"to know")
     ("bhuu"	"to be, to become")
     ("bhram"	"to walk")
     ("yaj"	"to worship")
     ("rak.sh"	"to protect")
     ("ruh"	"to grow")
     ("vad"	"to speak")
     ("vap"	"to sow")
     ("vas"	"to dwell")
     ("vah"	"to carry, to flow")
     ("vraj"	"to go")
     ("shans"	"to praise")
     ("s.r"	"to go")
     ("sm.r"	" to remember"))
   *verbal-roots*
   1)
  "Vocabulary for Lesson 2. Verbal roots of the 1st
conjugation.")

#||
(mapcar (lambda (x) (trie:gettrie (parse-skt x) *verbal-roots*))
	'("pat" "jiiv" "nind" "bhak.s"))
(trie:gettrie (parse-skt "pat") *verbal-roots*)
||#


;;; ----------------------------------------------------------------------
;;;
;;;
;;;
(defmethod form-verbal-base-internal :around
    ((obj skt-verbal-root) conjugation-class tense voice &optional parsed-form)
  "Internal. Around method handles irregular base."
  (declare (ignore conjugation-class parsed-form tense voice))
  (or (irregular-base obj) (call-next-method)))


(defmethod form-verbal-base-internal
    ((obj skt-verbal-root) (conjugation-class (eql 1))
     (tense (eql :present))
     (voice (eql :active))
     &optional parsed-form)
  "Internal Protocol method."
  (declare (ignore obj conjugation-class tense voice))
  (assert parsed-form)
  (form-verbal-base-1 parsed-form))


(defmethod decline-verbal-root-internal    ((obj skt-verbal-root)
     (conjugation-class (eql 1))
     (tense (eql :present))
     (voice (eql :active))
     base &optional f)
    "Internal. Protocol method dispatched for the First
conjugation: bhvaadi. Decline the verbal root (corresponding to
OBJ) in PARSED-FORM in the present tense active voice in each of
3 persons and 3 numbers."
    (declare (ignore conjugation-class tense voice))
    (map-declensions base *verb-termination-table1* f #'add-termination-1))


;;;
;;;
;;;
(defmethod decline-root
    ((obj skt-verbal-root) &optional f parsed-form &rest keys
    &key &allow-other-keys)
  "Internal. Protocol method. Maps f on declensions of root
OBJ. If :TENSE and :VOICE keys are not supplied, defaults to
present tense and default voice of the verb."
  (let ((tense (or (getf keys :tense) :present))
	(voice (or (let ((x (getf keys :voice)))
		     (ecase x
		       ((:active :middle) x)
		       ((nil) (default-voice obj)))))))
    (with-slots (conjugation-class) obj
      (decline-verbal-root-internal
       obj conjugation-class tense voice
       (form-verbal-base-internal
	obj conjugation-class tense voice
	(or parsed-form (parse-skt (slot-value obj 'string-form))))
       f))))


#||
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "pat")))
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "jiiv")))
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "nind"))) ;
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "ji")))
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "bhu")))
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "budh")))
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "k.r.s")))
(add-lexicon-entry *verbal-roots* (parse-skt "nind")
		   (make-instance 'skt-verbal-root :documentation "to blame"
				  :string "nind"
				  :conjugation-class 1))
(add-lexicon-entry *verbal-roots* (parse-skt "bhak.s")
		   (make-instance 'skt-verbal-root :documentation "to eat"
				  :string "bhak.s"
				  :conjugation-class 10)))
(trie:remtrie (parse-skt "bhak.s") *verbal-roots*)
(add-lexicon-entry *verbal-roots* (parse-skt "k.r.s")
		   (make-instance 'skt-verbal-root :documentation "to draw"
				  :string "k.r.s"
				  :conjugation-class 1))
(add-lexicon-entry *verbal-roots* (parse-skt "k.r.s")
		   (make-instance 'skt-verbal-root :documentation "to plough"
				  :string "k.r.s"
				  :conjugation-class 6))
(get-lexicon-entry *verbal-roots* (parse-skt "k.r.s"))
(get-lexicon-entry *verbal-roots* (parse-skt "k.r.s") :all t)
(delete-lexicon-entry
 *verbal-roots*
 (parse-skt "k.r.s"
 (car (get-lexicon-entry *verbal-roots* (parse-skt "k.r.s") :all t))
 :if-does-not-exist :error)
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "pat")))
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "jiiv")))
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "nind"))) ;
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "ji")))
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "bhu")))
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "budh")))
(decline-root (get-lexicon-entry *verbal-roots* (parse-skt "k.r.s")))
(decline-root (make-instance 'skt-verbal-root :documentation "to rejoice"
			     :string "mud"
			     :voice :middle
			     :conjugation-class 1))
(decline-root (make-instance 'skt-verbal-root :documentation "to obtain"
			:string "labh"
			:voice :middle
			:conjugation-class 1)
(map-declensions
 (form-verbal-base-internal $x 1 :present :middle (parse-skt "labh"))
 *verb-termination-table2*)
||#



;;; ----------------------------------------------------------------------
;;;
;;;

(defstruct lexicon-entry)

;;;
;;;
(defstruct (verbal-declension (:include lexicon-entry))
  tense voice persons numbers verbal-root string-form)


(defmethod add-declensions-to-lexicon ((obj skt-verbal-root) trie
				       &optional parsed-form)
  "Internal. Declines PARSED-FORM corresponding to verbal root
OBJ in present tense active voice in each of 3 persons and 3
numbers, and add the declined forms to the lexicon TRIE."
  (loop for tense in '(:present) do
	(loop for voice in '(:active) do
  (decline-root obj
		(lambda (declined-form persons numbers)
		  (declare (type (integer 1 3) persons numbers))
		  (let ((declined-string
			 (apply 'concatenate 'string
				(mapcar 'symbol-name declined-form))))
		    (add-lexicon-entry
		     trie declined-form
		     (make-verbal-declension
		      :tense :present
		      :voice voice
		      :persons persons
		      :numbers numbers
		      :verbal-root obj
		      :string-form declined-string)
		     :default-action :append)))	;XXX
		parsed-form
		:voice voice
		:tense tense))))

;;;
;;;
;;;
(defvar *skttag-initialization-table* nil
  "Internal. Alist of (name initialization-form). Used for
initializing the lexicon.")

(defun add-initialization (name form &key last)
  "Internal. Arrange to have FORM evaluated when
RUN-INITIALIZATIONS is called."
  (let ((entry (assoc name *skttag-initialization-table*
		      :test #'string-equal)))
    (cond (entry (setf (cadr entry) form))
	  (t (setq entry (list name form))
	     (cond ((and *skttag-initialization-table* last)
		    (loop for x on *skttag-initialization-table*
			  for (c . rest) = x when (endp rest) return
			  (setf (cdr x) (list entry))))
		   (t (push entry *skttag-initialization-table*)))))))

(defun run-initializations ()
  "Internal. Evaluates the initialization forms which were added
by ADD-INITIALIZATION. Returns T."
  (loop for (name form) in *skttag-initialization-table*
	do (warn "Evaluating ~A" name)
	(restart-case
	    (time (eval form))
	  (skip () :report (lambda (stream)
			     (format stream "Skip Initialization: ~A" name))
		()))
	  ) T)


;;;
;;; THE GENERAL LEXICON: $lexicon is initialized at the last line of
;;; this file.
;;;
(defvar $lexicon (trie:make-trie))

;;;
;;;
(defstruct (syntax (:include lexicon-entry))
  form)

(add-initialization
 "Add the space character to lexicon"
 '(add-lexicon-entry  $lexicon
   '(sktchar:| |)
   (make-syntax :form 'sktchar:| |)))

;;;
;;;
(defun decline-and-add-to-lexicon (trie &optional ($lexicon $lexicon)) ; XXX
  "Intrenal. Decline the roots in TRIE and add the declined forms
to $LEXICON. Returns T."
  (trie:maptrie (lambda (parsed-form entries)
		  (assert (consp entries))
		  (loop for x in entries do
			(add-declensions-to-lexicon x $lexicon parsed-form)))
		trie) T)

(add-initialization "Decline verbal roots and add to lexicon"
		    '(decline-and-add-to-lexicon *verbal-roots*))

#||
(trie:gettrie (parse-skt "nayati") $lexicon)
||#


;;; ----------------------------------------------------------------------
;;;
;;; NOUNS
;;;
(defclass skt-noun-root (skt-root)
  ((gender :type (integer 1 3) :initarg :gender
	   :documentation "1 - masculine, 2 - neuter, 3 - feminine.")
   (declension-class :type keyword :initarg :declension-class)))

(defmethod print-object ((obj skt-noun-root) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (with-slots (string-form documentation-string gender) obj
      (format stream "~A ~[m~;n~;f~]. (~A)"
	      string-form
	      (1- gender)
	      documentation-string))))

#+nil
(setq $a
      (make-instance 'skt-noun-root
	       :gender 1
	       :string "kuupa"
	       :documentation "a well"))

;;; ----------------------------------------------------------------------
;;;
;;; MASCULINE and NEUTER NOUNS IN A
;;;

;;;
;;;
;;;
(defun add-noun-vocabulary-1 (vocab trie)
  "VOCAB is a list of (NOUN meaning) where NOUN is masculine and
ends in a. NOUN is specified in Nom. Sing.  Adds the NOUN to the
lexicon TRIE setting the value to a freshly instanciated
SKT-NOUN-ROOT object. Returns VOCAB."
  (loop for (root doc) in vocab do
	(etypecase root (string))
	(assert (= (search "a.h" root :from-end t)
		   (- (length root) 3)))
	(setq root (subseq root 0 (- (length root) 2)))
	(let ((word (parse-skt root)))
	  (add-lexicon-entry
	   trie word
	   (make-instance 'skt-noun-root
			  :string root
			  :documentation doc
			  :declension-class :a
			  :gender 1))))
  vocab)

;;;
;;;
;;;
(defvar *noun-roots* (trie:make-trie))

(defvar *vocabulary3a*
  (add-noun-vocabulary-1
   '(("a\"sva.h" 	"horse")
     ("aacara.h"	"conduct")
     ("kapota.h"	"pigeon")
     ("kara.h" 		"hand")
     ("kaka.h"		"crow")
     ("grama.h"		"village")
     ("jana.h"		"people")
     ("daasa.h"		"servant")
     ("de\"sa.h"	"country")
     ("nara.h"		"man")
     ("n.rpa.h"		"king")
     ("parvata.h"	"mountain")
     ("baala.h"		"boy")
     ("megha.h"		"cloud")
     ("v.rk.sa.h"	"tree"))
   *noun-roots*)
  "Vocabulary for Lesson 3. Masculine nouns ending in a.")

;;;
;;;
(defun add-noun-vocabulary-2 (vocab trie)
  "VOCAB is a list of (NOUN meaning) where NOUN is neuter and
ends in a. NOUN is specified in Nom. Sing.  Adds the NOUN to the
lexicon TRIE setting the value to a freshly instanciated
SKT-NOUN-ROOT object. Returns VOCAB."
  (loop for (root doc) in vocab do
	(etypecase root (string))
	(assert (= (search "am" root :from-end t)
		   (- (length root) 2)))
	(setq root (subseq root 0 (- (length root) 1)))
	(let ((word (parse-skt root)))
	  (add-lexicon-entry
	   trie word
	   (make-instance 'skt-noun-root
			  :string root
			  :documentation doc
			  :declension-class :a
			  :gender 2))))
  vocab)

(defvar *vocabulary3b*
  (add-noun-vocabulary-2
   '(("annam"		"food")
     ("indham"		"fuel")
     ("kanakam"		"gold")
     ("kamalam"		"lotus")
     ("jalam"		"water")
     ("t.r.nam"		"grass")
     ("du.hkham"	"misery")
     ("patram"		"leaf")
     ("phalam"		"fruit")
     ("shariiram"	"body")
     ("shaastram"	"sacred precept")
     ("shiilam"		"character")
     ("sukham"		"happiness")
     ("sthaanam"	"place"))
   *noun-roots*)
  "Vocabulary for Lesson 3. Neut. nouns ending in a.")


;;; ----------------------------------------------------------------------
;;;
;;;
(defun add-vocabulary-1 (vocab trie class)
  "Adds words from VOCAB of list (WORD MEANING), verbatim, to
trie. Instanciates object of CLASS"
  (assert (subtypep class 'skt-word-mixin))
  (loop for (string meaning) in vocab
	for parsed-form = (parse-skt string)
	do (add-lexicon-entry
	    trie parsed-form
	    (make-instance class :documentation meaning :string string)))
  vocab)


;;; ----------------------------------------------------------------------
;;;
;;;
;;;
(defclass skt-preposition (skt-word-mixin) ())

(defvar *indeclinables* (trie:make-trie))

(defvar *vocabulary3c*
  (add-vocabulary-1
   '(("abita.h"		"near, in front")
     ("parita.h"	"around")
     ("sarvata.h"	"on all sides")
     ("ubhayata.h"	"on both sides")
     ("dhik"		"fie on")
     ("samaya"		"near")
     ("nika.sa"		"near")
     ("vina"		"without")
     ("antare.na"	"without")
     ("ati"		"above")
     ("anu"		"after, according to, along")
     ("abhi"		"near")
     ("antaraa"		"between")
     ("upa"		"near, below"))
   *indeclinables*
   'skt-preposition)
  "Vocabulary for Lesson 3: Prepositions governing the accusative.")

;;;
;;;
;;;
(defstruct (preposition-entry (:include lexicon-entry))  governs entry)

(defun add-preposition-entry-to-lexicon
    (trie string governing &optional (parsed-form (parse-skt string))
     (entry (let ((ents
		   (get-lexicon-entry *indeclinables* parsed-form :all t)))
	      (assert ents)
	      (assert (endp (cdr ents)))
	      (car ents))))
  "Internal."
  (add-lexicon-entry trie parsed-form
		     (make-preposition-entry :governs governing :entry entry)
		     :default-action :append))

(add-initialization
 "Add preposition entries to lexicon (Lesson 4)"
 '(loop	finally (return t)
	for (word . meaning) in *vocabulary3c*
	do (add-preposition-entry-to-lexicon  $lexicon word ':accusative)))


#+nil
(get-lexicon-entry $lexicon (parse-skt "abhi"))



;;; ----------------------------------------------------------------------
;;;
;;;    DECLENSION      |  0           1           2
;;;   TABLE SCHEMA:    | Sing.(1)   Dual.(2)   Pl.(3)
;;; -------------------+-----------------------------
;;; 0 Nominative   (1) |
;;; 1 Accusative   (2) |
;;; 2 Instrumental (3) |
;;; 3 Dative       (4) |
;;; 4 Ablative     (5) |
;;; 5 Genitive     (6) |
;;; 6 Locative     (7) |
;;; 7 Vocative     (8) |

(defvar *declension-table1a*
  #2a(((sktchar:|a| sktchar:|.h|) (sktchar:|au|) (sktchar:|aa| sktchar:|.h|))
      ((sktchar:|a| sktchar:|m|) (sktchar:|au|) (sktchar:|aa| sktchar:|n|))
      ((sktchar:|e| sktchar:|n| sktchar:|a|)
       (sktchar:|aa| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|ai| sktchar:|h|))
      ((sktchar:|aa| sktchar:|y| sktchar:|a|)
       (sktchar:|aa| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|e| sktchar:|bh| sktchar:|a| sktchar:|.h|))
      ((sktchar:|aa| sktchar:|t|)
       (sktchar:|aa| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|e| sktchar:|bh| sktchar:|a| sktchar:|.h|))
      ((sktchar:|a| sktchar:|s| sktchar:|y| sktchar:|a|)
       (sktchar:|a| sktchar:|o| sktchar:|.h|)
       (sktchar:|aa| sktchar:|n| sktchar:|aa| sktchar:|m|))
      ((sktchar:|e|)
       (sktchar:|a| sktchar:|y| sktchar:|o| sktchar:|.h|)
       (sktchar:|e| sktchar:|.s| sktchar:|u|))
      ((sktchar:|a|) (sktchar:|au|) (sktchar:|aa| sktchar:|.h|)))
  "Declension (terminations) of masculine nouns a. Eg:
kuupa (after eliding final a). 11.")


(defmethod decline-noun-root-internal
    ((obj skt-noun-root) (gender (eql 1)) (declension-class (eql :a))
     &optional f parsed-form)
  "Internal. Protocol method. For Masc. nouns in a."
  (assert (eq (car (last parsed-form)) 'sktchar:|a|))
  (map-declensions (butlast parsed-form) *declension-table1a* f
		   #'append-applying-internal-sandhi))

;;;
;;;
(defmethod decline-root ((obj skt-noun-root) &optional f parsed-form
			 &key &allow-other-keys)
  "Internal. Protocol method."
  (with-slots (gender declension-class) obj
    (decline-noun-root-internal
     obj gender declension-class f
     (if parsed-form parsed-form (parse-skt (slot-value obj 'string-form))))))


(defvar *declension-table1b*
  #2a(((sktchar:|a| sktchar:|m|)
       (sktchar:|e|)
       (sktchar:|aa| sktchar:|n| sktchar:|i|))
      ((sktchar:|a| sktchar:|m|)
       (sktchar:|e|)
       (sktchar:|aa| sktchar:|n| sktchar:|i|))
      ((sktchar:|e| sktchar:|n| sktchar:|a|)
       (sktchar:|aa| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|ai| sktchar:|h|))
      ((sktchar:|aa| sktchar:|y| sktchar:|a|)
       (sktchar:|aa| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|e| sktchar:|bh| sktchar:|a| sktchar:|.h|))
      ((sktchar:|aa| sktchar:|t|)
       (sktchar:|aa| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|e| sktchar:|bh| sktchar:|a| sktchar:|.h|))
      ((sktchar:|a| sktchar:|s| sktchar:|y| sktchar:|a|)
       (sktchar:|a| sktchar:|o| sktchar:|.h|)
       (sktchar:|aa| sktchar:|n| sktchar:|aa| sktchar:|m|))
      ((sktchar:|e|)
       (sktchar:|a| sktchar:|y| sktchar:|o| sktchar:|.h|)
       (sktchar:|e| sktchar:|.s| sktchar:|u|))
      ((sktchar:|a|)
       (sktchar:|e|)
       (sktchar:|aa| sktchar:|n| sktchar:|i|)))
  "Declension (terminations) of Neut. nouns in a. Eg:
vana (after eliding final a). 11.")


(defmethod decline-noun-root-internal
    ((obj skt-noun-root) (gender (eql 2)) (declension-class (eql :a))
     &optional f parsed-form)
  "Internal. Protocol method. For Neut. nouns in a."
  (assert (eq (car (last parsed-form)) 'sktchar:|a|))
  (map-declensions (butlast parsed-form) *declension-table1b* f
		   #'append-applying-internal-sandhi))

#||
(map-declensions (parse-skt "a\"sv") *declension-table1a*)
(map-declensions (parse-skt "van") *declension-table1b*)
(map-declensions (parse-skt "putr") *declension-table1b*)
(decline-root (car (trie:gettrie (parse-skt "de\"sa") *noun-roots*)))
(decline-root (car (trie:gettrie (parse-skt "sukha") *noun-roots*)))
||#


;;; ----------------------------------------------------------------------
;;;
;;; Lexicon mgt. protocols
;;;

(defstruct (noun-declension (:include lexicon-entry))
  noun-root case numbers string-form)


(defmethod add-declensions-to-lexicon  ((obj skt-noun-root) trie
					&optional parsed-form)
  "Internal. Protocol method. Decline the noun
root (corresponding to OBJ) in PARSED-FORM according to its
gender in each of 8 cases and 3 numbers, and add the declined
forms to the lexicon TRIE."
  (with-slots (gender declension-class) obj
    (decline-root obj
		  (lambda (declined-form case numbers)
		    (declare (type (integer 1 8) case)
			     (type (integer 1 3) numbers))
		    (let ((declined-string
			   (apply 'concatenate 'string
				  (mapcar 'symbol-name declined-form))))
		      (add-lexicon-entry
		       trie declined-form
		       (make-noun-declension :noun-root obj
					     :case case
					     :string-form declined-string
					     :numbers numbers)
		       :default-action :append)) ;XXX
		    parsed-form))))

(add-initialization "Decline noun roots and add to lexicon"
		    '(decline-and-add-to-lexicon *noun-roots*))

#||
(decline-and-add-to-lexicon *noun-roots*)
(trie:gettrie (parse-skt "a\"sva.h") $lexicon)
(trie:gettrie (parse-skt "a\"svaabhyaam") $lexicon)
||#


;;;
;;;
;;;
(defun lexicon-completions (trie)
  "Internal. Testing. Return exactly those strings of the
lexicon TRIE which have lexicon entries."
  (let (ret)
      (trie:maptrie
       (lambda (parsed-word entries)
	 (when (some (lambda (x) (lexicon-entry-p x)) entries)
	   (push (apply 'concatenate 'string
			(mapcar 'symbol-name parsed-word))
		 ret))) trie) ret))

#||
(lexicon-completions (descend-trie $lexicon (parse-skt "a\"s")))
(lexicon-completions (descend-trie $lexicon (parse-skt "eno")))
(lexicon-completions (descend-trie $lexicon (parse-skt "ji")))
||#


;;; ---------------------------------------------------------------------
;;;
;;; Annotating the lexicon with sandhi choice points
;;;

(defvar *initial-letters*
  #(SKTCHAR:|o| SKTCHAR:|k| SKTCHAR:|kh| SKTCHAR:|g| SKTCHAR:|gh|
    SKTCHAR:|c| SKTCHAR:|ch| SKTCHAR:|j| SKTCHAR:|jh| SKTCHAR:|.t|
    SKTCHAR:|.th| SKTCHAR:|.d| SKTCHAR:|.dh| SKTCHAR:|t|
    SKTCHAR:|th| SKTCHAR:|d| SKTCHAR:|dh| SKTCHAR:|p| SKTCHAR:|ph|
    SKTCHAR:|b| SKTCHAR:|bh| SKTCHAR:|n| SKTCHAR:|m| SKTCHAR:|y|
    SKTCHAR:|v| SKTCHAR:|r| SKTCHAR:|l| SKTCHAR:|"s| SKTCHAR:|.s|
    SKTCHAR:|s| SKTCHAR:|h| SKTCHAR:|a| SKTCHAR:|aa| SKTCHAR:|i|
    SKTCHAR:|ii| SKTCHAR:|u| SKTCHAR:|uu| SKTCHAR:|e| SKTCHAR:|ai|
    SKTCHAR:|au| SKTCHAR:|.r|)
  "List of permitted (following) initials in Coulson's sandhi
tables")


(defun annotate-lexicon-with-sandhi-choice-points (trie)
  "Internal."
  (trie:maptrie
   (lambda (parsed-word lexicon-entries)
     (loop for lexicon-entry in lexicon-entries do
	   (when (lexicon-entry-p lexicon-entry)
	     #+nil(warn "processing at ~A : ~A" parsed-word lexicon-entry)
	     (map nil (lambda (sandhi-choice-point)
			(let* ((u (SANDHI-CHOICE-POINT-U sandhi-choice-point))
			       (lambda (butlast parsed-word (length u))))
			  #+nil
			  (warn "adding at ~A : ~A" lambda sandhi-choice-point)
			  ;; XXX modifies trie, but shouldnt affect maptrie
			  (add-lexicon-entry  trie lambda sandhi-choice-point
					      :default-action :append
					      :if-exists :ignore)))
		  (COLLECT-SANDHI-RULES parsed-word *initial-letters*)))))
   trie))


(add-initialization
 "Annotate lexicon with sandhi choice points"
 '(annotate-lexicon-with-sandhi-choice-points $lexicon) :last t)


;;;
;;;
;;;
(defun segment-skt (string)
  (etypecase string
    (string
     (collect-solutions
       (segment-sandhi $lexicon (make-skt-sentence string))))))


#||
(time (delete-choice-points-from-lexicon $lexicon))
(time (annotate-lexicon-with-sandhi-choice-points $lexicon))
(segment-skt "n.rpojayati")
(segment-skt "n.rpa.hjayati")
(segment-skt "n.rpodaasaank.saamyati")
(segment-skt "dhanamantare.najiivana.mna\"syati")
||#


;;; ----------------------------------------------------------------------
;;;
;;; The Fourth Conjugation (divaadi)
;;;
;;; The radical vowel does not take gu.na. y is added to the root.
;;; The letter a is added before terminations. That a becomes aa
;;; before terminations begining with m or v and dropped before
;;; terminations begining with a. The terminations are same as the
;;; first conjugation (see no.8). 16.


(defun form-verbal-base-4 (root)
  "Fourth conjugation: divaadi. For regular verbs.The radical
vowel does not take gu.na. y is added to the root."
  (append root (list 'sktchar:|y|)))


(defmethod form-verbal-base-internal
    ((obj skt-verbal-root)
     (conjugation-class (eql 4))
     (tense (eql :present))
     (voice (eql :active))
     &optional parsed-form)
  "Internal Protocol method."
  (declare (ignore obj conjugation-class tense voice))
  (form-verbal-base-4 parsed-form))


(defmethod decline-verbal-root-internal
    ((obj skt-verbal-root)
     (conjugation-class (eql 4))
     (tense (eql :present))
     (voice (eql :active))
     base &optional f)
  "Internal. Protocol method dispatched for the Fourth
conjugation: divaadi. Decline the verbal root (corresponding to
OBJ) in PARSED-FORM in the , in the present tense active voice in
each of 3 persons and 3 numbers."
  (map-declensions base *verb-termination-table1* f #'add-termination-1))




;;;
;;;
(defmethod decline-verbal-root-internal
    ((obj skt-verbal-root)
     (conjugation-class (eql 4))
     (tense (eql :present))
     (voice (eql :active))
     base &optional f)
  "Internal. Protocol method dispatched for the Fourth
conjugation: divaadi.  Decline the verbal root (corresponding to
OBJ) in PARSED-FORM in the present tense active voice in each of
3 persons and 3 numbers."
  (map-declensions base *verb-termination-table1* f #'add-termination-1))


;;;
;;; Irregular verbs
;;;
(defun add-verb-vocabulary-2
    (vocab trie conjugation-class &optional (voice :active))
  "VOCAB is a list of (VERBAL-ROOT IRREGULAR-BASE meaning). Add
irregular verbal roots in given CONJUGATION-CLASS in VOCAB to the
roots lexicon TRIE."
  (loop for (root irregular-base doc) in vocab do
	(assert (= (search "ati" irregular-base :from-end t)
		   (- (length irregular-base) 3)))
	(setq irregular-base
	      (parse-skt (subseq irregular-base 0
				 (- (length irregular-base) 3))))
	(let ((word (parse-skt root)))
	  (add-lexicon-entry
	   trie word
	   (make-instance 'skt-verbal-root
			  :string root
			  :documentation doc
			  :conjugation-class conjugation-class
			  :voice voice
			  :irregular-base irregular-base)
	   :default-action :append)	;XXX
	  (assert (string= (apply 'concatenate 'string
				  (mapcar (lambda (x) (symbol-name x)) word))
			   root))))
  vocab)

(defvar *irregular-vocabulary-4a*
  (add-verb-vocabulary-2
   '(("gam"	"gacchati"	"to go")
     ("yam"	"yacchati"	"to restrain")
     ("guh"	"guuhati"	"to hide")
     ("sad"	"siidati"	"to sit")
     ("ghra"	"jighrati"	"to smell")
     ("paa"	"pibati"	"to drink")
     ("sthaa"	"ti.s.thati"	"to stand")
     ("da.m\"s" "da\"sati"	"to bite")
     ("dhma"	"dhamati"	"to blow")
     ("d.r\"s"	"pa\"syati"	"to see"))
   *verbal-roots*  1)
  "Irregular verbal roots of the First Conjugation in Lesson 4.")


(defvar *irregular-vocabulary-4b
  (add-verb-vocabulary-2
   '(("div"	"diivyati"	"to play")
     ("\"sam"	"\"saamyati"	"to cease")
     ("\sram"	"\"sraamyati"	"to be weary")
     ("mad"	"maadyati"	"to rejoice")
     ("vyadh"	"vidhyati"	"to pierce")
     ("bhra.m\"s"	"bhr\"syati"	"to fall")
     ("k.sam"	"k.saamyati"	"to forgive")
     ("bhram"	"bhraamyati"	"to roam, to err")) ; XXX
   *verbal-roots* 4)
  "Irregular verbal roots of the Fourth Conjugation in Lesson 4.")


(defvar *vocabulary4a*
  (add-verb-vocabulary-1
   '(("h.r" 	"take away")
     ("nind"	"to blame"))
   *verbal-roots* 1)
  "Vocabulary for Lesson 4. Remaining verbal roots of the First
Conjugation.")


(defvar *vocabulary4b*
  (add-verb-vocabulary-1
   '(("as"	"to throw")
     ("tu.s"	"to be pleased")
     ("na\"s"	"to perish")
     ("n.rt"	"to dance")
     ("pu.s"	"to nourish")
     ("muh"	"to faint"))
   *verbal-roots* 4)
  "Vocabulary for Lesson 4. Remaining verbal roots of the Fourth
Conjugation.")


(defvar *vocabulary4c*
  (add-noun-vocabulary-1
   '(("kuupa.h"	"well")
     ("gaja.h"	"elephant")
     ("candra.h"	"moon")
     ("praasaada.h"	"palace")
     ("h.rda.h"	"lake"))
   *noun-roots*)
  "Vocabulary for Lesson 4. Remaining Masc. nouns ending in a.")


(defvar *vocabulary4d*
  (add-noun-vocabulary-2
   '(("jiivanam" 	"life")
     ("dhanam"		"wealth")
     ("vanam"		"forest")
     ("\"siir.sam"	"head"))
   *noun-roots*)
  "Vocabulary for Lesson 4. Remaining Neut. nouns ending in a.")

#||
(form-verbal-base-1 (parse-skt "h.r"))
(form-verbal-base-4 (parse-skt "as"))
(form-verbal-base-4 (parse-skt "tu.s"))
(trie:gettrie (parse-skt "d.r\"s") *verbal-roots*)
(trie:gettrie (parse-skt "nam") *verbal-roots*)
(trie:gettrie (parse-skt "bhram") *noun-roots*)
(trie:gettrie (parse-skt "bhram") *verbal-roots*)
(decline-root  (cadr (trie:gettrie (parse-skt "bhram") *verbal-roots*)))
(decline-root  (car (trie:gettrie (parse-skt "bhram") *verbal-roots*)))
(decline-root (car (trie:gettrie (parse-skt "pu.s") *verbal-roots*)))	; XXX
(decline-root (car (trie:gettrie (parse-skt "d.r\"s") *verbal-roots*)))
||#


;;; ----------------------------------------------------------------------
;;;
;;;
(defclass skt-particle (skt-word-mixin) ())


(defvar *vocabulary4e*
  (add-vocabulary-1
   '(("ca"	"and")
     ("na"	"not"))
   *indeclinables*
   'skt-particle)
  "Vocabulary for Lesson 4. Remaining: ca and na.")


;;;
;;;
;;;
(defstruct (particle-entry (:include lexicon-entry))
  governs entry)


(defun add-particle-entry-to-lexicon
    (trie string governing &optional (parsed-form (parse-skt string))
     (entry (let ((ents
		   (get-lexicon-entry *indeclinables* parsed-form :all t)))
	      (assert ents)
	      (assert (endp (cdr ents)))
	      (car ents))))
  "Internal."
  (add-lexicon-entry trie parsed-form
		     (make-particle-entry
		      :governs governing
		      :entry entry)
		     :default-action :append))

(add-initialization "Add particles to lexicon (Lesson 4)"
   '(progn
     (add-particle-entry-to-lexicon $lexicon "ca" :nouns)
     (add-particle-entry-to-lexicon $lexicon "na" :verbs)))

#+nil
(get-lexicon-entry $lexicon (parse-skt "ca"))


;;; ----------------------------------------------------------------------
;;;
;;; The Sixth Conjugation (tudaadi)
;;;
;;; For regular verbs.The radical vowel does not take gu.na. y is NOT
;;; added to the root. The letter a is added before terminations. That
;;; a becomes aa before terminations begining with m or v and dropped
;;; before terminations begining with a. The terminations are same as
;;; the first conjugation (see no.8). 23.

(defmethod form-verbal-base-internal
    ((obj skt-verbal-root) (conjugation-class (eql 6))
     (tense (eql :present))
     (voice (eql :active))
     &optional parsed-form)
  "Internal. Protocol method."
  (declare (ignore obj conjugation-class))
  parsed-form)


(defmethod decline-verbal-root-internal
    ((obj skt-verbal-root)
     (conjugation-class (eql 6))
     (tense (eql :present))
     (voice (eql :active))
     base &optional f)
  "Internal. protocol method. Protocol method dispatched for the
Sixth conjugation: tudaadi.  Decline the verbal
root (corresponding to OBJ) in PARSED-FORM in , in the present
tense active voice in each of 3 persons and 3 numbers."
  (declare (ignore conjugation-class tense voice))
  (map-declensions base *verb-termination-table1* f #'add-termination-1))


#||
(map-declensions (parse-skt "tud") *verb-termination-table1* nil
		 #'add-termination-1)))
(map-declensions (parse-skt "hve") *verb-termination-table1* nil
		 #'add-termination-1)))
||#


(defvar *irregular-vocabulary-5a*
  (add-verb-vocabulary-2
   '(("k.rt"	"k.rntati"	"to cut")
     ("muc"	"mu\"scati"	"to release")
     ("lup"	"lumpati"	"to break")
     ("lip"	"limpati"	"to annoint")
     ("vid"	"vindati"	"to find")
     ("sic"	"si~ncati"	"to sprinkle")
     ("i.s"	"icchati"	"to wish")
     ("pracch"	"p.rcchati"	"to ask"))
   *verbal-roots* 6)
  "Irregular verbal roots of the Sixth Conjugation in Lesson 5.")


(defvar *vocabulary5a*
  (add-verb-vocabulary-1
   '(("k.r.s"		"to plough") ; XXX
     ("k.sip"		"to throw")
     ("tud"		"to strike")
     ("di\"s"		"to show")
     ("s.rj"		"to create")
     ("sp.r\"s"		"to touch")
     ("has"		"to laugh")
     ("hve"		"to call"))
   *verbal-roots* 6)
   "Vocabulary for Lesson 5. Remaining verbal roots of the Sixth
Conjugation.")


#||
(trie:gettrie (parse-skt "i.s") *verbal-roots*)
(let ((x (cons nil nil)) (y (cons nil nil)))
  (add-verb-vocabulary-1 *vocabulary5a* x 6)
  (decline-and-add-to-lexicon x y)
  (lexicon-completions y))
||#


(defvar *vocabulary5b*
  (append
   (add-noun-vocabulary-1
    '(("anila.h"	"wind")
      ("bhara.h"	"burden")
      ("\"s.rgaala.h"	"jackal")
      ("ha.msa.h"	"swan"))
    *noun-roots*)
   (add-noun-vocabulary-2		
    '(("g.rham"		"house")
      ("tiiram"		"bank")
      ("bhuu.sa.nam"	"ornament")
      ("ratnam"		"jewel"))
    *noun-roots*))
  "Vocabulary for Lesson 5. Masc. and Neut. noun roots in a.")


(defvar *vocabulary5c*
  (add-vocabulary-1		; particles governing the instrumental
   '(("k.rtam"	"enough")
     ("alam"	"enough")
     ("nama.h"	"salutation to")      ; particles governing the dative
     ("svasti"	"hail to"))
   *indeclinables* 'skt-particle)
  "Vocabulary for Lesson 5. particles.")


(defvar *vocabulary5d*
  (add-vocabulary-1
   '(("saha"	"with")
     #+nil
     ("vina"	"without"))
   *indeclinables* 'skt-preposition)
  "Prepositions governing the dative.")


(add-initialization
 "Add preposition and particle entries {Lesson 5)"
 '(progn
   (add-preposition-entry-to-lexicon $lexicon "saha" :instrumental)
   (add-preposition-entry-to-lexicon $lexicon "vina" :dative)
   (add-particle-entry-to-lexicon $lexicon "alam" :instrumental)
   (add-particle-entry-to-lexicon $lexicon "k.rtam" :instrumental)
   (add-particle-entry-to-lexicon $lexicon "nama.h" :dative)
   (add-particle-entry-to-lexicon $lexicon "svasti" :dative)))


#||
(get-lexicon-entry $lexicon (parse-skt "vina") :all t)
(segment-skt "sukhamicchaami")
(segment-skt "anilov.rk.saanlumpati")
(segment-skt "t.r.nenagajaan")
(segment-skt "jalenavinakamalaaninarohanti ")
||#



;;; ----------------------------------------------------------------------
;;;
;;;
;;; MASCULINE NOUNS IN I AND U
;;;
;;;
;;; There is great similarity between the declension of masculine
;;; nouns in i and that of masculine nouns in u: When the masculine
;;; nouns in i have i, ii, y, and e, the masculine nouns in u have u,
;;; uu, v and o respectively. 28.


(defvar *declension-table2a*
  #2a(((sktchar:|i| sktchar:|.h|)	; Nom. Sing.
       (sktchar:|ii|)			; Dual
       (sktchar:|a| sktchar:|y| sktchar:|a| sktchar:|.h|)) ; Pl.
      ((sktchar:|i| sktchar:|m|)	; Acc. Sing.
       (sktchar:|ii|)			; Dual
       (sktchar:|ii| sktchar:|n|)) 	; Pl.
      ((sktchar:|i| sktchar:|n| sktchar:|aa|) ; Inst. Sing.
       (sktchar:|i| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|) ; Dual
       (sktchar:|i| sktchar:|bh| sktchar:|i| sktchar:|.h|)) ; Pl.
      ((sktchar:|a| sktchar:|y| sktchar:|e|)	; Dative Sing.
       (sktchar:|i| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|) ; Dual
       (sktchar:|i| sktchar:|bh| sktchar:|y| sktchar:|a| sktchar:|.h|))	;Pl.
      ((sktchar:|e| sktchar:|.h|)	; Abl. Sing.
       (sktchar:|i| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|) ; Dual
       (sktchar:|i| sktchar:|bh| sktchar:|y| sktchar:|a| sktchar:|.h|))	;Pl.
      ((sktchar:|e| sktchar:|.h|)	; Gen. Sing.
       (sktchar:|y| sktchar:|o| sktchar:|.h|) ; Dual
       (sktchar:|ii| sktchar:|n| sktchar:|aa| sktchar:|m|))
      ((sktchar:|au|)			; Loc. Sing.
       (sktchar:|y| sktchar:|o| sktchar:|.h|) ; Dual
       (sktchar:|i| sktchar:|.s| sktchar:|u|)) ; Pl.
      ((sktchar:|e|)			       ; Voc. Sing.
       (sktchar:|ii|)			       ; Dual
       (sktchar:|a| sktchar:|y| sktchar:|a| sktchar:|.h|)))
  "Declension (terminations) of Masc. nouns in i. (after eliding
final i). Eg: muni. 28.2")


(defmethod decline-noun-root-internal
    ((obj skt-noun-root) (gender (eql 1)) (declension-class (eql :i))
     &optional f parsed-form)
  "Internal. Protocol method. For Masc. nouns in i."
  (assert (eq (car (last parsed-form)) 'sktchar:|i|))
  (map-declensions (butlast parsed-form) *declension-table2a* f
		   #'append-applying-internal-sandhi))


(defvar *declension-table2b*
  #2a(((sktchar:|u| sktchar:|.h|)	; Nom. Sing.
       (sktchar:|uu|)			; Dual
       (sktchar:|a| sktchar:|v| sktchar:|a| sktchar:|.h|)) ; Pl.
      ((sktchar:|u| sktchar:|m|)	; Acc. Sing.
       (sktchar:|uu|)			; Dual
       (sktchar:|uu| sktchar:|n|)) 	; Pl.
      ((sktchar:|u| sktchar:|n| sktchar:|aa|) ; Inst. Sing.
       (sktchar:|u| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|) ; Dual
       (sktchar:|u| sktchar:|bh| sktchar:|i| sktchar:|.h|)) ; Pl.
      ((sktchar:|a| sktchar:|v| sktchar:|e|)	; Dative Sing.
       (sktchar:|u| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|) ; Dual
       (sktchar:|u| sktchar:|bh| sktchar:|y| sktchar:|a| sktchar:|.h|))	;Pl.
      ((sktchar:|o| sktchar:|.h|)	; Abl. Sing.
       (sktchar:|u| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|) ; Dual
       (sktchar:|u| sktchar:|bh| sktchar:|y| sktchar:|a| sktchar:|.h|))	;Pl.
      ((sktchar:|o| sktchar:|.h|)	; Gen. Sing.
       (sktchar:|v| sktchar:|o| sktchar:|.h|) ; Dual
       (sktchar:|uu| sktchar:|n| sktchar:|aa| sktchar:|m|))
      ((sktchar:|au|)			; Loc. Sing.
       (sktchar:|v| sktchar:|o| sktchar:|.h|) ; Dual
       (sktchar:|u| sktchar:|.s| sktchar:|u|)) ; Pl.
      ((sktchar:|o|)			       ; Voc. Sing.
       (sktchar:|uu|)			       ; Dual
       (sktchar:|a| sktchar:|v| sktchar:|a| sktchar:|.h|)))
  "Declension (terminations) of Masc. nouns in u. (after eliding
final i). Eg: \"si\"su. 28.2")


(defmethod decline-noun-root-internal
    ((obj skt-noun-root) (gender (eql 1)) (declension-class (eql :u))
     &optional f parsed-form)
  "Internal. Protocol method. For Masc. nouns in u."
  (assert (eq (car (last parsed-form)) 'sktchar:|u|))
  (map-declensions (butlast parsed-form) *declension-table2b* f
		   #'append-applying-internal-sandhi))



(defun add-noun-vocabulary-3 (vocab trie)
  "VOCAB is a list of (NOUN meaning) where NOUN is Masc.and ends
in i. NOUN is specified in Nom. Sing.  Adds the NOUN to the
lexicon TRIE setting the value to a freshly instanciated
SKT-NOUN-ROOT object. Returns VOCAB."
  (loop for (root doc) in vocab do
	(etypecase root (string))
	(assert (= (search "i.h" root :from-end t)
		   (- (length root) 3)))
	(setq root (subseq root 0 (- (length root) 2)))
	(let ((word (parse-skt root)))
	  (add-lexicon-entry
	   trie word
	   (make-instance 'skt-noun-root
			  :string root
			  :documentation doc
			  :declension-class :i
			  :gender 1))))
  vocab)

(defun add-noun-vocabulary-4 (vocab trie)
  "VOCAB is a list of (NOUN meaning) where NOUN is Masc.and ends
in u. NOUN is specified in Nom. Sing.  Adds the NOUN to the
lexicon TRIE setting the value to a freshly instanciated
SKT-NOUN-ROOT object. Returns VOCAB."
  (loop for (root doc) in vocab do
	(etypecase root (string))
	(assert (= (search "u.h" root :from-end t)
		   (- (length root) 3)))
	(setq root (subseq root 0 (- (length root) 2)))
	(let ((word (parse-skt root)))
	  (add-lexicon-entry
	   trie word
	   (make-instance 'skt-noun-root
			  :string root
			  :documentation doc
			  :declension-class :u
			  :gender 1))))
  vocab)

(defvar *vocabulary6a*
  (append
   (add-noun-vocabulary-3
    '(("agni.h"		"fire")
      ("atithi.h"	"guest")
      ("aari.h"		"enemy")
      ("kavi.h"		"poet")
      ("giri.h"		"mountain")
      ("muni.h"		"sage")
      ("ravi.h"		"sun")
      ("raa\"si.h"	"heap")
      ("udadhi.h"	"ocean")
      ("kali.h"		"quarrel"))
    *noun-roots*)
   (add-noun-vocabulary-4
    '(("indu.h"		"moon")
      ("i.su.h"		"arrow")
      ("guru.h"		"teacher")
      ("taru.h"		"tree")
      ("para\"su.h"	"axe")
      ("pa\"su.h"	"beast")
      ("bandhu.h"	"friend")
      ("baahu.h"	"arm")
      ("bindu.h"	"drop")
      ("\"si\"su.h"	"baby"))
    *noun-roots*))
  "Vocabulary for Lesson 6. Masc. Nouns in i and u.")


(defvar *vocabulary6b*
  (add-vocabulary-1
   '(("praak"		"before, to the east")
     ("puurvam"		"before")
     ("anantaram"	"after")
     ("aa"		"until, upto")
     ("prabh.rti"	"since")
     ("bahi.h"		"outside")
     (".rte"		"except, without")
     #+nil
     ("vina"		"without"))
   *indeclinables* 'skt-preposition)
  "Vocabulary for Lesson 6. Prepositions governing the ablative.")


(defvar *vocabulary6c*
  (add-vocabulary-1
   '(("upari"		"before")
     ("adha.h"		"below")
     ("purata.h"	"in front of")
     ("pa\"scaat"	"behind")
     ("agre"		"in the prescence of")
     ("parata.h"	"beyond")
     ("samak.sam"	"in the prescence of")
     ("k.rte"		"for the sake of"))
   *indeclinables* 'skt-preposition)
  "Vocabulary for Lesson 6. Prepositions governing the dative.")


(add-initialization
 "Add preposition entries (Lesson 6)"
 '(progn
   (loop for (x meaning) in *vocabulary6b*
	 do (add-preposition-entry-to-lexicon $lexicon x :ablative))
   (add-preposition-entry-to-lexicon $lexicon "vina" :ablative)
   (loop for (x meaning) in *vocabulary6c*
	 do (add-preposition-entry-to-lexicon $lexicon x :genitive))))


#||
(get-lexicon-entry $lexicon (parse-skt "agre")))
(decline-root (car (trie:gettrie (parse-skt "muni") *noun-roots*)))
(decline-root (car (trie:gettrie (parse-skt "\"si\"su") *noun-roots*)))
(decline-root (car (trie:gettrie (parse-skt "g.rha") *noun-roots*)))
(let ((x (list nil))
      (y (list nil)))
  (add-noun-vocabulary-3 *vocabulary6a* x)
  (add-noun-vocabulary-4 *vocabulary6b* x)
  (decline-and-add-to-lexicon x y)
  (trie::trie-completions y))
(segment-skt "g.rhasyapa\"scaatbandhava.hsiidanti")
(segment-skt "meghaanaamupariravi\"scalati")
||#




;;; ----------------------------------------------------------------------
;;;
;;; The Tenth Conjugation (curadi)
;;;
;;; Formation of the base:
;;;
;;; A short medial vowel takes gu.na. A final vowel takes v.rddhi.  ay
;;; is added to the root. The letter a is added before
;;; terminations. That a becomes aa before terminations begining with
;;; m or v. That a is dropped before terminations begining with a. The
;;; terminations are the same as those of the first conjugation. (See
;;; No. 8). 32.
;;;

(defun form-verbal-base-10 (root)
  "Tenth conjugation: curaadi. For regular verbs. Short medial
vowel takes gu.na. Finalvowel takes v.rddhi. 32."
  (let ((line root) c rest ret (term (list 'sktchar:|y| 'sktchar:|a|)))
    (loop (cond ((endp line) (return (nreverse (nconc term ret))))
		((setq c (car line) rest (cdr line))
		 (cond ((and (get c :consonant)	; short medial vowel check
			     (get (car rest) :vowel)
			     (get (car rest) :short)
			     (cadr rest) (get (cadr rest) :consonant)
			     ;; vowel deemed long if follwed by conjunct
			     (or (endp (cddr rest))
				 (not (get (caddr rest) :consonant))))
			(setq ret (nreconc (form-gu.na (car rest))
					   (cons c ret))
			      line (cddr line)))
		       ((setq ret (cons c ret) line (cdr line)))))
		((get c :vowel) (return (nreconc
					 ret (nconc (form-v.rddhi c)
						    (nreverse term)))))
		((return (nreverse (nconc term (cons c ret)))))))  ))

#||
(form-verbal-base-10 (parse-skt "cur"))
(form-verbal-base-10 (parse-skt "dh.r"))
(form-verbal-base-10 (parse-skt "bhak.s"))
||#


(defmethod form-verbal-base-internal
    ((obj skt-verbal-root) (conjugation-class (eql 10))
     (tense (eql :present))
     (voice (eql :active))
     &optional parsed-form)
  "Internal. Protocol method."
  (declare (ignore obj conjugation-class))
  (form-verbal-base-10 parsed-form))


(defmethod decline-verbal-root-internal
    ((obj skt-verbal-root)
     (conjugation-class (eql 10))
     (tense (eql :present))
     (voice (eql :active))
     base &optional f)
  "Internal. Protocol method dispatched for the Tenth
conjugation: curaadi. Decline the verbal root (corresponding to
OBJ) in PARSED-FORM in the present tense active voice in each of
3 persons and 3 numbers."
  (map-declensions base *verb-termination-table1* f #'add-termination-1))



;;;
;;;
(defvar *irregular-vocabulary-7a*
  (add-verb-vocabulary-2
   '(("sp.rh"	"sp.rhayati"	"to desire") ; + dative
     ("chad"	"chaadyati"	"to conquer"))
   *verbal-roots* 10)
  "Irregular verbs of the tenth conjugation. (Lesson 7) 33.")


(defvar *irregular-vocabulary-7b*
  (add-vocabulary-1
   '(("adhi"	"near, unto")
     ("apa" 	"away from")
     ("ava" 	"down")
     ("ud"  	"up, forth")
     ("ni"  	"under")
     ("nis" 	"away, out")
     ("pari" 	"round, about")
     ("pra"  	"forward")
     ("prati" 	"toward")
     ("vi" 	"apart")
     ("sam"	"k.sip")
     ;; From `Recapitulation:' prepositions and adverbs
     ("atra"	"here")
     ("tatra"	"there")
     ("eva"	"just, only")
     ("adya"	"today")
     ("adhuna"	"now")
     ("iva"	"like")
     ("evam"	"thus")
     ("api"	"even")
     ("nakadaapi"	"never")
     ("sada"	"always")
     )
   *indeclinables*
   'skt-preposition)
  "(Remaining) prepositions mostly in use. (Lesson 7)")

;;;
;;;
;;;
(add-initialization
 "Add adverbs (Lesson 7)"
 '(progn
   (loop for (x meaning) in *irregular-vocabulary-7b*
	 do (add-preposition-entry-to-lexicon $lexicon x :verb))
   (loop for x in '("ati" "anu" "abhi" "upa")
	 do (add-preposition-entry-to-lexicon $lexicon x :verb))))


(defvar *vocabulary7a*
  (add-verb-vocabulary-1
   '(("kath"	"to tell")
     ("k.sal"	"to wash")
     ("ga.n"	"to count")
     ("ghu.s"	"to proclaim")
     ("cint"	"to worry")
     ("cur"	"to steal")
     ("da.n.d"	"to punish")
     ("dh.r"	"to owe")
     ("paal"	"to protect")
     ("pii.d"	"to oppress")
     ("puuj"	"to adore")
     ("bhak.s"	"to eat")
     ("bhuu.s"	"to adorn")
     ("rac"	"to arrange")
     ("saantv"	"to console"))
   *verbal-roots* 10)
  "Vocabulary for lesson 7. Verbs of the Tenth Conjugation.")

(defvar *vocabulary7b*
  (append
   (add-noun-vocabulary-1
    '(("ii\"svara.h"	"God")
      ("gu.na.h"	"virtue")
      ("loka.h"		"world")
      ("vinaya.h"	"modesty")
      ("janaka.h"	"father")
      ("aaka\"sa.h"	"sky")
      ("aagama.h"	"arrival")
      ("prasaada.h"	"favour")
      ;;;
      ("vaya.h"		"wind")
      ("m.rtya.h"	"death"))
    *noun-roots*)
   (add-noun-vocabulary-2
    '(("aarogyam"	"health")
      ("kaavyam"	"poem")
      ("daivam"		"fate")
      ("balam"		"strength")
      ("maa.msam"	"meat")
      ("mitram"		"friend")
      ("vacanam"	"saying")
      ("saundaryam"	"beauty")
      ("halam"		"plough"))
    *noun-roots*)
   (add-noun-vocabulary-3
    '(("ali.h"		"bee")
      ("kapi.h"		"monkey")
      ("n.rpati.h"	"king")
      (".r.si.h"	"seer")
      ("dhvani.h"	"sound")
      ("nidhi.h"	"treasure")
      ("paa.ni.h"	"hand")
      ("vidhi.h"	"fate")
      ("ra\"smi.h"	"ray"))
    *noun-roots*)
   (add-noun-vocabulary-4
    '(("prabhu.h"	"lord, master")
      ("\"satru.h"	"enemy")
      ("hetu.h"		"cause")
      ("saadhu.h"	"honest man")
      ("raghu.h"	"Raghu"))
    *noun-roots*))
  "Vocabulary for Chapter 7. Nouns in `Recapitulation'.")



;;; ----------------------------------------------------------------------
;;;
;;; FEMININE NOUNS IN aa AND ii. 38.
;;;
;;;
(defvar *declension-table3a*
  #2a(((sktchar:|aa|)			; Nom. Sing.
       (sktchar:|e|)			; Dual
       (sktchar:|aa| sktchar:|.h|))	; Pl.
      ((sktchar:|aa| sktchar:|m|)	; Acc. Sing.
       (sktchar:|e|)			; Dual
       (sktchar:|aa| sktchar:|.h|))	; Pl.
      ((sktchar:|a| sktchar:|y| sktchar:|a|) ; Inst. Sing.
       (sktchar:|aa| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|aa| sktchar:|bh| sktchar:|i| sktchar:|.h|))
      ((sktchar:|aa| sktchar:|y| sktchar:|ai|) ; Dat.
       (sktchar:|aa| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|aa| sktchar:|bh| sktchar:|y| sktchar:|a| sktchar:|.h|))
      ((sktchar:|aa| sktchar:|y| sktchar:|aa| sktchar:|.h|) ; Abl.
       (sktchar:|aa| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|aa| sktchar:|bh| sktchar:|y| sktchar:|a| sktchar:|.h|))
      ((sktchar:|aa| sktchar:|y| sktchar:|aa| sktchar:|.h|) ; Gen. Sing.
       (sktchar:|a| sktchar:|y| sktchar:|o| sktchar:|.h|)
       (sktchar:|aa| sktchar:|n| sktchar:|aa| sktchar:|m|))
      ((sktchar:|aa| sktchar:|y| sktchar:|aa| sktchar:|m|) ; Loc.
       (sktchar:|a| sktchar:|y| sktchar:|o| sktchar:|.h|)
       (sktchar:|aa| sktchar:|s| sktchar:|u|))
      ((sktchar:|e|) (sktchar:|e|) (sktchar:|aa| sktchar:|.h|)))
  "Declension (terminations) of Fem. nouns in aa. (after eliding
final aa). Eg: lataa. 38.")

(defmethod decline-noun-root-internal
    ((obj skt-noun-root) (gender (eql 3)) (declension-class (eql :aa))
     &optional f parsed-form)
  "Internal. Protocol method. For Fem. nouns in aa."
  (assert (eq (car (last parsed-form)) 'sktchar:|aa|))
  (map-declensions (butlast parsed-form) *declension-table3a* f
		   #'append-applying-internal-sandhi))

(defvar *declension-table3b*
  #2a(((sktchar:|ii|)			; Nom. Sing.
       (sktchar:|y| sktchar:|au|)	; Dual
       (sktchar:|a| sktchar:|y| sktchar:|a| sktchar:|.h|))
      ((sktchar:|ii| sktchar:|m|)	; Acc. Sing.
       (sktchar:|y| sktchar:|au|)	; Dual
       (sktchar:|a| sktchar:|ii| sktchar:|.h|))	; Pl.
      ((sktchar:|y| sktchar:|aa|)		; Inst. Sing.
       (sktchar:|ii| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|ii| sktchar:|bh| sktchar:|i| sktchar:|.h|))
      ((sktchar:|y| sktchar:|ai|)	; Dat.
       (sktchar:|ii| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|ii| sktchar:|bh| sktchar:|y| sktchar:|a| sktchar:|.h|))
      ((sktchar:|y| sktchar:|aa| sktchar:|.h|) ; Abl.
       (sktchar:|ii| sktchar:|bh| sktchar:|y| sktchar:|aa| sktchar:|m|)
       (sktchar:|ii| sktchar:|bh| sktchar:|y| sktchar:|a| sktchar:|.h|))
      ((sktchar:|aa| sktchar:|y| sktchar:|.h|) ; Gen. Sing.
       (sktchar:|y| sktchar:|au| sktchar:|.h|)
       (sktchar:|ii| sktchar:|n| sktchar:|aa| sktchar:|m|))
      ((sktchar:|y| sktchar:|aa| sktchar:|m|) ; Loc.
       (sktchar:|y| sktchar:|o| sktchar:|.h|)
       (sktchar:|ii| sktchar:|.s| sktchar:|u|))
      ((sktchar:|i|)			; Voc.
       (sktchar:|y| sktchar:|au|)
       (sktchar:|y| sktchar:|a| sktchar:|.h|)))
  "Declension (terminations) of Fem. nouns in ii. (after eliding
final ii). Eg: nadii. 38.")


(defmethod decline-noun-root-internal
    ((obj skt-noun-root) (gender (eql 3)) (declension-class (eql :ii))
     &optional f parsed-form)
  "Internal. Protocol method. For Fem. nouns in ii."
  (assert (eq (car (last parsed-form)) 'sktchar:|ii|))
  (map-declensions (butlast parsed-form) *declension-table3b* f
		   #'append-applying-internal-sandhi))





;;;
;;; Present tense middle voice. 39.
;;;
;;; The verbal base is formed according to the rules for the active
;;; voice of the first fourth, sixth and tenth conjugation.
;;; The terminations alone are different.

(defvar *verb-termination-table2*
  #2a(((sktchar:|e|)
       (sktchar:|v| sktchar:|a| sktchar:|h| sktchar:|e|)
       (sktchar:|m| sktchar:|a| sktchar:|h| sktchar:|e|))
      ((sktchar:|s| sktchar:|e|)
       (sktchar:|ii| sktchar:|th| sktchar:|e|)
       (sktchar:|dh| sktchar:|v| sktchar:|e|))
      ((sktchar:|t| sktchar:|e|)
       (sktchar:|ii| sktchar:|t| sktchar:|e|)
       (sktchar:|a| sktchar:|n| sktchar:|t| sktchar:|e|)))
  "Terminations of the present tense middle voice
aatmanepadii. (No. 40)")


(defun add-termination-2 (base termination)
  "Internal. Adding terminations of the present tense middle
voice. The vowel a is added before terminations. If the
termination begins with a m or a v that a becomes aa. That a is
dropped before terminations begining with an a or an e. 40."
  (case (car termination)
    ((sktchar:|a| sktchar:|e|)
     (append-applying-internal-sandhi base termination))
    ((sktchar:|m| sktchar:|v|)
     (append-applying-internal-sandhi base '(sktchar:|aa|) termination))
    (otherwise
     (append-applying-internal-sandhi base '(sktchar:|a|) termination))))


(defmethod form-verbal-base-internal
    ((obj skt-verbal-root)
     conjugation-class
     (tense (eql :present))
     (voice (eql :middle))
     &optional parsed-form)
  "Internal. Protocol method."
  (ecase conjugation-class
    ((1 4 6 10)
     (form-verbal-base-internal obj conjugation-class tense :active
				parsed-form))))


(defmethod decline-verbal-root-internal
    ((obj skt-verbal-root)
     conjugation-class
     (tense (eql :present))
     (voice (eql :middle))
     base &optional f)
  "Internal. Protocol method. Decline the verbal
root (corresponding to OBJ) in PARSED-FORM in the present tense
middle voice in each of 3 persons and 3 numbers."
  (ecase conjugation-class
    ((1 4 6 10)
     (map-declensions base *verb-termination-table2* f #'add-termination-2))))


(defun add-noun-vocabulary-5 (vocab trie)
  "VOCAB is a list of (NOUN meaning) where NOUN is feminine and ending in aa.
NOUN is specified in Nom. Sing. form (identical to the root).
Adds the NOUN to the lexicon TRIE setting the value to a freshly
instanciated SKT-NOUN-ROOT object. Returns VOCAB."
  (loop for (root doc) in vocab do
	(etypecase root (string))
	(assert (= (search "aa" root :from-end t)
		   (- (length root) 2)))
	(let ((word (parse-skt root)))
	  (add-lexicon-entry
	   trie word
	   (make-instance 'skt-noun-root
			  :string root
			  :documentation doc
			  :declension-class :aa
			  :gender 3))))
  vocab)


(defun add-noun-vocabulary-6 (vocab trie)
  "VOCAB is a list of (NOUN meaning) where NOUN is feminine and ending in ii.
NOUN is specified in Nom. Sing. form (identical to the root).
Adds the NOUN to the lexicon TRIE setting the value to a freshly
instanciated SKT-NOUN-ROOT object. Returns VOCAB."
  (loop for (root doc) in vocab do
	(etypecase root (string))
	(assert (= (search "ii" root :from-end t)
		   (- (length root) 2)))
	(let ((word (parse-skt root)))
	  (add-lexicon-entry
	   trie word
	   (make-instance 'skt-noun-root
			  :string root
			  :documentation doc
			  :declension-class :ii
			  :gender 3))))
  vocab)

(defvar *vocabulary8a*
  (append
   (add-noun-vocabulary-5
    '(("ga.ngaa"	"the Ganges")
      ("rambhaa" 	"plantain tree")
      ("mudraa"		"seal")
      ("\"sobhaa" 	"splendour")
      ("bhaaryaa"	"wife")
      ("chaayaa"	"shade")
      ("sandhyaa"	"twilight")
      ("bhaa.saa"	"speech")
      ("sabhaa"		"assembly")
      ("rekhaa"		"line")
      ("maalaa"		"garland")
      ("lataa"		"creeper")
      ("baalikaa"	"girl"))
    *noun-roots*)
   (add-noun-vocabulary-6
    '(("nagarii"	"town")
      ("nadii"		"river")
      ("dhatrii"	"nurse")
      ("p.rthivii"	"earth")
      ("vaa.nii"	"voice")
      ("raaj~nii"	"queen")
      ("si.mhii"	"lioness")
      ("jananii"	"mother")
      ("narii"		"woman")
      ("patnii"		"wife")
      ("bhaginii"	"sister")
      ("g.rhi.nii"	"housewife")
      ("\"sarvarii"	"night"))
    *noun-roots*))
  "Vocabulary for Lesson 8. Feminine nouns in aa and ii.")

#||
(decline-root (car (trie:gettrie (parse-skt "lataa") *noun-roots*)))
(decline-root (car (trie:gettrie (parse-skt "g.rhi.nii") *noun-roots*)))
||#


(defvar *vocabulary8b*
  (append
   (add-verb-vocabulary-1
    '(("ik.s"	"to see")
      ("kamp"	"to tremble")
      ("gaah"	"to dive")
      ("ruc"	"to please")	     ; XXX special construction, No.44
      (".dii"	"to fly")
      )
    *verbal-roots* 1 :middle)
   (add-verb-vocabulary-1
    '(("jan"	"to be born")
      (".dii"	"to fly")
      ("man"	"to think")
      ("yudh"	"to fight"))
    *verbal-roots* 4 :middle)
   (add-verb-vocabulary-1
    '(("mantr"	"to consult")
      ("m.rg"	"to search"))
    *verbal-roots* 10 :middle)))


#||
(decline-root (car (trie:gettrie (parse-skt "kamp") *verbal-roots*)))
(decline-root (car (trie:gettrie (parse-skt ".dii") *verbal-roots*)))
(decline-root (cadr (trie:gettrie (parse-skt ".dii") *verbal-roots*)))
(segment-skt "ii\"svarasyaprasaadenanaraaaarogyamadhigacchanti")
||#

;;;-sandhi rules for dual+e.
;;;
;;;-preposition+verb table
;;;
;;;-better support for multiple conjugations?
;;;
;;;-refactor add-vocabulary mess.
;;;
;;;-infer root
;;;
#+nil
(defvar $lexicon-intialized (progn (run-initializations) t))
'#:EOF