;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Mon Apr 02 08:57:48 2007 +0530 <enometh@net.meer>
;;;   Time-stamp: <2007-04-06 22:24:29 madhu>
;;;   Bugs-To: <enometh@net.meer>
;;;   Status: Experimental. Do not redistribute.
;;;   Copyright (C) 2007 Madhu. All rights reserved.
;;;
(defpackage "REE-1-1" (:use "CL"))
(in-package "REE-1-1")

(defvar *csx-translation-table-1*
  '(
    ("long a"                  #\à             224	   )
    ("long A"                  #\â             226	   )
    ("long i"                  #\ã             227	   )
    ("long I"                  #\ä             228	   )
    ("long u"                  #\å             229	   )
    ("long U"                  #\æ             230	   )
    ("vocalic r"               #\ç             231	   )
    ("vocalic R"               #\è             232	   )
    ("long vocalic r"          #\é             233	   )
    ("vocalic l"               #\ë             235	   )
    ("long vocalic l"          #\í             237	   )
    ("velar n"                 #\ï             239	   )
    ("velar N"                 #\ð             240	   )
    ("palatal n"               #\¤             164	   )
    ("palatal N"               #\¥             165	   )
    ("retroflex t"             #\ñ             241	   )
    ("retroflex T"             #\ò             242	   )
    ("retroflex d"             #\ó             243	   )
    ("retroflex D"             #\ô             244	   )
    ("retroflex n"             #\õ             245	   )
    ("retroflex N"             #\ö             246	   )
    ("palatal s"               #\÷             247	   )
    ("palatal S"               #\ø             248	   )
    ("retroflex s"             #\ù             249	   )
    ("retroflex S"             #\ú             250	   )
    ("anusvara"                #\ü             252	   )
    ("anusvara (overdot)"      #\§             167	   )
    ("capital anusvara"        #\ý             253	   )
    ("visarga"                 #\þ             254	   )
    ("(capital visarga)"       nil             255	   )))

(defvar *ree-translation-table-1*
  '(
    ("long a"                  #\Ã             195		)
    ("long A"                  #\ù             249		)
    ("long i"                  #\Å             197		)
    ("long I"                  #\ý             253		)
    ("long u"                  #\Æ             198		)
    ("long U"                  #\ô             244		)
    ("vocalic r"               #\­             173		)
    ("vocalic R"               #\ã             227		)
    ("long vocalic r"          #\Ì             204		)
    ("vocalic l"               #\Ê             202		)
    ("long vocalic l"          #\Ë             203		)
    ("velar n"                 #\Ç             199		)
    ("velar N"                 #\§             167		)
    ("palatal n"               #\¤             164		)
    ("palatal N"               #\¥             165		)
    ("retroflex t"             #\Â             194		)
    ("retroflex T"             #\è             232		)
    ("retroflex d"             #\¬             172		)
    ("retroflex D"             #\Ö             214		)
    ("retroflex n"             #\ï             239		)
    ("retroflex N"             #\×             215		)
    ("palatal s"               #\Ó             211		)
    ("palatal S"               #\Á             193		)
    ("retroflex s"             #\«             171		)
    ("retroflex S"             #\å             229		)
    ("anusvara"                #\æ             230		)
    ("capital anusvara"        #\õ             245		)
    ("visarga"                 #\÷             247		)
    ("capital visarga"         #\ê             234		))
  "Ronald E. Emmerick's encoding, used in GRETIL texts")

(defvar *skt-translation-table-1*
  '(
    ("long a"                  "aa"		)
    ("long A"                  nil		)
    ("long i"                  "ii"		)
    ("long I"                  nil		)
    ("long u"                  "uu"		)
    ("long U"                  nil		)
    ("vocalic r"               ".r"		)
    ("vocalic R"               nil		)
    ("long vocalic r"          ".r.r"		)
    ("vocalic l"               ".l"		)
    ("long vocalic l"          ".l.l"		)
    ("velar n"                 "\"n"		)
    ("velar N"                 nil		)
    ("palatal n"               "~n"		)
    ("palatal N"               nil		)
    ("retroflex t"             ".t"		)
    ("retroflex T"             nil		)
    ("retroflex d"             ".d"		)
    ("retroflex D"             nil		)
    ("retroflex n"             ".n"		)
    ("retroflex N"             nil		)
    ("palatal s"               "\"s"		)
    ("palatal S"               nil		)
    ("retroflex s"             ".s"		)
    ("retroflex S"             nil		)
    ("anusvara"                ".m"		)
    ("capital anusvara"        nil		)
    ("visarga"                 ".h"		)
    ("capital visarga"         nil		))
  "SKT Transliteration scheme (wikner).")

;; lookup tables are arrays of length 256.

(defun initialize-lookup-table-pass-through (table)
  (flet ((self-insert-char (char)
	   (setf (aref table (char-code char)) char)))
    (loop for c from 97 to 122 ;[a-z]
	  do (setf (aref table c) (code-char c)))
    (self-insert-char #\Space)
    (setf (aref table (char-code #\Newline)) #\Newline)
    (loop for i in (list #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0 #\. #\[ #\] )
	  do (self-insert-char i))))

;;;
;;;
(define-generic error-context-string (condition))

(define-condition unknown-character ()
  ((c :initarg :char :reader unknown-character-character)
   (d :initarg :code :reader unknown-character-code))
  (:report (lambda (condition stream)
	     (format stream "Unknown Character ~C (code ~D)~@[~&~A~]"
		     (unknown-character-character condition)
		     (unknown-character-code condition)
		     (error-context-string condition)))))

(defmethod error-context-string ((condtion unknown-character))
  (declare (special $idx $buf))
  (cond ((and (boundp '$idx) (boundp '$buf))
	 (subseq $buf (max (- $idx 10) 0) (min (+ 100 $idx) (length $buf))))))

(defun xlate-character (character lookup-table)
  "Returns NIL or a translation."
  (prog (return *current-condition* code xlation)
     (labels ((handle-condition (condition)
		(setq *current-condition* condition))
	      (unknown-char ()
		(unknown-character-character *current-condition*))
	      (unknown-char-code ()
		(unknown-character-code *current-condition*))
	      (test-function (condition)
		;;#+cmu(declare (ignore condition))
		#-cmu			; usual cmu+slime fuckup
		(eql condition *current-condition*)
		#+cmu t
		)
	      (xlate-once (x)
		(setq return x)
		(go return))
	      (report-xlate-once (stream)
		(format stream "Return something else this once"))
	      (xlate-always (x)
		(setq return x)
		(assert (not (aref lookup-table  (unknown-char-code))))
		(setf (aref lookup-table  (unknown-char-code)) x)
		(go return))
	      (report-xlate-always (stream)
		(format stream "Return something else and permanently modify xlate table."))
	      (xlate-interactive ()
		(format *terminal-io* "~&~&Enter lisp form: ")
		(multiple-value-list (read)))
	      (literal-once ()
		(setq return (unknown-char))
		(go return))
	      (report-literal-once (stream)
		(format stream "Return ~C just this once."
			(unknown-char)))
	      (literal-always ()
		(setq return (unknown-char))
		(assert (not (aref lookup-table (unknown-char-code))))
		(setf (aref lookup-table (unknown-char-code)) return)
		(go return))
	      (report-literal-always (stream)
		(format stream
			"Return ~C, adding it permanently to the allowed list."
			(unknown-char)))
	      (ignore-once ()
		(go return))
	      (report-ignore-once (stream)
		(format stream "Ignore ~C just this once."
			(unknown-char)))
	      (ignore-always ()
		(assert (not (eq (aref lookup-table (unknown-char-code))
			      :EATME)))
		(setf (aref lookup-table (unknown-char-code)) :EATME)
		(go return))
	      (report-ignore-always (stream)
		(format stream
			"Ignore ~C, adding it permanently to the ignored list."
			(unknown-char))))
       (restart-bind ((literal-once #'literal-once
		       :report-function #'report-literal-once
		       :test-function #'test-function)
		      (literal-always #'literal-always
		       :report-function #'report-literal-always
		       :test-function #'test-function)
		      (ignore-once #'ignore-once
		       :report-function #'report-ignore-once
		       :test-function #'test-function)
		      (ignore-always #'ignore-always
		       :report-function #'report-ignore-always
		       :test-function #'test-function)
		      (xlate-once #'xlate-once
		       :report-function #'report-xlate-once
		       :test-function #'test-function
		       :interactive-function #'xlate-interactive)
		      (xlate-always #'xlate-always
		       :report-function #'report-xlate-always
		       :test-function #'test-function
		       :interactive-function #'xlate-interactive))
	 (handler-bind ((unknown-character #'handle-condition))
	   (etypecase character		; XXX INITIALIZE
	     (character (setq code (char-code character)))
	     ((integer 0 256) (setq code character
				    character (code-char character))))
	   (cond ((eq (setq xlation (aref lookup-table code)) :EATME)
		  (return nil))
		 (xlation
		  ;(etypecase xlation ((string character)))
		  (return xlation))
		 (t (error 'unknown-character :char character :code code))))))
     return (if return (return return))))

(defun translate-string-using-lookup-table (string lookup-table &key
					    (stream *standard-output*)
					    (start 0) end)
  (declare (special $idx))
  (loop for idx #+nil $idx from start below (or end (length string))
	for c = (aref string (setq $idx idx))
	;; for c = (aref string $idx) ; XXX
	for translated = (xlate-character c lookup-table)
	do (etypecase translated
	     (string (write-string translated stream))
	     (character (write-char translated stream))
	     (null))))