;;; -*- Mode:LISP; Package:VIF; Base:10; Syntax:CL -*-
;;; ********************************************************************************
;;; Copyright (C) 1984, 1985, 1986.
;;;        Massachusetts Institute of Technology
;;;        ALL RIGHTS RESERVED
;;;        No copy of this source code may be made by any means,
;;;        electronic or otherwise, without prior permission of
;;;        the Massachusetts Institute of Technology.
;;; ********************************************************************************

;;;
;;; General Imagen output functions
;;;
;;; Dinarte R. Morais, November 6, 1985
;;;

(eval-when (eval compile load)

(defmacro defimagen ((name code &rest args) &body body)
  `(defun ,name ,args (imagen-byte ,code) . ,body))

(defmacro imagen-byte (byte)
  `(write-byte ,byte *imagen-stream*))

(defmacro imagen-word (word)
  (zl:once-only (word)
    `(progn (imagen-byte (ldb (byte 8 8) ,word))
	    (imagen-byte (ldb (byte 8 0) ,word)))))

(defmacro imagen-string (string)
  `(progn
     (zl:send *imagen-stream* :string-out ,string)
     (write-byte 0 *imagen-stream*)))

(defvar *imagen-stream*)

)

(defconstant right 0)
(defconstant down  1)
(defconstant left  2)
(defconstant up    3)

(defconstant black 15.)

;;;
;;; Document Structure Commands
;;;

(defimagen (imagen-endpage 219))
(defimagen (imagen-eof 255))
(defimagen (imagen-nop 254))

;;;
;;; Coordinate System Commands
;;;

(defimagen (imagen-set-hv-system 205 origin axes orientation)
  (imagen-byte (dpb origin (byte 2 5) (dpb axes (byte 2 3) (dpb (byte 3 0) orientation 0)))))

(defimagen (imagen-set-abs-h 135 new-h)   (imagen-word new-h))
(defimagen (imagen-set-abs-v 137 new-v)   (imagen-word new-v))
(defimagen (imagen-set-rel-h 136 delta-h) (imagen-word delta-h))
(defimagen (imagen-set-rel-v 138 delta-v) (imagen-word delta-v))

(defimagen (imagen-page 213))

(defun imagen-set-position (x y)
  (imagen-set-abs-h x)
  (imagen-set-abs-v y))

;;;
;;; Text Positioning Commands
;;;

(defimagen (imagen-set-adv-dirs 206 main secondary)
  (imagen-byte (dpb main (byte 2 1) (dpb secondary (byte 1 0) 0))))

(defimagen (imagen-mmove 133 delta-m)	  (imagen-word delta-m))
(defimagen (imagen-smove 134 delta-s)	  (imagen-word delta-s))
(defimagen (imagen-set-sp 210 space-size) (imagen-word space-size))

(defimagen (imagen-sp 128))
(defimagen (imagen-sp1 129))
(defimagen (imagen-mplus 131))
(defimagen (imagen-mminus 132))
(defimagen (imagen-crlf 197))

(defimagen (imagen-set-bol 209 line-begin) (imagen-word line-begin))
(defimagen (imagen-set-il 209 inter-line)  (imagen-word inter-line))

;;;
;;; Text Printing Commands
;;;

;;; Outputs everything but the mask.
(defimagen (imagen-bgly 199 rotation family member advance-width
			width left-offset height top-offset)
  (imagen-word (dpb rotation (byte 2 14) (dpb family (byte 7 7) member)))
  (imagen-word advance-width)
  (imagen-word width)
  (imagen-word left-offset)
  (imagen-word height)
  (imagen-word top-offset))

(defimagen (imagen-create-map 222 map-name number-of-triples &rest triples)
  (imagen-byte map-name)
  (imagen-byte number-of-triples)
  (unless (= (* 3 number-of-triples) (length triples))
    (zl:ferror "CREATE-MAP: Inconsistent arguments."))
  (loop for (starting-member starting-symbol count) on triples by #'cdddr do
    (imagen-byte starting-member)
    (imagen-word starting-symbol)
    (imagen-byte count)))

(defimagen (imagen-create-family-table 221 family number-of-pairs &rest pairs)
  (imagen-byte family)
  (imagen-byte pairs)
  (unless (= (* 2 number-of-pairs) (length pairs))
    (zl:ferror "CREATE-FAMILY-TABLE: Inconsistent arguments."))
  (loop for (map-name font-name) on pairs by #'cddr do
    (imagen-byte map-name)
    (imagen-string font-name)))

(defimagen (imagen-set-family 207 family) (imagen-byte family)) 

(defimagen (imagen-member code code))

;;;
;;; Test Rule Command
;;;

(defimagen (imagen-brule 193 width height top-offset)
  (imagen-word width)
  (imagen-word height)
  (imagen-word top-offset))

;;;
;;; Graphics Commands
;;;

(defimagen (imagen-create-path 230 vertex-count &rest vertices)
  (imagen-word vertex-count)
  (unless (= (* 2 vertex-count) (length vertices))
    (error "CREATE-PATH: Inconsistent arguments."))
  (do ((v vertices (cddr v)))
      ((null v))
    (imagen-word (car v))
    (imagen-word (cadr v))))

(defun imagen-start-path (vertex-count)
  (imagen-byte 230)
  (imagen-word vertex-count))

(defun imagen-output-vertex (h v)
  (imagen-word h)
  (imagen-word v))

(defimagen (imagen-circ-arc 150 radius alpha0 alpha1)
  (imagen-word radius)
  (imagen-word alpha0)
  (imagen-word alpha1))

(defimagen (imagen-circ-segm 160 radius0 radius1 alpha0 alpha1 offset)
  (imagen-word radius0)
  (imagen-word radius1)
  (imagen-word alpha0)
  (imagen-word alpha1)
  (imagen-word offset))

(defimagen (imagen-ellipse-arc 151 radiusa radiusb alphaoff alpha0 alpha1)
  (imagen-word radiusa)
  (imagen-word radiusb)
  (imagen-word alphaoff)
  (imagen-word alpha0)
  (imagen-word alpha1))

(defimagen (imagen-set-pum 225 mode)
  (imagen-byte (ldb (byte 1 0) mode)))

(defimagen (imagen-set-texture 231 family member)
  (imagen-byte (ldb (byte 6 1) family))
  (imagen-byte (dpb (ldb (byte 1 0) family) (byte 1 7) member)))

(defimagen (imagen-set-pen 232 diameter)         (imagen-byte diameter))
(defimagen (imagen-draw-path 234 operation-type) (imagen-byte operation-type))
(defimagen (imagen-fill-path 233 operation-type) (imagen-byte operation-type))

(defimagen (imagen-bitmap 235 operation-type hsize vsize &rest bits)
  operation-type hsize vsize bits
  (zl:ferror "Not implemented."))

(defimagen (imagen-set-magnification 236 power) (imagen-byte power))

;;;
;;; State Saving and Restoring
;;;

(defimagen (imagen-set-push-mask 214 pen-and-texture interword-space interline-space
			      beginning-of-line family hv-position advance-directions
			      origin orientation)
  (imagen-byte (ldb (byte 1 0) pen-and-texture))
  (imagen-byte (dpb interword-space (byte 1 7) 
		    (dpb interline-space (byte 1 6)
			 (dpb beginning-of-line (byte 1 5)
			      (dpb family (byte 1 4)
				   (dpb hv-position (byte 1 3)
					(dpb advance-directions (byte 1 2)
					     (dpb origin (byte 1 1) orientation)))))))))

(defimagen (imagen-push 211))
(defimagen (imagen-pop 212))

;;;
;;; Impress Macros
;;;

(defimagen (imagen-define-macro 242 macro-name body-length &rest body)
  (imagen-byte macro-name)
  (imagen-word body-length)
  (unless (= body-length (length body))
    (zl:ferror "DEFINE-MACRO: Inconsistent arguments."))
  (loop for body-byte in body do
    (imagen-byte body-byte)))

(defimagen (imagen-execute-macro 243 macro-name)
  (imagen-byte macro-name))

;;;
;;; Version 1.1 Features
;;;

(defimagen (imagen-set-clip-region 140 width height)
  (imagen-word width)
  (imagen-word height))

(defimagen (imagen-reset-clip-region 141))





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


(defvar *current-font-map* (make-array 256 :element-type '(unsigned-byte 4)))

(defun clear-font-map ()
  (dotimes (i 256)
    (setf (aref *current-font-map* i) 0)))

(defvar *current-font-descriptor* (fed:font-get-fd 'fonts:gach10))

(defun imagen-setup-text (&optional (font 'fonts:gach10))
  (clear-font-map)
  (setq *current-font-descriptor* (fed:font-get-fd font))
  (imagen-set-family 1)
  (imagen-set-sp (fed:cd-char-width (aref *current-font-descriptor* #\space))))

(defvar *current-rotation* down)

(defun imagen-set-text-rotation (rot)
  (setq *current-rotation* rot)
  (imagen-set-family (1+ rot)))

(defun imagen-write-char (char)
  (if (= char #\space)
      (imagen-sp)
    (let ((map (aref *current-font-map* char)))
      (unless (logbitp *current-rotation* map)
	(imagen-download-glyph
	  *current-font-descriptor*
	  *current-rotation*
	  (1+ *current-rotation*)
	  char
	  )
	(setf (aref *current-font-map* char) (logior map (ash 1 *current-rotation*))))
      (imagen-byte char))))

(defconstant charmag 2.)

(defun imagen-download-glyph (font-desc rotation font-number char-number
			      &aux byte count)
  (let* ((char (aref font-desc char-number))
	 (height (array-dimension char 0))
	 (width (array-dimension char 1))
	 (raw-width (array-dimension char 1))
	 (baseline (fed:fd-baseline font-desc)))
    (if (= rotation down)
	(rotatef width height))
  (when char
    (imagen-bgly rotation font-number char-number
		 (* (fed:cd-char-width char) charmag)
		 (* width charmag)
		 (* (if (= rotation down)          ;left-offset
			(- width baseline)
		      0)
		    charmag)
		 (* height charmag)                ;height
		 (* (if (= rotation down)	   ;top-offset
			0
		      baseline)
		    charmag))

;		 (* (fed:cd-char-width char) charmag)
;		 (* width charmag)
;		 0
;		 (* height charmag)
;		 (* (fed:fd-baseline font-desc) charmag))

    (dotimes (r height)
      (dotimes (k charmag)
	(setq byte 0)
	(setq count 7)
	(dotimes (c width)
	  (dotimes (j charmag)
	    (setq byte (logior byte
			       (ash
				 (cond
				   ((= rotation down)  (aref char (- width c 1) r))
				   ((= rotation right) (aref char r c)))
				 count)))
	    (setq count (1- count))
	    (when (minusp count)
	      (setq count 7)
	      (imagen-byte byte)
	      (setq byte 0))))
	(if (/= count 7)
	    (imagen-byte byte)))))))