;-*- Mode:LISP; Package:(VIF :use (LISP)); Readtable:CL; Base:10 -*-


;;;; Grok Daisy Vectorized Intermediate Files


(defmacro read-word (stream)
  `(logior (read-byte ,stream)
	   (ash (read-byte ,stream) 8.)))

(defmacro read-opcode (stream)
  `(read-word ,stream))

(defmacro read-parameter (stream)
  `(read-word ,stream))

(defmacro read-coordinate (stream)
  `(values (read-word ,stream)
	   (read-word ,stream)))


;;; Control Opcodes
(defconstant VIF-OP-BEGIN-FILE      0.)
(defconstant VIF-OP-END-FILE        1.)

;;; Object Opcodes
(defconstant VIF-OP-POLYLINE        2.)
(defconstant VIF-OP-POLYGON         3.)
(defconstant VIF-OP-CIRCLE          4.)
(defconstant VIF-OP-RECTANGLE       5.)
(defconstant VIF-OP-ARC             6.)
(defconstant VIF-OP-TEXT            7.)

;;; Attribute Opcodes
(defconstant VIF-OP-SET-COLOR       9.)
(defconstant VIF-OP-LINE-WIDTH     10.)
(defconstant VIF-OP-LINE-STYLE     11.)
(defconstant VIF-OP-TEXT-WIDTH     12.)
(defconstant VIF-OP-TEXT-HEIGHT    13.)
(defconstant VIF-OP-TEXT-DIRECTION 14.)


(defun no-handler (s)
  (cerror "foo" "no handler"))

