;;; ccl programs

;;; register assignment
;;
;; r0 temporary
;; r1 high
;; r2 low
;; r3 flags
;; r4 indent level
;; r5 loop counter

(require 'ccl)

(defconst odccl-charset-id-japanese-jisx0208
  (if (boundp 'lc-jp) lc-jp (charset-id 'japanese-jisx0208)))
(defconst odccl-charset-id-latin-iso8859-1
  (if (boundp 'lc-ltn1) lc-ltn1 (charset-id 'latin-iso8859-1)))

(defconst odccl-self
  '((write r1 r2)))

(defconst odccl-flags
  '((col . 1) (eop . 2) (bold . 4) (inv . 8)
    (item . 16) (ret . 32)
    (eop2 . 66)))			; = 64 + 2

(defun odccl-set (key)
  (let ((bit (cdr (assq key odccl-flags))))
    (if bit
	(` (r3 |= (, bit)))
      (error "odccl-set: %s not found" key))))

(defun odccl-reset (key)
  (let ((bit (cdr (assq key odccl-flags))))
    (if bit
	(` (r3 &= (, (- 32767 bit))))
      (error "odccl-reset: %s not found" key))))

(defun odccl-check (key)
  (let ((bit (cdr (assq key odccl-flags))))
    (if bit
	(` (r3 & (, bit)))
      (error "odccl-check: %s not found" key))))

(defconst odccl-prtbcd
  '((read r2)
    (r0 = (r2 >> 4))
    (r0 += ?0)
    (write r0)
    (r0 = (r2 & 15))
    (r0 += ?0)
    (write r0)))

(defun odccl-prtbcd-loop (n)
  (` ((r5 = (, n))
      (loop
       (if r5
	   ((r5 -= 1)
	    (,@ odccl-prtbcd)
	    (repeat)))))))

(defun odccl-prthex (reg)
  (` ("#x"
      (r0 = ((, reg) >> 4))
      (if (r0 < 10)
	  (r0 += ?0)
	(r0 += (, (- ?a 10))))
      (write r0)
      (r0 = ((, reg) & 15))
      (if (r0 < 10)
	  (r0 += ?0)
	(r0 += (, (- ?a 10))))
      (write r0))))

(defconst odccl-jis-r2
  (` ((write (, odccl-charset-id-japanese-jisx0208))
      (r0 = (r1 | 128))
      (write r0)
      (r0 = (r2 | 128))
      (write-repeat r0))))

(defconst odccl-jis
  (` ((read r2)
      (write (, odccl-charset-id-japanese-jisx0208))
      (r0 = (r1 | 128))
      (write r0)
      (r0 = (r2 | 128))
      (write-repeat r0))))

(defconst odccl-start-bold
  (` ((, (odccl-set 'bold))
      (if (, (odccl-check 'inv))
	  "\e[1;7m"
	"\e[1m"))))

(defconst odccl-end-bold
  (` ((, (odccl-reset 'bold))
      (if (, (odccl-check 'inv))
	  "\e[7m"
	"\e[0m"))))

(defconst odccl-start-inv
  (` ((, (odccl-set 'inv))
      (if (, (odccl-check 'bold))
	  "\e[1;7m"
	"\e[7m"))))

(defconst odccl-end-inv
  (` ((, (odccl-reset 'inv))
      (if (, (odccl-check 'bold))
	  "\e[1m"
	"\e[0m"))))

(defconst odccl-indent
  '((r0 = (r4 >> 3))
    (loop
     (if r0
	 ((r0 -= 1)
	  (write-repeat "        "))))
    (branch (r4 & 7)
	    nil
	    " "
	    "  "
	    "   "
	    "    "
	    "     "
	    "      "
	    "       ")))

(defun odccl-lookup-capfunc (key table)
  (let ((number (car (rassq key table))))
    (if number
	(format "\x1e%d\x1e" number)
      (error "odccl-lookup-capfunc: capfunc %s not found" 'key))))

(defun odccl-select (table &optional key)
  (mapcar
   (function
    (lambda (element)
      (cond ((not (vectorp element)))
	    ((or (and (not (eq key 'sc)) (not (eq key 'x)))
		 (= (length element) 1))
	     (setq element (aref element 0)))
	    ((or (not (eq key 'x)) (= (length element) 2))
	     (setq element (aref element 1)))
	    (t
	     (setq element (aref element 2))))
      (if (stringp element)
	  (if (and (string= element (char-to-string (string-to-char element)))
		   (if (fboundp 'cmpcharp)
		       (not (cmpcharp (string-to-char element)))))
	      (list 'write-repeat (string-to-char element))
	    (list 'write-repeat element))
	element)))
   table))

(defun odccl-make-low-tables (low-alist)
  (let ((low-table (make-vector 39 nil))
	(low-table1 (make-vector 129 nil)))
    (while low-alist
      (let ((pair (car low-alist)))
	(cond ((< (car pair) 38)
	       (aset low-table (car pair) (cdr pair)))
	      ((>= (car pair) 127)
	       (aset low-table1 (- (car pair) 127) (cdr pair)))))
      (setq low-alist (cdr low-alist)))
    (cons (append low-table nil) (append low-table1 nil))))

;;; meaning of arguments (hereinafter C-B stands for CCL-BLOCK)
;;; if `table-type' = nil or t
;;;   low-tables =
;;;     ((C-B-WHEN-r1=0   ... C-B-WHEN-r1=37  C-B-OTHERWISE) .
;;;      (C-B-WHEN-r1=127 ... C-B-WHEN-r1=255 C-B-OTHERWISE))
;;;   if `table-type' = nil
;;;     r1 (39 <= r1 <= 126) ... the first byte of a jis0208 character.
;;;   if `table-type' = t,
;;;     r1 (33 <= r1 <= 126) ... an ascii character.
;;;     r1 (160 <= r1)       ... a latin1 character.
;;; if `table-type' = 'fully-specified
;;;   low-tables = (CCL-STATEMENT0 ... CCL-STATEMENTn)
(defun odccl-make-ccl (low-tables &optional table-type)
  (` (2					; buffer-mag
      ((loop
	(read-if
	 (r1 == 31)
	 ((read r2)
	  (loop
	   (branch
	    r2
	    nil nil nil			; 0x1f00-0x1f02
	    ("\C-c\C-c" ;;(write ?\C-c)	; 0x1f03 stop
	     (, (odccl-set 'eop2)))
	    ((, (odccl-reset 'col))) ; 0x1f04 single-column
	    ((, (odccl-set 'col)))	; 0x1f05 double-column
	    (;"_{"			; 0x1f06 subscript start
	     (, (odccl-reset 'col))
	     (,@ odccl-self))
	    (;(write ?})			; 0x1f07 subscript end
	     (, (odccl-set 'col))
	     (,@ odccl-self))
	    nil				; 0x1f08
	    ((read r4 r0)		; 0x1f09 set indent level
	     (r4 <8= r0)
	     (,@ odccl-indent))
	    ((, (odccl-set 'ret))	; 0x1f0a \n
	     (write ?\n)
	     (read-if (r1 != 31)
		      ((,@ odccl-indent)
		       (break))
		      (read-if (r2 == 9)
			       (repeat)
			       ((,@ odccl-indent)
				(repeat)))))
	    nil nil nil			; 0x1f0b-0d
	    (;"^{"			; 0x1f0e superscript start
	     (, (odccl-reset 'col))
	     (,@ odccl-self))
	    (;(write ?})			; 0x1f0f superscript end
	     (, (odccl-set 'col))
	     (,@ odccl-self))
	    nil nil			; 0x1f10,11 prohibit \n (ignored)
	    nil nil nil nil nil nil	; 0x1f12-
	    nil nil nil nil nil nil nil nil
	    nil nil nil nil nil nil nil nil ; 0x1f20-
	    nil nil nil nil nil nil nil nil
	    nil nil			; 0x1f30-0x1f31
	    ((,@ odccl-self))		; 0x1f32 caption of figure
	    ((,@ odccl-self))		; 0x1f33 caption of sound
	    nil nil nil nil		; 0x1f34-
	    nil
	    ((,@ odccl-self)		; 0x1f39 movie
	     (,@ (odccl-prtbcd-loop 44)))
	    nil nil nil nil nil nil	; 0x1f3a-
	    nil				; 0x1f40
	    ((if (, (odccl-check 'item)) ; 0x1f41
		 (if (, (odccl-check 'ret))
		     ((write ?\C-c)
		      (, (odccl-set 'eop)))
		   nil)
	       ((, (odccl-set 'item))))
	     (read r0 r0))
	    ((,@ odccl-self))		; 0x1f42 caption of reference
	    ((,@ odccl-self))		; 0x1f43 caption of reference
	    ((,@ odccl-self)		; 0x1f44 figure height x width
	     (read r0 r0)
	     (,@ (odccl-prtbcd-loop 8)))
	    ((,@ odccl-self)		; 0x1f45 figure or sound
	     (read r0 r0))
	    nil				; 0x1f46
	    ((,@ odccl-self))		; 0x1f47 color sample ?
	    nil nil			; 0x1f48-
	    ((,@ odccl-self)		; 0x1f4a sound(wave)
	     (,@ (odccl-prtbcd-loop 16)))
	    nil nil			; 0x1f4b-
	    ((,@ odccl-self)		; 0x1f4d color figure
	     (,@ (odccl-prtbcd-loop 18)))
	    nil nil			; 0x1f4e-
	    nil nil			; 0x1f50-
	    ((,@ odccl-self)		; 0x1f52 figure data
	     (,@ (odccl-prtbcd-loop 6)))
	    ((,@ odccl-self)		; 0x1f53 sound data
	     (,@ (odccl-prtbcd-loop 8)))
	    nil nil nil nil		; 0x1f54-
	    nil				; 0x1f58
	    ((,@ odccl-self))		; 0x1f59 movie caption end
	    nil nil nil nil nil nil	; 0x1f5a-
	    nil nil			; 0x1f60-
	    ((,@ odccl-self)		; 0x1f62 reference honmon
	     (,@ (odccl-prtbcd-loop 6)))
	    ((,@ odccl-self)		; 0x1f63 reference menu
	     (,@ (odccl-prtbcd-loop 6)))
	    ((,@ odccl-self)		; 0x1f64 figure data
	     (,@ (odccl-prtbcd-loop 6)))
	    nil	nil			; 0x1f65-
	    ((,@ odccl-self))		; 0x1f67 color sample data ?
	    nil nil			; 0x1f68-
	    ((,@ odccl-self))		; 0x1f6a sound(wave) end
	    nil nil			; 0x1f6c-
	    ((,@ odccl-self))		; 0x1f6d color figure caption end
	    )
	   (read-if (r1 != 31)
		    (break)
		    ((read r2)
		     (repeat)))))
	 nil)
	;; r1 != ESC
	(if (r1 == 30)
	    ((write r1)
	     (,@ odccl-prtbcd))
	  ;; r1 != ESC, r1 != 0x1e
	  (, (cond ((null table-type)
		    (` ((r2 = 256)
			(if (r1 < 38)
			    (branch r1 (,@ (car low-tables)))
			  (if (r1 >= 127)
			      (branch (r1 - 127) (,@ (cdr low-tables)))
			    (, odccl-jis)))
			(if (r2 == 256)
			    (read r2)
			  ((,@ (odccl-prthex 'r1))
			   (,@ (odccl-prthex 'r2)))))))
		   ((eq table-type t)
		    (` ((if (r1 < 32)
			    (branch r1 (,@ (car low-tables)))
			  (if (r1 < 127)
			      (write-repeat r1)
			    (if (r1 < 160)
				(branch (r1 - 127) (,@ (cdr low-tables)))
			      ((write (, odccl-charset-id-latin-iso8859-1))
			       (write-repeat r1))))))))
		   ((eq table-type 'fully-specified)
		    low-tables)
		   (t
		    (error "odccl-make-ccl: unknown table-type `%s'"
			   table-type)))))
	(repeat))))))

(defconst odccl-jis-kana-table
  (mapcar
   (function (lambda (arg)
	       (cond ((null arg) nil)
		     ((= (if (fboundp 'chars-in-string)
			     (chars-in-string arg)
			   (length arg))
			 1)
		      (list 'write-repeat (string-to-char arg)))
		     (t
		      (list 'write-repeat arg)))))
   '( 	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	"ｧ"	"ｱ"	"ｨ"	"ｲ"	"ｩ"	"ｳ"	"ｪ"
	"ｴ"	"ｫ"	"ｵ"	"ｶ"	"ｶﾞ"	"ｷ"	"ｷﾞ"	"ｸ"
	"ｸﾞ"	"ｹ"	"ｹﾞ"	"ｺ"	"ｺﾞ"	"ｻ"	"ｻﾞ"	"ｼ"
	"ｼﾞ"	"ｽ"	"ｽﾞ"	"ｾ"	"ｾﾞ"	"ｿ"	"ｿﾞ"	"ﾀ"
	"ﾀﾞ"	"ﾁ"	"ﾁﾞ"	"ｯ"	"ﾂ"	"ﾂﾞ"	"ﾃ"	"ﾃﾞ"
	"ﾄ"	"ﾄﾞ"	"ﾅ"	"ﾆ"	"ﾇ"	"ﾈ"	"ﾉ"	"ﾊ"
	"ﾊﾞ"	"ﾊﾟ"	"ﾋ"	"ﾋﾞ"	"ﾋﾟ"	"ﾌ"	"ﾌﾞ"	"ﾌﾟ"
	"ﾍ"	"ﾍﾞ"	"ﾍﾟ"	"ﾎ"	"ﾎﾞ"	"ﾎﾟ"	"ﾏ"	"ﾐ"
	"ﾑ"	"ﾒ"	"ﾓ"	"ｬ"	"ﾔ"	"ｭ"	"ﾕ"	"ｮ"
	"ﾖ"	"ﾗ"	"ﾘ"	"ﾙ"	"ﾚ"	"ﾛ"	"ヮ"	"ﾜ"
	"ヰ"	"ヱ"	"ｦ"	"ﾝ"	"ｳﾞ"	"ヵ"	"ヶ"	nil)))

(defconst odccl-jis-single-col1
  (list	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil		" "		[nil "､"]	[nil "｡"]
	","		"."		[nil ",A7"]	nil
	";"		"?"		"!"		[nil "ﾞ"]
	[nil "ﾟ"]	nil		nil		[nil ",A("]
	nil	"~"	nil	nil	nil	nil	nil	nil
	nil		nil		nil		nil
	[nil "ｰ"]	nil		[nil ",A-"]	"/"
	"\\"	nil	nil	"|"	nil	nil	"`"	"'"
	"\""	"\""	"("	")"	nil	nil	"["	"]"
	"{"		"}"		nil		nil
	nil		nil		[nil "｢"]	[nil "｣"]
	nil		nil		nil		nil
	"+"		"-"		[nil ",A1"]	[nil ",AW"]
	[nil ",Aw"]	"="		nil		"<"
	">"		nil		nil		nil
	nil		nil		nil		[nil ",A0"]
	nil		nil		nil		[nil ",A%"]
	"$"		[nil ",A""] 	[nil ",A#"]	"%"
	nil		"&"		"*"		"@"
	[nil ",A'"]	nil		nil		nil
	nil		nil		nil		nil))

(defconst odccl-jis-single-col2
  (list	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil		nil		nil		nil
	[nil ",A,"]	nil		nil		nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil		nil		nil		[nil ",A+"]
	[nil ",A;"]	nil		nil		nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil	nil	nil	nil	nil	nil	nil	nil
	nil		[nil ",A6"]	nil		nil
	nil		nil		nil		nil))

(defun odccl-low-alist-japanese (key)
  (list (cons 33
	      (` (if (, (odccl-check 'col))
		     (, odccl-jis)
		   ((read-branch r2
				 (,@ (odccl-select
				      odccl-jis-single-col1 key)))
		    (,@ odccl-jis-r2)))))
	(cons 34
	      (` (if (, (odccl-check 'col))
		     (, odccl-jis)
		   ((read-branch r2
				 (,@ (odccl-select
				      odccl-jis-single-col2 key)))
		    (,@ odccl-jis-r2)))))
	(cons 35
	      (` (if (, (odccl-check 'col))
		     (, odccl-jis)
		   ((read r2)
		    (write-repeat r2)))))
	(cons 36 odccl-jis)
	(cons 37
	      (if (not key)
		  odccl-jis
		(` (if (, (odccl-check 'col))
		       (, odccl-jis)
		     ((read-branch r2
				   (,@ odccl-jis-kana-table)))))))))

;(defmacro odccl-compile (func)
;  (list 'cons
;	(ccl-compile (funcall func 'x))
;	(ccl-compile (funcall func))))

(defmacro odccl-define (sym form)
  (` (defun (, sym) ()
       (, (eval form)))))

;;; od-ccl.el ends here
