;;;-*- Mode: Lisp; Package: CCL -*-
;;;
;;; little-arrows-dialog-item7.lisp
;;;
;;; Patches little-arrows-dialog-item.lisp for BACKWARDS COMPATIBILITY WITH MACOS 7
;;;
;;; Copyright ©1999 Terje Norderhaug and Media Design inĄProgress
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted, so long as this copyright 
;;; notice is included intact.
;;;
;;; This software is made available AS IS, and no warranty is made about 
;;; the software or its performance. 
;;;
;;; Author: Terje Norderhaug <terje@in-progress.com> of Media Design in*Progress.
;;;
;;; Latest version available from <http://www.in-progress.com/src/little-arrows-dialog-item7.lisp>.
;;; Tested on MCL 4.2, but should also work with other recent versions of MCL.
;;; Should normally be used with the Appearance Manager extension to MCL by Eric Russell.

#| VERSION HISTORY:


1999-Jul-27 Terje  Version 1.0 released.
|#

(in-package :ccl)

(require :little-arrows-dialog-item)

(defparameter %little-arrows-direction% NIL)

(defmethod view-draw-no-appearance-contents ((item little-arrows-dialog-item))
  (with-focused-view (view-container item)
    (with-item-rect (rect item)
      (inset-rect rect 1 0)
      (offset-rect rect -1 0)
      (with-back-color (part-color item :back-color)
       (with-fore-color (if (dialog-item-enabled-p item) *black-color* *gray-color*)
        (#_eraseroundrect rect 5 5)
        (#_frameroundrect rect 5 5)
        (#_MoveTo 
          (+ (rref rect rect.left) 3)
          (+ (rref rect rect.top) 4))
        (#_Move :long #@( 3 0))
        (#_Line :long #@( 1 1))
        (#_Line :long #@(-2 0))
        (#_Line :long #@(-1 1))
        (#_Line :long #@( 4 0))
        (#_Move :long #@( 0 10))
        (#_Line :long #@(-4 0))
        (#_Line :long #@( 1 1))
        (#_Line :long #@( 2 0))
        (#_Line :long #@(-1 1))        
        (let ((split (floor (+ (rref rect rect.top) (rref rect rect.bottom)) 2)))
          (#_MoveTo (rref rect rect.left) split)
          (#_LineTo (1- (rref rect rect.right)) split)
          (when %little-arrows-direction%
            (inset-rect rect 1 1)
            (case %little-arrows-direction%
              (:up-button 
                (setf (rref rect rect.bottom) split)) 
              (:down-button
                (setf (rref rect rect.top) (1+ split))))
            (#_invertrect rect))))))))

(defmethod little-arrow-direction ((item little-arrows-dialog-item) pos)
  (rlet ((rect :rect :topleft #@(0 0) :botright (view-size item)))
    (when (point-in-rect-p rect pos)
      (if (< (point-v pos)
             (+ 2 (floor (point-v (view-size item)) 2)))
        :up-button
        :down-button))))

(defmethod view-click-event-handler :around ((item little-arrows-dialog-item) where)
  (declare (ignore where))
  (if (appearance-available-p)
    (call-next-method)
    (when (dialog-item-enabled-p item)
      (with-focused-view item
        (loop
          for dir = (little-arrow-direction item (view-mouse-position item))
          do (unless (eq %little-arrows-direction% dir)
               (setf %little-arrows-direction% dir)
               (force-view-draw-contents item))
          do (when dir
               (track-little-arrows item 1 dir))
          do (process-wait "Doubletime"
               #'(lambda ()
                   (or (not (mouse-down-p))
                       (> (- (get-tick-count) *last-mouse-down-time*)
                             (#_LMGetDoubleTime)))))
          do (process-wait-with-timeout "MouseUp" 5 
               #'(lambda ()
                   (not (mouse-down-p))))
          while (mouse-down-p) 
          do (%run-masked-periodic-tasks))
        (setf %little-arrows-direction% NIL)
        (force-view-draw-contents item)))))

(defmethod set-little-arrows-setting :around ((item little-arrows-dialog-item) value)
  (cond
    ((appearance-available-p)
       (call-next-method))
    (T
       (setf (slot-value item 'setting) value)
       (dialog-item-action item))))


#|

(setf *APPEARANCE-AVAILABLE-P* NIL)

(make-instance 'window
  ; :back-color *tool-back-color*
  :view-subviews
    (list 
      (make-instance 'little-arrows-dialog-item)
      (make-instance 'little-arrows-dialog-item :view-position #@(20 15)
        :dialog-item-enabled-p NIL)))

|#

;;;;;;;;;;;;;;;;

(provide :little-arrows-dialog-item7)