(in-package :mt)

#| ######################################################################

 Random hacks for MCL

Copyright © 1994-97 Michael Travers
Permission is given to use and modify this code as long
as the copyright notice is preserved.

Send questions, comments, and fixes to mt@media.mit.edu.


-------------------------------------------------------------------------

A random assortment of hacks peculiar to the MCL environment. There
are tools for manipulating views, files, resources, the mouse, and suchlike.

History:
6/95:          MCL 3.0 release
6/27/95 15:29  view-adjust-for-subviews: default optional args properly 
7/8/95 13:33   at-listener-level can just pass continuation; does not need to be wrapped in a funcall form
8/23/95 13:26  cosmetic 
9/4/95 13:10   POP-UP-MENU-DEFAULT-ITEM not exported in MCL2
11/27/96 15:14 Add view-real-position and view-real-position-relative
11/28/96 22:30 Add with-timeout
12/8/96 12:14  Add with-handle from LW
2/12/97 21:54  Remove unneeded local var from at-listener-level
               Added in-background and report-and-ignore-errors 
4/9/97 1:37    view-contained-by? had a bug
4/14/97 19:27  Added here and rel-pathname
4/26/97 13:28  Added in-own-process
###################################################################### |#


;;; Interaction and development

;;; Use this to edit any old sort of file in fred.  
(defun edit-any (&optional (file (choose-file-dialog)))
  (fred file))

;;; Immediately compile and display some Lisp code
(defmacro disasm (&body some-code)
  `(inspect #'(lambda () ,@some-code)))

;;; from Bill St.Clair
(defmacro meter-consing (&body body)
  (let ((bytes (gensym)))
    `(let ()              ; LET here forces evaluator to compile whole form
       (gc)
       (let ((,bytes (ccl::%freebytes)))
         (multiple-value-prog1
           (progn ,@body)
           (gc)
           (format t "~&Consed ~d bytes~%" (- ,bytes (ccl::%freebytes))))))))

