;;;-*- Mode:Common-Lisp; Package:SI; Base:10; Fonts:(CPTFONT HL12 HL12BI CPTFONTB) -*-

;;; Copyright (C) 1987, 1989 Texas Instruments Incorporated. All rights reserved.

Ï2;;;       Window and Graphics support for PC Scheme compatibility

Ï1;;  3/25/88 DNG - Added Ï*Ï*window-get-cursor,Ï1 Ï*window-set-cursor!,Ï1 and Ï*window-get-sizeÏ1 .
;;  2/04/89 DNG - Added some graphics support.
;;  2/11/89 DNG - More graphics.
;;  2/13/89 DNG - Graphics fixes.

Ï2;;;Ï*Ï*	Ï2WindowsÏ*

(export '(scheme:window? scheme:window-clear) scheme-package)
(defun scheme:Ï3window?Ï* (object)
  (typecase object
    (instance (typep object 'tv:minimum-window))
    (symbol (and (get object 'si:io-stream-p)
		 (fboundp object)
		 (scheme:window? (symbol-function object))))
    (t nil)))

(defsubst scheme:Ï3window-clearÏ* (window)
  (send window :clear-screen)
  unspecified)

(export '( scheme:window-get-cursor scheme:window-set-cursor!
	  scheme:window-get-size) scheme-package)

(defun scheme:Ï3window-get-cursorÏ* (window)
  Ï1"Return cursor position as (line . column)"Ï*
  (multiple-value-bind (x y)
      (send window :read-cursorpos :character)
    (cons y x)))

(defun scheme:Ï3window-set-cursor!Ï* (window line column)
  (let (x y)
    (when (or (null line) (null column))
      (multiple-value-setq (x y)
	(send window :read-cursorpos :character)))
    (send window :set-cursorpos (or column x) (or line y) :character))
  unspecified)

(defun scheme:Ï3window-get-sizeÏ* (window)
  Ï1"Return window size as (lines . columns)"Ï*
  (cons (truncate (send window :inside-height)
		  (send window :line-height))
	(truncate (send window :inside-width)
		  (send window :char-width)) ))

Ï1;;;   - much more to be added -Ï*

(export 'scheme:( make-window window-delete window-get-attribute
		 window-get-position window-popup window-popup-delete
		 window-restore-contents window-save-contents
		 window-set-attribute! window-set-position! window-set-size! )
	scheme-package)


Ï2;;;Ï*	Ï2GraphicsÏ*

(export 'scheme:( clear-graphics clear-point
		 draw-box-to draw-filled-box-to draw-line-to draw-point
		 get-pen-color get-pen-position get-video-mode
		 *graphics-colors* is-point-on? point-color position-pen
		 set-clipping-rectangle set-palette! set-pen-color! set-video-mode!)
	scheme-package)

(export 'scheme:(black white red green blue yellow cyan magenta) scheme-package)
(defconstant scheme:Ï3*graphics-colors*Ï*
	     'scheme:((black . 0) (blue . 1) (red . 2) (magenta . 3)
		      (green . 4) (cyan . 5) (yellow . 6) (white . 7)))

;; map TI-PC color values to Explorer color values.
(defconstant tipc-color-map (coerce (mapcar #'(lambda (x)
						(symbol-value (find-symbol (car x) 'w)))
					    scheme:*graphics-colors*)
				    'vector))

(defvar *scheme-graphics-status* nil)
(defstruct (scheme-graphics-status (:conc-name graphics-))
  (pen-x 0 :type fixnum)
  (pen-y 0 :type fixnum)
  x-origin
  y-origin
  (color w:black :type fixnum)
  (mode 9000 :type fixnum)
  (y-scale #'identity)Ï1 ; scaling function for vertical coordinatesÏ*
  )

(defun get-graphics-status ()
  (let ((window *terminal-io*))
    (or (getf *scheme-graphics-status* window)
	(progn (pushnew '(setq *scheme-graphics-status* nil)
			SYS:LOGOUT-LIST :test #'equal)
	       (setf (getf *scheme-graphics-status* window)
		     (make-scheme-graphics-status
		       :x-origin (truncate (send window :inside-width) 2)
		       :y-origin (truncate (send window :inside-height) 2)
		       :color (if (tv:color-system-p *terminal-io*)
				  (tv:sheet-foreground-color *terminal-io*)
				w:black))
		     )))))

(defun scheme:Ï3clear-graphics Ï*()
  (let ((status (get-graphics-status)))
    (when (tv:color-system-p *terminal-io*)
      (if (< (graphics-mode status) 8) ; for PC simulation, switch to white on black
	  (progn (send *terminal-io* :set-background-color w:black)
		 (send *terminal-io* :set-foreground-color w:12%-gray-color))
	  (when (eql (send *terminal-io* :background-color)  w:black)
	    ;; revert to normal color Explorer black on white.
	    (send *terminal-io* :set-background-color w:12%-gray-color)
	    (send *terminal-io* :set-foreground-color w:black))))
    (send *terminal-io* :clear-screen)
    (setf (graphics-x-origin status) (truncate (send *terminal-io* :inside-width) 2))
    (setf (graphics-y-origin status) (truncate (send *terminal-io* :inside-height) 2))
    (setf (graphics-pen-x status) 0)
    (setf (graphics-pen-y status) 0)
    
    )
  (values))

(defun scheme:Ï3clear-point Ï*(x y)
  (let ((status (get-graphics-status)))
    (send *terminal-io* :draw-point (+ (graphics-x-origin status) x)
	  (- (graphics-y-origin status) (funcall (graphics-y-scale status) y))
	  w:alu-seta
	  (if (tv:color-system-p *terminal-io*)
	      (tv:sheet-background-color *terminal-io*)
	    0))
    (values)))

(defun scheme:Ï3draw-point Ï*(x y)
  (let ((status (get-graphics-status)))
    (send *terminal-io* :draw-point (+ (graphics-x-origin status) x)
	  (- (graphics-y-origin status) (funcall (graphics-y-scale status) y))
	  w:alu-seta
	  (IF (tv:color-system-p *terminal-io*) (graphics-color status) -1 ))
    (values)))

(defun scheme:Ï3is-point-on?Ï* (x y)
  (let ((status (get-graphics-status)))
    (not (zerop (send *terminal-io* :point (+ (graphics-x-origin status) x)
		      (- (graphics-y-origin status)
			 (funcall (graphics-y-scale status) y)))))))

(defun scheme:Ï3point-colorÏ* (x y)
  (let ((status (get-graphics-status)))
    (multiple-value-bind (on color)
	(send *terminal-io* :point (+ (graphics-x-origin status) x)
	      (- (graphics-y-origin status) (funcall (graphics-y-scale status) y)))
      (if (null color)				; monochrome
	  (if (zerop on)
	      '#.(cdr (assoc 'scheme:black scheme:*graphics-colors*))
	      '#.(cdr (assoc 'scheme:white scheme:*graphics-colors*)))
	(or (position (the fixnum color) (the vector tipc-color-map))
	    color)))))

(defun scheme:Ï3draw-line-to Ï*(x y)
  (let* ((status (get-graphics-status))
	 (y (funcall (graphics-y-scale status) y)))
    (send *terminal-io* :draw-line
	  (+ (graphics-x-origin status) (graphics-pen-x status)) ; from x
	  (- (graphics-y-origin status) (graphics-pen-y status)) ; from y
	  (+ (graphics-x-origin status) x) ; to x
	  (- (graphics-y-origin status) y) ; to y
	  1 ; thickness
	  (graphics-color status)
	  w:alu-seta
	  t ; draw end point
	  )
    (setf (graphics-pen-x status) x)
    (setf (graphics-pen-y status) y)
    (values)))

(defun scheme:Ï3position-pen Ï*(x y)
  (let ((status (get-graphics-status)))
    (setf (graphics-pen-x status) x)
    (setf (graphics-pen-y status) (funcall (graphics-y-scale status) y))
    (values)))

(defun scheme:Ï3get-pen-position Ï*()
  (let ((status (get-graphics-status)))
    (cons (graphics-pen-x status)
	  (round (graphics-pen-y status) (/ (funcall (graphics-y-scale status) 1000) 1000)))))

(defun scheme:Ï3draw-box-to Ï*(x y)
  (let* ((status (get-graphics-status))
	 (y (funcall (graphics-y-scale status) y)))
    (ticl:send *terminal-io* :draw-rectangle
	       (+ (graphics-x-origin status) (graphics-pen-x status))	; from x
	       (- (graphics-y-origin status) (graphics-pen-y status))	; from y
	       (- x (graphics-pen-x status))	; width
	       (- (graphics-pen-y status) y)	; height
	       1				; thickness
	       (graphics-color status)
	       w:alu-seta)
    (setf (graphics-pen-x status) x)
    (setf (graphics-pen-y status) y)
    (values)))

(defun scheme:Ï3draw-filled-box-to Ï*(x y)
  (let* ((status (get-graphics-status))
	 (y (funcall (graphics-y-scale status) y)))
    (ticl:send *terminal-io* :draw-filled-rectangle
	       (+ (graphics-x-origin status) (graphics-pen-x status))	; from x
	       (- (graphics-y-origin status) (graphics-pen-y status))	; from y
	       (- x (graphics-pen-x status))	; width
	       (- (graphics-pen-y status) y)	; height
	       (graphics-color status)		; fill color
	       w:alu-seta)
    (setf (graphics-pen-x status) x)
    (setf (graphics-pen-y status) y)
    (values)))

(defun scheme:Ï3set-pen-color!Ï* (color)
  (let* ((status (get-graphics-status))
	 (new-color (let (temp)
		      (cond ((and (symbolp color)
				  (eq (symbol-package color) '#,(symbol-package 'w:red)))
			     (symbol-value color))
			    ((and (fixnump color)
				  (<= 0 color 255))
			     (if (<= color 7)
				 (aref tipc-color-map color)
			       color))
			    ((setq temp (assoc color scheme:*graphics-colors* :test #'eq))
			     (aref tipc-color-map (cdr temp)))
			    (t (error "~S is not the name or number of a color." color))))))
    (setf (graphics-color status)
	  (if (tv:color-system-p *terminal-io*)
	      new-color
	    ;; else use shades of gray
	    (if (= new-color w:black)
		w:white
	      (+ 1 (or (position new-color tipc-color-map)
		       (error "Color ~S not supported on this terminal." color)))))))
  (values))

(defun scheme:Ï3get-pen-colorÏ* ()
  (let* ((status (get-graphics-status))
	 (color (graphics-color status)))
    (declare (fixnum color))
    (if (tv:color-system-p *terminal-io*)
	(or (position color (the vector tipc-color-map))
	    color)
      (if (= color w:black)
	  '#.(cdr (assoc 'scheme:white scheme:*graphics-colors*))
	  '#.(cdr (assoc 'scheme:black scheme:*graphics-colors*))))))

