no-compute screensaver, final version...

[pjackson@rcsuna.gmr.com (Philip Jackson )]

Here's the (hopefully final) version of a no-compute screensaver,
in case anyone out there winds up using this besides me-- this
version includes code provided by Rich Lynch, who pointed out that
the previous version's code for hiding the menubar would not restore
it and could cause further problems if one swapped out of Lisp while
the menubar was hidden--

;;; -*- Syntax:Common-LISP; Mode:LISP; Package: Common-Lisp-User; Base:10. -*-

; history

; PCJ 3/26/94  created file, to make a simple, no compute screensaver.
;              new code for hiding menubar was provided by Rich Lynch.

(defvar *screensaver*)

(defclass screensaver (window)
  ()
  (:default-initargs 
    :window-type :document-with-grow
    :window-title ""
    ))

(defun init-screensaver ()
  (let (window)
    (setf window
          (make-instance 'screensaver
            :view-position #@(0 0)
            :view-size (make-point *screen-width* *screen-height*)
            :window-show nil
            ))
    (set-fore-color window *black-color*)
    (set-back-color window *black-color* t)
    (set-part-color window :frame *black-color*)
    (set-part-color window :text *black-color*)
    (set-part-color window :hilite *black-color*)
    (set-part-color window :title-bar *black-color*)
    window
    ))

(defun save-screen ()
  (let ()
    (menubar-hide)
    (setf *screensaver* (init-screensaver))
    (window-show *screensaver*)
    ))

(defun ss () (save-screen))

(defun restore-screen ()
  (setf *screensaver* (window-close *screensaver*))
  (menubar-show)
  )

(defun rs () (restore-screen))

(defparameter *menubar-hidden-p* nil
  "Maintained by menubar-hide and menubar-show."
)

(defvar *menubar-height* (#_GetMBarHeight)
  "The height of the menubar."
)

(defparameter *suspend-functions* ()
  "A list of functions that will be called when the Application is
placed in the background."
)

(defparameter *resume-functions* ()
  "A list of functions that will be called when the Application is
brought back into the foreground."
)

(defun set-menubar-height (int)
  "int
Sets the height of the menubar to int."
  (%put-word (%int-to-ptr #x0BAA) int)
)

(defun menubar-hide ()
  "Hides the menubar and sets *menubar-hidden-p* to t.
Destructively modifies the system handle GrayRgn."
  (setq *menubar-hidden-p* t)
  (let* ((menubar-region (#_NewRgn))
         (gray-region (%get-ptr (%int-to-ptr #$GrayRgn)))
         (front (front-window))
         (win-ptr (when front (wptr front)))
         (old-height (#_GetMBarHeight))
        )
    (unless (zerop old-height) (setq *menubar-height* old-height))
    (set-menubar-height 0)
    (#_SetRectRgn menubar-region 0 0 *screen-width* *menubar-height*)
    (#_UnionRgn menubar-region gray-region gray-region)
    (when win-ptr
      (#_PaintOne win-ptr menubar-region)
      (#_PaintBehind win-ptr menubar-region)
      (#_CalcVis win-ptr)
      (#_CalcVisBehind win-ptr menubar-region)
    )
    (#_DisposHandle menubar-region)
) )

(defun menubar-show ()
  "Shows the menubar and sets *menubar-hidden-p* to nil.
Destructively modifies (restores) the system handle GrayRgn."
  (setq *menubar-hidden-p* nil)
  (let* ((menubar-region (#_NewRgn))
         (gray-region (%get-ptr (%int-to-ptr #$GrayRgn)))
         (front (front-window))
         (win-ptr (when front (wptr front)))
        )
    (set-menubar-height *menubar-height*)
    (#_SetRectRgn menubar-region 0 0 *screen-width* *menubar-height*)
    (#_DiffRgn gray-region menubar-region gray-region)
    (when win-ptr
      (#_CalcVis win-ptr)
      (#_CalcVisBehind win-ptr menubar-region)
    )
    (#_HiliteMenu 0)
    (#_DrawMenuBar)
    (#_DisposHandle menubar-region)
) )

(defun menubar-suspend ()
  "Calls menubar-show in response to suspend-event-handler."
  (when *menubar-hidden-p*
    (menubar-show)
    (setq *menubar-hidden-p* t)
) )

(defun menubar-resume ()
  "Calls menubar-hide in response to suspend-event-handler."
  (when *menubar-hidden-p*
    (menubar-hide)
) )

(push #'menubar-suspend *suspend-functions*)
(push #'menubar-resume *resume-functions*)

(defmethod suspend-event-handler ((ap application))
  "ap
Calls each function in *suspend-functions*.
Any specialization should be sure to call-next-method."
  (declare (ignore ap))
  (mapc #'funcall *suspend-functions*)
)

(defmethod resume-event-handler ((ap application))
  "ap
Calls each function in *resume-functions*.
Any specialization should be sure to call-next-method."
  (declare (ignore ap))
  (mapc #'funcall *resume-functions*)
)

(defun suspend-resume-event-hook ()
  "Checks if *current-event* is a suspend or resume.
If so, calls suspend-event-handler or resume-event-handler on *application*.
Returns NIL."
  (let ((message (rref *current-event* :EventRecord.Message)))
    (when (= (rref *current-event* :EventRecord.What) #$osEvt)
      (when (= (ash message -24) #$suspendResumeMessage)
        (if (logbitp 0 message)
          (resume-event-handler *application*)
          (suspend-event-handler *application*)
    ) ) )
    nil
) )

;; (setq *eventhook* #'suspend-resume-event-hook)
(push #'suspend-resume-event-hook *eventhook*) ;; PCJ 3/30/94, based on advice by R.Lynch.