(defmacro def-device (name)
  `(defconstant ,name (make-array 15. :initial-element #'no-handler)))

(defmacro def-vif-op-handler ((device op) lambda-list &body body)
  `(progn
     (defun ,op ,lambda-list
       ,@body)
     (setf (aref ,device ,op) #',op)))

(defun do-vif-file (file device)
  (with-open-file (s file :raw t)
    (read-opcode s)
    (dotimes (i 30) (read-byte s))
    (do ((op (read-opcode s) (read-opcode s)))
	((= op VIF-OP-END-FILE))
 ;     (print op)
      (funcall (aref device op) s))))

;;; Draw on Lisp Machine Windows

(def-device LM-WINDOW)

(defun display-vif-file (file)
  (zl:send tv:selected-window :set-font-map (list fonts:hl6))
  (zl:send tv:selected-window :clear-screen)
  (do-vif-file file LM-WINDOW)
  (zl:send tv:selected-window :set-cursorpos 0 680))


(def-vif-op-handler (LM-WINDOW VIF-OP-POLYLINE) (s)
  (let ((n-coordinates (read-parameter s))
	from-x from-y to-x to-y)
    (multiple-value-setq (from-x from-y) (read-coordinate s))
    (dotimes (i (1- n-coordinates))
      (multiple-value-setq (to-x to-y) (read-coordinate s))
      (draw-line from-x from-y to-x to-y)
      (setq from-x to-x
	    from-y to-y))))

(def-vif-op-handler (LM-WINDOW VIF-OP-ARC) (s)
  (multiple-value-bind (start-x start-y) (read-coordinate s)
    (multiple-value-bind (middle-x middle-y) (read-coordinate s)
      (multiple-value-bind (last-x last-y) (read-coordinate s)
	(multiple-value-bind (center-x center-y radius)
	    (circle-center-and-radius-from-3-points start-x start-y middle-x middle-y last-x last-y)
	  (let ((theta-1 (atan (- start-y center-y) (- start-x center-x)))
		(theta-2 (atan (- last-y center-y) (- last-x center-x))))
	    (when (> theta-1 theta-2)
	      (let ((theta theta-1))
		(setq theta-1 theta-2)
		(setq theta-2 theta)))
	    (draw-arc center-x center-y radius theta-1 theta-2)))))))
	
(defun draw-arc (center-x center-y radius theta-1 theta-2)
  (zl:send tv:selected-window :draw-circular-arc
	   (round (* center-x *x-scale*))
	   (+ *y-offset* (round (* center-y *y-scale*)))
	   (round (* radius   *x-scale*))
	   theta-1 theta-2))

(def-vif-op-handler (LM-WINDOW VIF-OP-CIRCLE) (s)
  (let ((radius (read-parameter s)))
    (multiple-value-bind (center-x center-y) (read-coordinate s)
      (draw-circle center-x center-y radius))))

(defun draw-circle (center-x center-y radius)
  (zl:send tv:selected-window :draw-circle
	   (round (* center-x *x-scale*))
	   (+ *y-offset* (round (* center-y *y-scale*)))
	   radius))


(def-vif-op-handler (LM-WINDOW VIF-OP-LINE-WIDTH) (s)
  (let ((width (read-parameter s)))))

(def-vif-op-handler (LM-WINDOW VIF-OP-RECTANGLE) (s)
  (cerror "foo" "implement rectangle"))

(def-vif-op-handler (LM-WINDOW VIF-OP-TEXT-DIRECTION) (s)
  (let ((direction (read-parameter s)))))

(defvar *x-scale* .62s0)
(defvar *y-offset* 650.)
(defvar *y-scale* -.62s0)

(def-vif-op-handler (LM-WINDOW VIF-OP-TEXT) (s)
  (multiple-value-bind (x y) (read-coordinate s)
    (zl:send tv:selected-window :set-cursorpos
	     (truncate (* x *x-scale*))
	     (+ -6 *y-offset* (truncate (* y *y-scale*)))))
  (let ((nchars (read-parameter s)))
    (dotimes (i (truncate nchars 2))
      (let ((ch2 (read-byte s))
	    (ch1 (read-byte s)))
	(zl:send tv:selected-window :tyo ch1)
	(zl:send tv:selected-window :tyo ch2)))
    (when (oddp nchars)
      (read-byte s)
      (zl:send tv:selected-window :tyo (read-byte s)))))

(defun draw-line (from-x from-y to-x to-y)
  (zl:send tv:selected-window :draw-line
	   (round (* from-x *x-scale*))
	   (+ *y-offset* (round (* from-y *y-scale*)))
	   (round (* to-x *x-scale*))
	   (+ *y-offset* (round (* to-y *y-scale*)))))



;;;; Create an impress file


(def-device IMPRESS)

(defun convert-vif-to-impress (vif-file &optional
			       impress-file)
  (let ((vif-pn (fs:merge-pathname-defaults vif-file nil :default-type "vif")))
    (unless impress-file
      (setq impress-file (zl:send vif-pn :new-pathname :type "imp")))
    (with-open-file (imagen-stream impress-file :direction :output :raw t)
      (setq *imagen-stream* imagen-stream)
      (format *imagen-stream* "@Document(JobHeader on,Language Impress,Owner ~a,Name \"~A\")"
	      zl:user-id impress-file)
      (imagen-setup-text)
      (imagen-nop)
      (do-vif-file vif-pn IMPRESS)
      (imagen-endpage)
      (imagen-eof))))

(def-vif-op-handler (IMPRESS VIF-OP-POLYLINE) (s)
  (let ((n-coordinates (read-parameter s))
	x y)
    (imagen-start-path n-coordinates)
    (dotimes (i n-coordinates)
      (multiple-value-setq (x y) (read-coordinate s))
      (imagen-output-vertex (+ 225 (ash y 1)) (+ 40 (ash x 1))))
    (imagen-draw-path 15.)))

(defconstant *imagen-angle* (/ 8196.0s0 3.14159s0))

(def-vif-op-handler (IMPRESS VIF-OP-ARC) (s)
  (multiple-value-bind (start-x start-y) (read-coordinate s)
    (multiple-value-bind (middle-x middle-y) (read-coordinate s)
      (multiple-value-bind (last-x last-y) (read-coordinate s)
	(multiple-value-bind (center-x center-y radius)
	    (circle-center-and-radius-from-3-points start-x start-y middle-x middle-y last-x last-y)
	  (let ((theta-2 (atan (- start-y center-y) (- start-x center-x)))
		(theta-1 (atan (- last-y center-y) (- last-x center-x))))
	    (imagen-set-abs-h (+ 225 (ash (round center-y) 1)))
	    (imagen-set-abs-v (+  40 (ash (round center-x) 1)))
	    (imagen-circ-arc (ash (round radius) 1)
			     (- 4096. (round (* theta-1 *imagen-angle*)))
			     (- 4096. (round (* theta-2 *imagen-angle*))))
	    (imagen-draw-path 15.)
	    ))))))

(def-vif-op-handler (IMPRESS VIF-OP-CIRCLE) (s)
  (let ((radius (read-parameter s)))
    (multiple-value-bind (center-x center-y) (read-coordinate s)
      (imagen-set-abs-h (+ 225 (ash (round center-y) 1)))
      (imagen-set-abs-v (+  40 (ash (round center-x) 1)))
      (imagen-circ-arc (ash (round radius) 1) 0 16383.)
      (imagen-draw-path 15.)
      )))

(def-vif-op-handler (IMPRESS VIF-OP-LINE-WIDTH) (s)
  (imagen-set-pen (read-parameter s)))

(def-vif-op-handler (IMPRESS VIF-OP-RECTANGLE) (s)
  (multiple-value-bind (x1 y1) (read-coordinate s)
    (multiple-value-bind (x2 y2) (read-coordinate s)
      (imagen-start-path 5)
      (imagen-output-vertex (+ 225 (ash y1 1)) (+ 40 (ash x1 1)))
      (imagen-output-vertex (+ 225 (ash y1 1)) (+ 40 (ash x2 1)))
      (imagen-output-vertex (+ 225 (ash y2 1)) (+ 40 (ash x2 1)))
      (imagen-output-vertex (+ 225 (ash y2 1)) (+ 40 (ash x1 1)))
      (imagen-output-vertex (+ 225 (ash y1 1)) (+ 40 (ash x1 1)))
      (imagen-draw-path 15.))))


(def-vif-op-handler (IMPRESS VIF-OP-TEXT-DIRECTION) (s)
  (multiple-value-bind (main sec)
      (case (read-parameter s)
	;right
	(1 (values down right)) 
	;up
	(3 (values right up)))
    (imagen-set-adv-dirs main sec)
    (imagen-set-text-rotation main)))


(def-vif-op-handler (IMPRESS VIF-OP-TEXT) (s)
  (multiple-value-bind (x y) (read-coordinate s)
    (imagen-set-position (+ 225 (ash y 1)) (+ 40 (ash x 1))))
  (let ((nchars (read-parameter s)))
    (dotimes (i (truncate nchars 2))
      (let ((ch2 (read-byte s))
	    (ch1 (read-byte s)))
	(imagen-write-char ch1)
	(imagen-write-char ch2)))
    (when (oddp nchars)
      (read-byte s)
      (imagen-write-char (read-byte s)))))






(defun vif-to-imp-dir (directory)
  (let ((dirlist (fs:directory-list directory :noerror)))
    (if (typep dirlist 'error)
	(progn
	  (terpri)
	  (zl:send dirlist :print-error-message si:current-stack-group nil t))
      (dolist (file (cdr dirlist))
	(cond ((string-equal "VIF" (pathname-type (car file)))
	       (convert-vif-to-impress (car file)))
	      ((get file :directory)
	       (vif-to-imp-dir (zl:send (zl:send (car file) :pathname-as-directory)
					:new-pathname
					:name :wild
					:type :wild
					:version :newest))))))))