;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Spice Lisp interface to sapphire.
;;; 
;;; Written by  Daniel Aronson
;;;
;;; **********************************************************************

;;; **********************************************************************

(declare (special null-port	        ;reply port when we don't want a reply.
		  *user-viewport* 	;port to send viewport messages to.
		  data-port
		  sapphire-reply-port
		  *user-window*
		  *viewport-x-size*
		  *viewport-y-size*
		  port-death-message
		  ))

(defvar *full-window* ()
  "Full Sapphire window.")

;;; sapphire-reply-port holds the port which this process receives replies 
;;; from the sapphire server on.  It is initialized by sapphire-init.


;;; Window-Viewport

;;; The global special to-window-viewport stores an alien structure of type
;;;  to-window-viewport  This structure holds the message sent to sapphire
;;;  by the window-viewport function.  To-window-viewport is initialized
;;;  by sapphire-init.

(defvar to-window-viewport)
(def-alien-structure to-window-viewport
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 22)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (msg-remote-port port 14 18 :default *user-window*)
  (msg-id unsigned-integer 18 22 :constant 2204)
  )


(defvar from-window-viewport)
(def-alien-structure from-window-viewport
  (msg-size unsigned-integer 2 6 :constant 48)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (viewport port 32 36 :direction read)
  (width unsigned-integer 40 42 :direction read)
  (height unsigned-integer 46 48 :direction read)
  )

;;; Window-viewport fetches the viewport associated with *user-window*
;;; as well as the width and height of that viewport.

(defun window-viewport (&optional window)
  (if window (setf (to-window-viewport-msg-remote-port
		    to-window-viewport)
		   window))
  (simple-send to-window-viewport)
  (simple-receive from-window-viewport)
  (values (from-window-viewport-viewport from-window-viewport)
	  (from-window-viewport-width from-window-viewport)
	  (from-window-viewport-height from-window-viewport))
  )


;;;CREATE-WINDOW

;;;Creates a window.

(defvar to-create-window)
(def-alien-structure to-create-window
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 244)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (msg-remote-port port 14 18 :default *user-window*)
  (msg-id unsigned-integer 18 22 :constant 2201)
  (tt1-1 unsigned-integer 22 24 :constant 4096)
  (tt1-2 unsigned-integer 24 26 :constant 4097)
  (fixed-position (selection () t) 26 28)
  (tt2-1 unsigned-integer 28 30 :constant 4097)
  (tt2-2 unsigned-integer 30 32 :constant 4097)
  (leftx signed-integer 32 34)
  (tt3-1 unsigned-integer 34 36 :constant 4097)
  (tt3-2 unsigned-integer 36 38 :constant 4097)
  (topy signed-integer 38 40)
  (tt4-1 unsigned-integer 40 42 :constant 4096)
  (tt4-2 unsigned-integer 42 44 :constant 4097)
  (fixed-size (selection () t) 44 46)
  (tt5-1 unsigned-integer 46 48 :constant 4097)
  (tt5-2 unsigned-integer 48 50 :constant 4097)
  (width signed-integer 50 52)
  (tt6-1 unsigned-integer 52 54 :constant 4097)
  (tt6-2 unsigned-integer 54 56 :constant 4097)
  (height signed-integer 56 58)
  (tt7-1 unsigned-integer 58 60 :constant 4096)
  (tt7-2 unsigned-integer 60 62 :constant 4097)
  (hastitle (selection () t) 62 64)
  (tt8-1 unsigned-integer 64 66 :constant 4096)
  (tt8-2 unsigned-integer 66 68 :constant 4097)
  (hasborder (selection () t) 68 70)
  (tt9-1 unsigned-integer 70 72 :constant 0)
  (tt9-2 unsigned-integer 72 74 :constant 12288)
  (tt9-3 unsigned-integer 74 76 :constant 12)
  (tt9-4 unsigned-integer 76 78 :constant 1144)
  (tt9-5 unsigned-integer 78 82 :constant 1)
  (title perq-string 82 226)
  (tt10-1 unsigned-integer 226 228 :constant 14348)
  (tt10-2 unsigned-integer 228 230 :constant 4097)
  (progname perq-string 230 238)
  (tt11-1 unsigned-integer 238 240 :constant 4096)
  (tt11-2 unsigned-integer 240 242 :constant 4097)
  (hasicon (selection () t) 242 244)
  )


(defvar from-create-window)
(def-alien-structure from-create-window
  (msg-size unsigned-integer 2 6 :constant 80)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (leftx unsigned-integer 32 34 :direction read)
  (topy unsigned-integer 38 40 :direction read)
  (width unsigned-integer 44 46 :direction read)
  (height unsigned-integer 50 52 :direction read)
  (progname perq-string 56 64 :direction read)
  (viewport port 68 72 :direction read)
  (window port 76 80 :direction read)
  )



