#| -*- Mode:LISP; Base: 10;
       Package:(VISTA-LIBRARY :use (LISP));
       Syntax: Common-lisp; Readtable: CL; -*- 

|#


;;; Copyright (C) Lisp Machine, Inc. 1984, 1985, 1986
;;;   See filename "Copyright" for
;;; licensing and release information.

(in-package 'vista-library :use '(lisp))


;;;; The definition of the MEDIUM-RES device
;;;  and the implementation of the Vista Library for it


;;; Changes
;;; 7/14/86 EFH    Created using inheriting devices and RDM code
;;;                from BLACK&WHITE


(defvice (MEDIUM-RES
	   (:conc-name "MR-")
	   (:include black&white))
  "The LMI Medium Resolution Color Device")  




(zl:defsubst mr-color (&optional (display-device *current-display-device*))
  (ldb (byte 8 5) (mr-alu-fcn display-device)))



(defun init-mr ()
  (setf (mr-alu-fcn) (dpb 1 (byte 8 4) tv:alu-seta))
  (dotimes (i 8)				               
    (set-map-color i (logand i 1) (logand i 2) (logand i 4)))
  (setf
    (mr-mouse-click-buffer) (tv:make-io-buffer 3)
    (mr-cursor-visibility) t
    (mr-current-buffer) (mr-host-window)
    (mr-double-buffer-p) nil
    (mr-host-window-width) (zl:send (mr-host-window) :inside-width)
    (mr-host-window-height) (zl:send (mr-host-window) :inside-height)
    (mr-font) (zl:send (mr-host-window) :current-font)
    (mr-font-height) (tv:font-char-height (mr-font)))
  (set-color 0)
  (set-viewport (make-viewport 0 1 0 1))
  (ortho2 0 1023 0 767)
  (dolist (tr (mr-transform-stack))
    (push tr *transform-pool*))			;recover transforms
  (tv:turn-off-sheet-blinkers (mr-host-window)))



(defvicefun (INIT MEDIUM-RES) (&rest args)
  (unless (mr-host-window)
    (setf (mr-host-window)							;***
	  (tv:make-window 'black&white-display-device-host-window	;***
			  :superior color:color-screen	;***
			  :blinker-p nil	;***
			  :edges-from :mouse	;***
			  :label (format nil "Medium Res Display Window ~d"	;***
					 (incf *black&white-device-count*))))))




(defvicefun (INITIALIZE-DEVICE MEDIUM-RES) ()
  (zl:send (mr-host-window) :expose)
  (init-mr)
  (clear-viewport))

;-------------------- Color --------------------

(defvicefun (SET-COLOR MEDIUM-RES) (color-map-index)
   (setf (mr-color) color-map-index)
   (dpb color-map-index (byte 8 5) (dpb 1 (byte 1 4) (mr-alu-fcn))))


;;; wrong
(defvicefun (GET-MAP-COLOR MEDIUM-RES) (color)
  (color:read-color-map color))



(defvicefun (SET-MAP-COLOR MEDIUM-RES) (color-index red green blue)
  (color:write-color-map color-index (round (* red 255))
			             (round (* green 255))
			             (round (* blue 255))))






;----------------- Points ---------------------

(defvicefun (POINT2 MEDIUM-RES) (x y)
  (setf (mr-graphpos-x) x
	(mr-graphpos-y) y)
  (multiple-value-bind (screen-x screen-y clipped-p) (map-2d-point x y)
    (unless clipped-p
      (let ((scr-array (zl:send (mr-host-window) :screen-array)))
	(when scr-array
	  (zl:aset (mr-color)
		   scr-array
		   screen-y screen-x))))))

(defvicefun (POINT3 MEDIUM-RES) (x y z)
  (setf (mr-graphpos-x) x
	(mr-graphpos-y) y
	(mr-graphpos-z) z)
  (multiple-value-bind (screen-x screen-y clipped-p) (map-3d-point x y z)
    (unless clipped-p
      (let ((scr-array (zl:send (mr-host-window) :screen-array)))
	(when scr-array
	  (zl:aset (mr-color)
		   scr-array
		   screen-y screen-x))))))