Some questions and another "fun" dialog item!

[hohmann@zug.csmil.umich.edu]

Hello Fellow MCLer's:

This mail contains three parts:
  1)  A question regarding buffer-marks, 
  2)  A question regarding undocumented but really useful functions, and,
  3)  A "new" dialog item.  I hope that one of the really excellent
      lisp hackers (Steve, Mike Engbar, Matt, Bill St. Clair, etc.)
      will take a look at the code and consider adding this dialog-item
      to their utilities.

Here goes:

1) Buffer Marks

In MCL 1.3.2, you had to explicitly kill marks that you created with
a call to kill-mark.  I think this was because buffers somehow had
to associate themselves with the mark, and this association would
prevent the mark from being garbage collected when you were finished
using the mark.

In MCL 2.0, you create buffer-marks in a similar manner, (i.e.,
see page 363 of the manual) but there is no kill-mark function.
I am a little worried about this, because my code relies *extensively*
on having many marks (MCL 1.3.2) or buffer-marks (MCL 2.0) associated
with a fred-window.  My question boils down to:

   How are buffer-marks that a create but no longer reference
   manager by the MCL class fred-mixin?  I want to be certain that
   these puppies are garbage collected.

If you need example code to make this question more concrete,
just holler....

2) Undocumented functions

In the file "windoid-key-events" in the examples folder, there
is a function called window-object.  It is documented in the help
system, but does not appear in the manual.  This is a useful function
(see code below) and I hate the general feeling that many more
functions like this exist but are undocumented - and hence, inherently
unusable.  

  (I don't know about you, but I always *hate* that feeling that
   "sure, this hunk of lisp code works, but how can I be certain
    that there isn't ONE function that does the same job as my
    5 lines of code...)

3) A fun dialog item

I am in the process of creating a lot of tools to support direct
manipulation of program objects.  What follows is a very simple
sequence dialog item that allows you to directly "drag" out one of
its items and "drop" it on a window.  I think all the code is
correct (well, at least it doesn't crash my Mac SE or my Mac IIci)
but I'll warn you that it isn't 100% general - it is rather like
my "restricted-text-dialog-item" that I find useful.

Oh - thanks for all the *wonderful* comments for extending the
functionality of the restricted-text-dialog-item.  I found all of
them stimulating, and I apologize for 1) not directly answering
all mail messages and 2) not really working on the suggestions.
I was in the death throes of finals, and I am getting married
in two weeks (YEAH!!!! Jamaica here I come!) so I'm just concentrating
on transferring only those parts of my 1.3.2 system that I 
absolutely need in 2.0.

Enough JABBER - here is some code.  If you extend it, let me
know....



;; sorry for the minimal documentation - I'm still playing
;; with this code....

;;  Luke!