(defun create-window (fixedposition leftx topy fixedsize width height hastitle hasborder title progname hasicon &optional window)
  (if window (setf (to-create-window-msg-remote-port to-create-window)
		   window))
  (if (or (< width 10) (< height 15) (> width 16000) (> height 16000))
      (error "Illegal size for Create-Window.  Width = ~s, height = ~s."
	     width height))
  (multiple-alien-setq-to-create-window
   to-create-window
   (:fixed-position fixedposition)
   (:leftx leftx)
   (:topy topy)
   (:fixed-size fixedsize)
   (:width width)
   (:height height)
   (:hastitle hastitle)
   (:hasborder hasborder)
   (:title title)
   (:progname progname)
   (:hasicon hasicon))
  (simple-send to-create-window)
  (simple-receive from-create-window)
  (values (from-create-window-window from-create-window)
	  (from-create-window-viewport from-create-window)
	  (from-create-window-leftx from-create-window)
	  (from-create-window-topy from-create-window)
	  (from-create-window-width from-create-window)
	  (from-create-window-height from-create-window)
	  (from-create-window-progname from-create-window))
  )

;;;GET-FULL-WINDOW

(defvar to-get-full-window)
(def-alien-structure to-get-full-window
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 22)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (msg-remote-port port 14 18 :constant *user-window*)
  (msg-id unsigned-integer 18 22 :constant 2226)
  )


(defvar from-get-full-window)
(def-alien-structure from-get-full-window
  (msg-size unsigned-integer 2 6 :constant 36)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (full-window port 32 36 :direction read)
  )


(defun get-full-window ()
  (simple-send to-get-full-window)
  (simple-receive from-get-full-window)
  (from-get-full-window-full-window from-get-full-window))

;;;SET-TITLE

;;; Set-title Sets the title of the lisp listener.

(defvar to-set-title)
(def-alien-structure to-set-title
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 176)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant null-port)
  (msg-remote-port port 14 18 :default *user-window*)
  (msg-id unsigned-integer 18 22 :constant 2202)
  (ipc-name1-1 unsigned-integer 22 24 :constant 0)
  (ipc-name1-2 unsigned-integer 24 26 :constant 12288)
  (tname2 unsigned-integer 26 28 :constant 12)
  (tsize2 unsigned-integer 28 30 :constant 1144)
  (num-elts unsigned-integer 30 34 :constant 1)
  (string perq-string 34 176)
  )

(defun set-title (title &optional window)
  (if window (setf (to-set-title-msg-remote-port to-set-title)
		   window))
  (setf (to-set-title-string to-set-title) title)
  (simple-send to-set-title))
;;;DESTROY-WINDOW


(defvar to-destroy-window)
(def-alien-structure to-destroy-window
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 22)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant null-port)
  (msg-remote-port port 14 18)
  (msg-id unsigned-integer 18 22 :constant 2203)
  )

;;; After the window is destroyed we must receive the port death messages.

(defun destroy-window (window)
  (setf (to-destroy-window-msg-remote-port to-destroy-window) window)
  (simple-send to-destroy-window)
  (simple-receive port-death-message)
  (simple-receive port-death-message)
  )


;;; MODIFY-WINDOW


(defvar to-modify-window)
(def-alien-structure to-modify-window
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 52)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (msg-remote-port port 14 18)
  (msg-id unsigned-integer 18 22 :constant 2200)
  (tt2-1 unsigned-integer 22 24 :constant 4097)
  (tt2-2 unsigned-integer 24 26 :constant 4097)
  (newleftx signed-integer 26 28)
  (tt3-1 unsigned-integer 28 30 :constant 4097)
  (tt3-2 unsigned-integer 30 32 :constant 4097)
  (newtopy signed-integer 32 34)
  (tt4-1 unsigned-integer 34 36 :constant 4097)
  (tt4-2 unsigned-integer 36 38 :constant 4097)
  (newouterwidth signed-integer 38 40)
  (tt5-1 unsigned-integer 40 42 :constant 4097)
  (tt5-2 unsigned-integer 42 44 :constant 4097)
  (newouterheight signed-integer 44 46)
  (tt6-1 unsigned-integer 46 48 :constant 4097)
  (tt6-2 unsigned-integer 48 50 :constant 4097)
  (newrank signed-integer 50 52)
  )



(defvar from-modify-window)
(def-alien-structure from-modify-window 
  (msg-size unsigned-integer 2 6 :constant 28)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (rc unsigned-integer 26 28 :direction read)
  )

;;; Modify-window changes the size position and/or rank of a window.  If
;;; any of the parameters are (-32005) then the user is required to supply the 
;;; missing information.

