I have created many aggregate widgets.  Here is my dialog widget, which is 
simply a dialog window that thinks it's a widget.  Following that is my vscroll 
widget, which is built on my dialog widget.  Evaluate everything and then 
evaluate the progn at the bottom.

In general, creating aggregate widgets takes a bit of hacking.  I've never been 
able to figure out the "official" or "clean" way to do many of the things I've 
done.  The fact that a widget is implemented as two objects (the pane and the 
widget) causes all sorts of headaches.  You have to be very careful about which 
functionality you put where.


Here are some questions of my own:

1.  Has anyone figured out how to link a header control widget with a dialog 
pane so that when the user moves the header control back and forth, the 
boundary line moves back and forth in the dialog pane?

2.  How can I get scroll bars where the "thumb" (the little box you manipulate 
with the mouse) is proportional instead of fixed length?

3.  Is there a code repository somewhere for stuff like this?  I recently moved 
to ACL from MCL, and the MCL folks have a great code repository.

--Matthew Haines

;;;;;;;;;;;;;;;
;;
;;  DIALOG WIDGET
;;
;;;;;;;;;;;;;;;


(defclass dialog-widget (dialog-item) ())

(defclass dialog-widget-pane (dialog)
    ((item :accessor pane-item :initform nil :initarg :dialog-item))
   (:default-initargs
    :page-height 300
    :user-scrollable nil
    :window-border :plain
    :user-resizable T
    :user-closable T
    :user-movable T
    ))

(defmethod widget-device ((item dialog-widget) dialog)
   'dialog-widget-pane)

(defmethod window-dialog-item ((pane dialog-widget-pane))
   (pane-item pane))

(defmethod redisplay-window ((pane dialog-widget-pane) &optional box)
   (call-next-method)
   t)

(defmethod expand-window ((pane dialog-widget-pane))
   (call-next-method)
   (invalidate-window pane (visible-box pane) t)
   (redisplay-window pane (visible-box pane))
   )

(defmethod pc::lisp-widget-clear-focus ((pane dialog-widget-pane)
                                        (widj dialog-widget))
   t)

(defmethod pc::lisp-widget-set-focus ((pane dialog-widget-pane)
                                      (widg dialog-widget))
   t)

(defmethod pc::lisp-widget-draw-focus ((pane dialog-widget-pane)
                                      (widg dialog-widget))
   t)

;;;;;;;;;;;;;;;
;;
;;  VSCROLL WIDGET
;;
;;;;;;;;;;;;;;;

(defvar *vscroll-width*)
(setq *vscroll-width* 16)

(defclass vscroll-widget (dialog-widget)
    ((vscroll-bar :accessor widget->vscroll-bar)
     (front-pane :accessor widget->front-pane)
     (back-pane :accessor widget->back-pane)
     ))

(defclass vscroll-bar (vertical-scroll-bar)
    ((front-pane :accessor vscroll->front-pane))
   (:default-initargs
    :bottom-attachment :bottom
    :right-attachment :right
    :left-attachment :right
    :page-increment 100
    :delayed NIL
    :set-value-fn #'set-vscroll-page         
    ))

(defclass vscroll-front-pane (dialog)
     ((widget :accessor front-pane->widget)
      (vscroll-bar :accessor front-pane->vscroll-bar)
      (item :accessor window-dialog-item :initform NIL))
   (:default-initargs
    :bottom-attachment :bottom
    :right-attachment :right
    :user-scrollable NIL
    :window-border :none))

(defmethod widget-device ((widget vscroll-widget) (dialog dialog-mixin))
   'vscroll-front-pane)

(defclass vscroll-back-pane (memorex-mixin dialog) ()
   (:default-initargs
    :bottom-attachment :bottom
    :right-attachment :right
    :user-scrollable NIL))



(defmethod add-widget ((widget vscroll-widget) (dialog dialog-mixin) 
                       &optional in-back-p hidden-p
                       &aux front-pane back-pane vscroll-bar)
   (setq back-pane
      (open-dialog nil 'vscroll-back-pane dialog
         :window-exterior (slot-value widget 'box)
         :user-scrollable NIL
         :user-movable NIL
         :user-closable NIL
         :window-border :plain
         :pop-up-p NIL))
   (let* ((height (window-interior-height back-pane))
          (width (window-interior-width back-pane))
          (divide (- width *vscroll-width*))
          (dlg-box (make-box 0 0 (- divide 2) height))
          (scroll-range (or (dialog-item-range widget) 0))
          (scroll-box (make-box divide 0 width height)))
      (setf (slot-value widget 'box) dlg-box)
      (setq front-pane (open-dialog-item widget back-pane hidden-p))
      (setq vscroll-bar       
         (make+add-widget back-pane 'vscroll-bar NIL
            :window-exterior scroll-box
            :border :none
            :range (list 0 (max 0 (- scroll-range height)))
            :box scroll-box))
      )
   
   (setf (slot-value widget     'window) front-pane)
   (setf (slot-value front-pane 'item)   widget)
   (setf (widget->back-pane   widget)      back-pane)
   (setf (widget->front-pane  widget)      front-pane)
   (setf (widget->vscroll-bar widget)      vscroll-bar)
   (setf (front-pane->vscroll-bar front-pane)  vscroll-bar)
   (setf (vscroll->front-pane vscroll-bar)     front-pane)
   
      
   ;; Standard cleanup copied from base method.
   (push widget (slot-value dialog 'dialog-items))
   (pc::check-widgets dialog)
   widget)

(defun set-vscroll-page (widget new old)
   (scroll-to (vscroll->front-pane widget) (make-position 0 new))
   T)

(defmethod set-scroll-range ((pane vscroll-front-pane) x y &optional x-thumb 
y-thumb)
   (when (slot-boundp pane 'vscroll-bar)
      (let ((win (dialog-item-window (front-pane->vscroll-bar pane))))
         (progn-if (zerop y)
            ((shrink-window win T))
            ((expand-window win)
             (setf (dialog-item-range (front-pane->vscroll-bar pane))
                   (list 0 y)))))))

(let (focus)
   (defmethod event :before ((stream vscroll-bar)
                             (num (eql mouse-in))
                             state data time)
      (setq focus (get-focus *planet-window*)))
   (defmethod event :after ((stream vscroll-bar)
                            (num (eql mouse-out))
                            state data time)
      (set-focus focus)))

(defclass slot-pane-vscroll-pane (filler-mixin vscroll-front-pane) ())

(defclass slot-pane-vscroll-widget (vscroll-widget) ())

(defmethod widget-device ((widget slot-pane-vscroll-widget) (dialog 
dialog-mixin))
   'slot-pane-vscroll-pane)

#|

(progn
   (setq *d* (open-dialog nil 'dialog *planet-window* :pop-up-p NIL
             :window-exterior (make-box 100 100 400 400)))
   
   (setq *w*
      (make+add-widget *d* 'vscroll-widget NIL
         :box (make-box 30 30 250 200)
         :range 500
         ))
   (let ((str "this is a sreally long string that is getting longer as I type"))
   (draw-string-in-box (dialog-item-window *w*) str 0 (length str)
      (make-box 10 10 50 200) :center :center NIL T)))

|#