(defun save-all-files ()
  (ccl::do-all-windows w
    (when (and (typep w 'ccl::fred-window)
               (window-needs-saving-p w))
      (if (y-or-n-p "Save ~A" (window-title w))
        (window-save w)))))

(defun rerequire (module)
  (let ((paths (ccl::find-module-pathnames (string module))))
    (if (listp paths)
      (mapc #'load paths)
      (load paths))))

;;; Misc macros

;;; Does what eval-enqueue does, but more naturally using a closure
(defmacro at-listener-level (&body body)
  `(eval-enqueue #+CCL-3 #'(lambda () ,@body)
                 #-CCL-3 `(funcall #'(lambda () ,@body))))

#|
; +++ we don't really need both of the following
;;; like the above but will work even if listener is busy
(defmacro in-own-process (&body body)
  `(let ((continuation #'(lambda () ,@body)))
     (process-run-function "Temp Process" continuation)))
|#

;;; Run a section of code in a background process, errors are reported.  Name must be a string.
;;; A closure is made around the body.
(defmacro in-background (name &body body)
  `(process-run-function 
    ,name
    #'(lambda () 
        (handler-case (progn ,@body)
          (error (condition)
                 (at-listener-level
                   (format t "~%Error in process ~A: ~A" ,name condition)))))))

;;; put a timeout around an execution. Null time means no timeout.
(defmacro with-timeout (time body-form timed-out-form)
  `(let ((timer-process (and ,time (set-timeout *current-process* ,time #'(lambda ()
                                                                 (ignore-errors         ; sometimes the throw gets executed outside of the catch, causing an error. I'm not sure how or why that is happening.
                                                                  (throw :timeout t))))))
         values)
     (unwind-protect 
       (if (catch :timeout
             (setf values (multiple-value-list ,body-form))
             nil)
         ,timed-out-form
         (values-list values))
       (if ,time (process-kill timer-process)))))

;;; lower-level function to create a timeout process
(defun set-timeout (process seconds action)
  (process-run-function
   `(:name ,(format nil "Timeout for ~A" process)
     :priority -1
     :background-p t)
   #'(lambda ()
       (sleep seconds)
       (process-interrupt process action))))


;;; for trap calls that return zero or an error code
(defmacro errcheck (form)
  `(let ((result ,form))
     (assert (zerop result) () "~&~A had an error: ~A" ',(car form) result)
     result))

;;; Graphics

;;; stolen from quickdraw.lisp 
(defmacro with-rect ((var left &optional top right bottom) &body body)
  "takes a rectangle, two points, or four coordinates and makes a rectangle.
body is evaluated with VAR bound to that rectangle."
  `(rlet ((,var :rect))
     (setup-rect ,var ,left ,top ,right ,bottom)
     ,@body))

(defmacro with-view-rect ((var view) &body body)
  `(with-rect (,var (view-position ,view) (add-points (view-position ,view) (view-size ,view)))
     ,@body))

(defun setup-rect (rect left top right bottom)
  (cond (bottom
         (setf (pref rect rect.topleft) (make-point left top))
         (setf (pref rect rect.bottomright) (make-point right bottom)))
        (right
         (error "Illegal rectangle arguments: ~s ~s ~s ~s"
                left top right bottom))
        (top
         (setf (pref rect rect.topleft) (make-point left nil))
         (setf (pref rect rect.bottomright) (make-point top nil)))
        (t (%setf-macptr rect left))))

(defmacro make-poly (&body drawing-forms)
  `(let ((phandle (require-trap #_OpenPoly)))
     ,@drawing-forms
     (require-trap #_ClosePoly)
     phandle))

;;; These use a 0-255 scale for component levels
(defun make-gray (level)
  (make-color* level level level))

;;; Make-color with sensible arguments
(defun make-color* (red green blue)
  "given red, green, and blue, returns an encoded rgb value"
  (logior (lsh red 16)
          (lsh green 8)
          blue))


;;; Views & Windows

;;; This is complicated by windoids
(defun window-expose (w)
  (set-window-layer w (1+ (window-layer (front-window))))
  (window-show w))

(defclass scale-subviews-mixin (simple-view) ())

(defvar *scale-subviews* t)

(defmethod set-view-size :around ((view scale-subviews-mixin) h &optional v)
  (unless v
    (setq v (point-v h)
          h (point-h h)))
  (let* ((oldsize (view-size view))
         (h-scale (/ h (point-h oldsize)))
         (v-scale (/ v (point-v oldsize))))
    (call-next-method)
    (when *scale-subviews*
      (dosequence (subview (view-subviews view))
                  (view-scale subview h-scale v-scale t)))))

(defmethod view-scale ((view simple-view) hscale vscale &optional scale-position)
  (let* ((oldsize (view-size view))
         (oldpos (view-position view)))
    (set-view-size view
                   (round (* hscale (point-h oldsize)))
                   (round (* vscale (point-v oldsize))))
    (when scale-position
      (set-view-position view
                         (round (* hscale (point-h oldpos)))
                         (round (* vscale (point-v oldpos)))))
    (set-view-font-size view
                        (round (* vscale (view-font-size view))))
    (dosequence (subview (view-subviews view))
      (view-scale subview hscale vscale t))))

(defmethod view-font-size ((v simple-view))
  (find nil (view-font v) 
        :test #'(lambda (x y) (declare (ignore x)) (numberp y))))

(defmethod set-view-font-size ((v simple-view) new-size)
  (set-view-font v new-size))

(defmethod view-shrink-to-fit-subviews ((view view) &optional (border 10))
  (let* ((subviews (coerce (view-subviews view) 'list))
         (max-h (maximize subviews 
                          :key #'(lambda (sv) (+ (point-h (view-size sv))
                                                 (point-h (view-position sv))))
                          :return-max t))
         (max-v (maximize subviews 
                          :key #'(lambda (sv) (+ (point-v (view-size sv))
                                                 (point-v (view-position sv))))
                          :return-max t)))
    (when subviews
      (let ((*scale-subviews* nil))
        (set-view-size view (+ max-h border) (+ max-v border))))))

;;; Does a view overlap any of its siblings?
(defmethod view-overlaps? ((v simple-view))
  (dosequence (sv (view-subviews (view-container v)) nil)
    (unless (eq sv v)
      (when (views-overlap? v sv)
        (return sv)))))

(defmethod views-overlap? ((v1 view) (v2 view))
  (with-rect (r1 (view-position v1) (add-points (view-position v1) (view-size v1)))
    (with-rect (r2 (view-position v2) (add-points (view-position v2) (view-size v2)))
      (#_SectRect r1 r2 r2))))

(defun point-max (p1 p2)
  (make-point (max (point-h p1)
                   (point-h p2))
              (max (point-v p1)
                   (point-v p2))))

(defun point-min (p1 p2)
  (make-point (min (point-h p1)
                   (point-h p2))
              (min (point-v p1)
                   (point-v p2))))

(defsubst point> (a b)
  (not (point<= a b)))

;;; LiveWorld-style shrink-wrapping
(defmethod view-adjust-for-subviews ((view view) preferred-size border &optional (min-size #@(0 0)) (max-size #@(2000 2000)))
  (let* ((subviews (coerce (view-subviews view) 'list))
         (min-width (point-h min-size))
         (min-height (point-v min-size))
         max-h max-v new-size)
    (setf max-h (max& min-width
                      (+& border
                          (or 
                           (maximize subviews 
                                     :key #'(lambda (sv) (+& (point-h (view-size sv))
                                                             (point-h (view-position sv))))
                                     :return-max t)
                           0)))
          max-v (max min-height
                     (+& border
                         (or (maximize subviews 
                                       :key #'(lambda (sv) (+& (point-v (view-size sv))
                                                               (point-v (view-position sv))))
                                       :return-max t)
                             0))))
    (if preferred-size
      (setf new-size (point-max preferred-size (make-point max-h max-v)))
      (setf new-size (make-point max-h max-v)))
    (if max-size
      (setf new-size (point-min max-size new-size)))
    (unless (= new-size (view-size view))
      (set-view-size view new-size)
      t)))

(defun view-contained-by? (view container?)
  (cond ((null view) nil)
        ((eq view container?) t)
        (t (view-contained-by? (view-container view) container?))))

(defmethod view-position-relative ((view simple-view) some-superior)
  (let ((container (view-container view)))
    (cond ((eq some-superior container)
           (view-position view))
          ((null container)
           (error "~A is not contained in ~A" view some-superior))
          (t (add-points (view-position view)
                         (view-position-relative (view-container view) some-superior))))))

;;; accounts for scrolling
(defmethod view-real-position ((view simple-view))
  (subtract-points (view-position view)
                   (view-scroll-position view)))

(defmethod view-real-position-relative ((view simple-view) some-superior)
  (let ((container (view-container view)))
    (cond ((eq some-superior container)
           (view-real-position view))
          ((null container)
           (error "~A is not contained in ~A" view some-superior))
          (t (add-points (view-real-position view)
                         (view-real-position-relative (view-container view) some-superior))))))

(defmethod bring-to-top ((view view))
  (set-view-level view 0)
  (aif (view-container view)
       (bring-to-top it)))

(defmethod bring-to-top ((view window))
  (window-select view))

; for debugging
(defun view-hierarchy (view)
  (list view (mapcar #'view-hierarchy (coerce (view-subviews view) 'list))))

(defun window-under-point (point)
  (rlet ((winptr :pointer))
    (#_FindWindow point winptr)
    (window-object (%get-ptr winptr))))


;;; Low-level mouse manipulation

(defun warp-mouse (p)
  (%put-long (%int-to-ptr #$rawmouse) p)
  (%put-long (%int-to-ptr #$mtemp) p)
  (%put-byte (%int-to-ptr #$crsrnew)
             (%get-byte (%int-to-ptr #$crsrcouple))))

(defun raw-mouse ()
  (%get-long (%int-to-ptr #$rawmouse)))

(defun hide-mouse ()
  (%put-byte (%int-to-ptr #$CrsrVis) -1))       ; doesn't work very well (if at all)


;;; Resources and Records

(defun resource-info (res-handle)
  (rlet ((strptr :str255)
         (id :pointer)
         (type :ostype))
    (#_GetResInfo res-handle id type strptr)
    (values (%get-string strptr) (%get-word id) (%get-ostype type))))

(defun resourcep (handle)
  (and (handlep handle)
       (logbitp 5 (the fixnum (#_HGetState handle)))))

(defun purgeable? (handle)
  (and (handlep handle)
       (logbitp 6 (the fixnum (#_HGetState handle)))))

(defun all-resources-of-type (type &optional resfile)
  (let ((nrez (#_CountResources type))
        (result nil)
        res)
    (#_SetResLoad nil)
    (dotimes (n nrez)
      (setf res (#_GetIndResource type (1+ n)))
      (when (or (null resfile)
                (= resfile (#_HomeResFile res)))
        (push res result)))
    (#_SetResLoad t)
    result))

(defun resource-info (res-handle)
  (rlet ((strptr :str255)
         (id :pointer)
         (type :ostype))
    (#_GetResInfo res-handle id type strptr)
    (values (%get-string strptr) (%get-word id) (%get-ostype type))))

(defmacro check-reserr (&body body)
  `(let ((result (progn ,@body))
         (error (require-trap #_ResError)))
     (unless (zerop error)
       (error "Resource error ~D from ~A" error ',(car body)))
     result))

(defmacro with-handle ((var handle) &body body)         ;[35]
  `(let ((,var ,handle))
     (when (or (not (handlep ,var))     ; an unloaded handle looks like a pointer, sigh
               (resourcep ,var))
       (check-reserr (require-trap #_LoadResource ,var)))
     (require-trap #_HLock ,var)               ; +++ try locking around use.
     ,@body
     (require-trap #_HUnLock ,var)))

;;; A version of rref that figures out the handle/pointer problem for itself.
(defmacro rref* (pointer accessor)
  (once-only (pointer accessor)
    `(if (handlep ,pointer)
       (rref ,pointer ,accessor :storage :handle)
       (rref ,pointer ,accessor :storage :pointer))))
                            
;;; Files

(defun wildcard-copy (from to)
  (let ((files (directory from :directories nil :resolve-aliases t)))
    (dolist (file files)
      (unless (find #\~ (namestring file))
        (let ((to-file (merge-pathnames to file) ))
          (format t "~%Copying ~A to ~A" file to-file)
          (copy-file file to-file :fork :data))))))

;;; what truename ought to do, with a name I can remember
(defun realname (path)
  (mac-namestring path))

;;; Loading utilities

;;; example: (load (mt:rel-pathname "snip-dev-load.lisp" '(:up "Grasp")))

(defun here ()
  (pathname-directory (realname *loading-file-source-file*))       ; this is sometimes nil
;  (pathname-directory (car ccl::*loading-files*))       ; this is more reliable despite being undocumented
  )

(defun rel-pathname (name rel-path &optional (from (here)))
  (let ((dir (copy-list (if (listp from) from (pathname-directory from)))))
    (dolist (item rel-path)
      (cond ((eq :up item)
             (setf dir (butlast dir)))
            (t (setf dir (nconc dir (list item))))))
    (make-pathname :directory dir :defaults name)))

#|
;;; older stuff, I hope not needed any mode
;;; for loading
(defun define-local-host (host-name)
  (let ((here (pathname-directory *loading-file-source-file*)))
    (setf (logical-pathname-translations host-name)
          (list (list (make-pathname :host host-name :directory :wild :name :wild :type :wild)
                      (make-pathname :directory (nconc here (list :wild-inferiors)) :name :wild :type :wild))))))

(defun relative-pathname (root rel-path &optional (defaults root))
  (let ((dir (pathname-directory root)))
    (dolist (item rel-path)
      (cond ((eq :up item)
             (setf dir (butlast dir)))
            (t (setf dir (nconc dir (list item))))))
    (make-pathname :directory dir :defaults defaults)))
|#

;;; Menus, dialogs, etc.

;;; change a pop-up menu
(defmethod set-selected-item ((menu pop-up-menu) item)
  (let ((position (position item (menu-items menu))))
    (if position
      (progn
        (setf (ccl::pop-up-menu-default-item menu) (1+ position))       ; not exported in MCL2
        (invalidate-view menu))
      (error "~A isn't an item of ~A" item menu))))

;;; this ought to be in MCL, but it ain't
(defmethod set-dialog-item-enabled-p ((menu pop-up-menu) enabled?)
  (if enabled?
    (menu-enable menu)
    (menu-disable menu)))

;;; add a menu item at a particular point
(defun add-menu-item-at (menu item n)
  (let ((old-items (menu-items menu)))
    (apply #'remove-menu-items menu old-items)
    (apply #'add-menu-items menu (list-insert old-items item n))))


#|
;;; return a list of all mac processes: names and signatures
(require "appleevent-toolkit")
(defun all-mac-procs (&aux result)
  (do-processes (psn inforec)
    (declare (ignore psn))
    (push (list (%get-string (pref inforec :processInfoRec.ProcessName))
                (pref inforec :ProcessInfoRec.processSignature))
          result))
  result)
    
|#

;;; Possibly irritating hack (+++ put it under a variable)
#-CCL-3 ;[ppc] perhaps this is causing weird crashes in saved apps?
(advise ccl::break-loop (ccl::beep) :when :before :name :beep-on-error)
               


(provide :mcl-hacks)