(defun modify-window (newleftx newtopy newouterwidth newouterheight newrank
			&optional (port *user-window*))
  "Modify-window changes the size position and/or rank of a window.  If
any of the parameters are (-32005) then the user is required to supply the 
missing information."
  (multiple-alien-setq-to-modify-window to-modify-window
				       (:msg-remote-port port)
				       (:newleftx newleftx)
				       (:newtopy newtopy)
				       (:newouterwidth newouterwidth)
				       (:newouterheight newouterheight)
				       (:newrank newrank))
  (simple-send to-modify-window)
  (simple-receive from-modify-window)
  (if (/= (from-modify-window-rc from-modify-window) rc-success)
      (error "RC = ~s." (from-modify-window-rc from-modify-window)))
  )

;;; SET-WINDOW-PROGRESS


(defvar to-set-window-progress)
(def-alien-structure to-set-window-progress
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 44)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (msg-remote-port port 14 18)
  (msg-id unsigned-integer 18 22 :constant 2213)
  (tt2-1 unsigned-integer 22 24 :constant 4097)
  (tt2-2 unsigned-integer 24 26 :constant 4097)
  (nestlevel unsigned-integer 26 28)
  (tt3-1 unsigned-integer 28 30 :constant 8194)
  (tt3-2 unsigned-integer 30 32 :constant 4097)
  (value unsigned-integer 32 36)
  (tt4-1 unsigned-integer 36 38 :constant 8194)
  (tt4-2 unsigned-integer 38 40 :constant 4097)
  (max unsigned-integer 40 44)
  )


;;; Set-window-progress shows the progress in the icon and title area if
;;; appropriate.  If MAX is 0 then random progress is done.  If VALUE>=MAX
;;; then the progress bar is removed.  NESTLEVEL determines which bar to show.

(defun set-window-progress (nestlevel value max
				      &optional (port *user-window*))
  "Set-window-progress shows the progress in the icon and title area if
appropriate.  If MAX is 0 then random progress is done.  If VALUE>=MAX
then the progress bar is removed.  NESTLEVEL determines which bar to show."
  (multiple-alien-setq-to-set-window-progress to-set-window-progress
				       (:msg-remote-port port)
				       (:nestlevel nestlevel)
				       (:value value)
				       (:max max))
  (simple-send to-set-window-progress)
  )



;;; Window moving utilities

(defvar to-expand-window)
(def-alien-structure to-expand-window
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 22)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (msg-remote-port port 14 18)
  (msg-id unsigned-integer 18 22 :constant 2220)
  )

;;; Expands the specified window to be full screen.

(defun expand-window (port)
  "Expands the specified window to be full screen."
  (setf (to-expand-window-msg-remote-port to-expand-window) port)
  (simple-send to-expand-window)
  )


;;; ***************************************************************************

(defvar to-shrink-window)
(def-alien-structure to-shrink-window
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 22)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (msg-remote-port port 14 18)
  (msg-id unsigned-integer 18 22 :constant 2221)
  )

;;; Shrinks the window back to its original size.

(defun shrink-window (port)
  "Shrinks the window back to its original size."
  (setf (to-shrink-window-msg-remote-port to-shrink-window) port)
  (simple-send to-shrink-window)
  )


;;; ***************************************************************************

(defvar to-remove-window)
(def-alien-structure to-remove-window
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 22)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (msg-remote-port port 14 18)
  (msg-id unsigned-integer 18 22 :constant 2222)
  )


;;; Removes window from screen.

(defun remove-window (port)
 "Removes window from screen."
  (setf (to-remove-window-msg-remote-port to-remove-window) port)
  (simple-send to-remove-window)
  )

;;; ***************************************************************************

(defvar to-restore-window)
(def-alien-structure to-restore-window
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 22)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant sapphire-reply-port)
  (msg-remote-port port 14 18)
  (msg-id unsigned-integer 18 22 :constant 2223)
  )


;;; Restores window to old position on screen.

(defun restore-window (port)
  "Restores window to old position on screen."
  (setf (to-restore-window-msg-remote-port to-restore-window) port)
  (simple-send to-restore-window)
  )



(defun sapphire-init ()
  (setq sapphire-reply-port (allocate-port 0))
  (setq to-window-viewport (make-to-window-viewport))
  (setq from-window-viewport (make-from-window-viewport))
  (setq to-set-title (make-to-set-title))
  (setq to-create-window (make-to-create-window))
  (setq from-create-window (make-from-create-window))
  (setq to-destroy-window (make-to-destroy-window))
  (setq to-get-full-window (make-to-get-full-window))
  (setq from-get-full-window (make-from-get-full-window))
  (setq to-modify-window (make-to-modify-window))
  (setq from-modify-window (make-from-modify-window))
  (setq to-set-window-progress (make-to-set-window-progress))
  (setq to-expand-window (make-to-expand-window))
  (setq to-shrink-window (make-to-shrink-window))
  (setq to-remove-window (make-to-remove-window))
  (setq to-restore-window (make-to-restore-window))
  (setq *full-window* (get-full-window))
  )