;; (defun scheme:Ï3set-palette! Ï*(color mapping)
  

(defun scheme:Ï3set-video-mode!Ï* (mode-number)
  "Two video modes are supported:
  3  simulates video mode 3 of a TI PC (text and graphics), including the use of 
	a similar aspect ratio.
9000 is native Explorer mode, which provides higher resolution and a 1:1 
	aspect ratio; this is the default.
Other video mode values used on PCs will be treated the same as mode 3 except 
that GET-VIDEO-MODE will still return the actual number given."
  (check-type mode-number (signed-byte 15))
  (let ((status (get-graphics-status)))
    (setf (graphics-mode status) mode-number)
    (setf (graphics-y-scale status)
	  (if (and (<= 0 mode-number 99)
		   (>= (send *terminal-io* :inside-height) (expand-y 300)))
	      ;; For PC simulation, use 7:4 aspect ratio.
	      #'expand-y
	    ;; else native Explorer mode, no conversion.
	    #'identity)))
  (values))

(defun expand-y (y) (values (round (* y 7) 4)))

(defun scheme:Ï3get-video-modeÏ* ()
  (graphics-mode (get-graphics-status)))

Ï1;; not yet supported:   Ï2 Ï*Ï*set-clipping-rectangle Ï2 Ï*set-palette!
