Button of any shape

[bill@cambridge.apple.com (Bill St. Clair)]

At  8:21 PM 5/4/93 -0400, aspoerri@Athena.MIT.EDU wrote:
>Hi,
>
>I would like to create buttons that can be of any shape.
>Let's say, for example, I want buttons whose shape is a polygon.
>How difficult would it be to create them ?
>
>I have studied the documentation extensively, but I could
>not quite figure out how I could replace the rectangular 
>response region of a standard button with a polygon.
>
>I am a graduate student at MIT working on a visual
>interface for information retrieval, and I am using
>MacLisp as an enviroment to prototype the interface.
>Your help will be greatly appreciated !
>
>Anselm Spoerri
>CECI, MIT

Here's a half-hour hack that should get you started. You might also
look at Mike Engber's oodls os utils package, which is on the MCL 2.0 CD
and available for anonymous FTP from cambridge.apple.com in the
directory "/pub/mcl2/contrib". The version on our FTP server is more
recent. His package defines PICT dialog items and buttons and has a
button mixin class that is similar to my custom-button class below.

-Bill

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

; custom-button.lisp
;
; How to make your own buttons with non-rectangular shapes

(in-package :ccl)

(export '(custom-button toggle-hilite set-hilite track-mouse))

(defclass custom-button (dialog-item)
  ((hilited-p :initform nil :accessor hilited-p)))

(defmethod view-click-event-handler ((self custom-button) where)
  (unwind-protect
    ; where is in my container's coordinates (I'm a simple-view)
    (when (track-mouse self (subtract-points where (view-position self)))
      (call-next-method))               ; this calls dialog-item-action
    (set-hilite self nil)))

(defmethod focus-and-toggle-hilite ((self custom-button))
  (with-focused-view self
    (toggle-hilite self)))

(defmethod toggle-hilite ((self custom-button))
  (rlet ((rect :rect :topleft #@(0 0) :botright (view-size self)))
    (#_InvertRect rect))
  nil)

(defmethod toggle-hilite :after ((self custom-button))
  (setf (hilited-p self) (not (hilited-p self))))

(defmethod set-hilite ((self custom-button) hilite)
  (unless (eq (not (null hilite)) (not (null (hilited-p self))))
    (focus-and-toggle-hilite self)))

(defmethod view-draw-contents :after ((self custom-button))
  (when (hilited-p self)
    (setf (hilited-p self) nil)
    (toggle-hilite self)))

; Where is in the coordinate system of the button
(defmethod track-mouse ((self custom-button) where)
  (set-hilite self t)
  (loop
    (unless (mouse-down-p)
      (set-hilite self nil)
      (return (view-contains-point-p self (view-mouse-position self))))
    (setq where (view-mouse-position self))
    (set-hilite self (view-contains-point-p self where))))

#|
; This example creates a triangular button.
; Note that you need to inherit from custom-button and
; define methods for view-contains-point-p, view-draw-contents, and
; toggle-hilite.

(defclass triangle-button (custom-button) ())

(defmethod view-contains-point-p ((self triangle-button) where)
  (let* ((top 0)
         (left 0)
         (size (view-size self))
         (bottom (point-v size))
         (v (point-v where)))
    (and (>= v top)
         (< v bottom)
         (let* ((right (point-h size))
                (middle (round (+ right left) 2))
                (h (point-h where)))
           (and (>= h (+ left 
                         (round (* (- bottom v) (- middle left))
                                (- bottom top))))
                (< h (+ middle
                        (round (* (- v top) (- right middle))
                               (- bottom top)))))))))

(defmethod view-draw-contents ((self triangle-button))
  (draw-triangle self))

(defun draw-triangle (self)
  (let* ((pos (view-position self))
         (left (point-h pos))
         (top (point-v pos))
         (size (view-size self))
         (right (+ left (point-h size)))
         (bottom (+ top (point-v size)))
         (middle (round (- right left) 2)))
    (#_moveto middle top)
    (#_lineto right bottom)
    (#_lineto left bottom)
    (#_lineto middle top)))

(defmethod focus-and-toggle-hilite ((self triangle-button))
  (with-focused-view (view-container self)
    (toggle-hilite self)))

(defmethod toggle-hilite ((self triangle-button))
  (with-focused-view (view-container self)
    (let ((poly (#_OpenPoly)))
      (unwind-protect
        (draw-triangle self)
        (#_ClosePoly)
        (#_InvertPoly poly)
        (#_disposeHandle poly)))))

(defparameter *w*
  (make-instance 'dialog
    :view-subviews (list (make-instance 'triangle-button
                           :view-size #@(50 50)
                           :dialog-item-action #'(lambda (item)
                                                   (print item))))))
|#