(require 'quickdraw)

;; thanks to Mike Engbar for letting me steal this ;-)
;;
(defmacro with-clip-rect-intersect (rect &rest body)
    (let ((old (gensym))
          (new (gensym)))
      `(let ((,old (#_NewRgn))
             (,new (#_NewRgn)))
         (#_getclip ,old)
         (#_rectrgn ,new ,rect)
         (#_SectRgn ,old ,new ,new)
         (#_SetClip ,new)
         (unwind-protect
           (progn ,@body)
           (#_SetClip ,old)
           (#_DisposeRgn ,old)
           (#_DisposeRgn ,new)))))


;; there are many times when we want an item to be always dragable.
;; if this is the case, we use this as the drag function
;;
(defun always-draggable (obj) 
  (declare (ignore obj))
  t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; this is the method that is called when an object is dropped
;; on a window.  The default is mainly used for debugging!
;;
(defmethod window-dropped-on ((self window) what where)
  (format t "~a was dropped on ~a at ~a~%" 
          what (window-title self) (point-string where)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; define some constants needed for the dragging and dropping
;;
(defconstant $incontent 3)

;; the default is always draggable
;;
(defclass dragable-sequence-dialog-item (sequence-dialog-item)
  ((drag-checker :initarg :drag-checker :accessor drag-checker))
  (:default-initargs
    :drag-checker t))

(defmethod view-click-event-handler
           ((self dragable-sequence-dialog-item) where)
  (cond
   ; the first test ignores clicks in the vertical scrollbar
   ; obviously this needs to be extended to actually check to
   ; make sure there is a vertical scrollbar, and similar checks
   ; need to made for horizontal scrollbars
   ;
   ((> (point-h where) 
       (point-h (add-points (- (view-size self) 16) 
                            (view-position self))))
    (call-next-method self where))
   (t
    ; get the clicked on cell, and, if it is not selected,
    ; select it.  If it can be dragged, drag it.
    ;
    (let* ((currently-selected-cell (car (selected-cells self)))
           (the-clicked-cell (point-to-cell self where)))
      (unless (eq currently-selected-cell the-clicked-cell)
        (when currently-selected-cell (cell-deselect self currently-selected-cell)))
      (when the-clicked-cell
        (cell-select self the-clicked-cell)
        (let ((the-cell-contents (cell-contents self the-clicked-cell)))
          (when (funcall (drag-checker self) the-cell-contents)
            (let* ((topleft     (cell-position self the-clicked-cell))
                   (bottomright (add-points topleft (cell-size self)))
                   (reg (#_NewRgn))
                   where-dropped)
              (unwind-protect
                (with-port (%stack-block ((port 4))
                             (#_GetWmgrPort port)
                             (%get-ptr port))
                  (rlet ((rect :rect :topleft topleft :bottomright bottomright))
                    (#_RectRgn reg rect)
                    (setf (rref rect :rect.topleft) (make-point 0 *menubar-bottom*))
                    (setf (rref rect :rect.bottomright)
                          (make-point *screen-width* *screen-height*))
                    (with-clip-rect rect
                      (let* ((pos
                              (add-points
                               where
                               (#_DragGrayRgn reg where rect rect 0 (%null-ptr)))))
                        
                        (rlet ((which-window :pointer))
                          (setf where-dropped (#_FindWindow pos which-window))
                          (%setf-macptr which-window (%get-ptr which-window))
                          (when (and (not (%null-ptr-p which-window))
                                     (eq where-dropped $incontent))
                            (window-dropped-on (window-object which-window)
                                               the-cell-contents
                                               (global-to-local (window-object which-window) pos))))))))
                    
                ; it is good to be neat
                ;
                (#_DisposeRgn reg))))))))))



#|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; some sample code
;;

(defvar *is-draggable* nil)

(defun test-drag-checker (a-name-obj)
  (format t "testing ~a~%" a-name-obj)
  (string= "average" (name a-name-obj)))
    

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass *nameobj* () 
  ((name :initarg :name :initform "sample" :accessor name)))


(defun print-nameobj (a-nameobj a-stream)
  (format a-stream "~a" (name a-nameobj)))


(defclass *testwin* (dialog)
  ((window-do-first-click :initform t :accessor window-do-first-click))
  (:default-initargs
    :window-type :document 
    :window-title "sample dialog"
    :view-position #@(63 172)
    :view-size #@(185 100)))


(defmethod initialize-instance :after ((self *testwin*) &rest initargs)
  (add-subviews self
                (make-instance 'dragable-sequence-dialog-item
                  :drag-checker   'test-drag-checker
                  :view-position         #@(17 18)
                  :view-size             #@(156 60)
                  :dialog-item-text      "sample"
                  :view-nick-name        'nameobj-list
                  :cell-size             #@(140 16)
                  :table-hscrollp        nil
                  :table-print-function  'print-nameobj
                  :table-vscrollp        t
                  :table-sequence
                  (list (make-instance '*nameobj* :name "count")
                        (make-instance '*nameobj* :name "average")
                        (make-instance '*nameobj* :name "0")
                        (make-instance '*nameobj* :name "total")
                        (make-instance '*nameobj* :name "sum")))))



(make-instance '*testwin*)

|#