21 Feb
2004
21 Feb
'04
9:04 p.m.
Just in case...
kenny
--
http://tilton-technology.com
Why Lisp? http://alu.cliki.net/RtL%20Highlight%20Film
Your Project Here! http://alu.cliki.net/Industry%20Application
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
;;;
;;; Copyright © 2004 by Kenneth William Tilton.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is furnished
;;; to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;; IN THE SOFTWARE.
(in-package :cello)
(defmodel Mouse ()
((leftb :initarg :leftb :initform (cv :up) :accessor leftb)
(middleb :initarg :middleb :initform (cv :up) :accessor middleb)
(rightb :initarg :rightb :initform (cv :up) :accessor rightb)))
(defmodel MouseClick (Model Perishable)
((clickwindow :cell nil :initarg :clickwindow :initform nil :reader clickwindow)
(osEvent :cell nil :initarg :oSEvent :reader osEvent)
(clickee :cell nil :initarg :clickee :reader clickee)
(clickeePXY :reader clickeePXY :cell nil :initarg :clickeePXY)
(clickCompleted :reader clickCompleted
:initform (c? (when (typep (clickwindow self) 'Window) ;; <- acl used to turn windows into
(mouseUpEvt (clickwindow self))))) ;; closed-stream instances
(clickOver :reader clickOver
:initform (c? (when (typep (clickwindow self) 'Window)
(unless (^clickCompleted)
(when (mouse-over-p (clickee self))
(mousePos (clickwindow self)))))))
(inDrag :reader inDrag
:initform (c? (when (typep (clickwindow self) 'Window)
(unless (^clickCompleted)
(when (mouse-over-p (clickee self))
(mousePos (clickwindow self)))))))
(clicked :reader clicked
:initform (c? (trc nil "clicked?> typeof clickw" (clickwindow self) (type-of (clickwindow self)))
(when (typep (clickwindow self) 'Window)
(trc nil "clicked?> asking clickcompleted")
(bWhen (up (^clickCompleted))
(trc nil "clicked?> asking point-in-box"
(evtWhere up)
(clickee self)
(without-c-dependency
(screenbox (clickee self))))
(when (point-in-box (evtWhere up) ;; more precise than mPos
(without-c-dependency ;; moving GUI elements? chya
(screenbox (clickee self))))
(cons (clickee self) up))))))
)
(:default-initargs
:expiration (c? (mouseUpEvt (clickWindow self)))))
(defmethod initialize-instance :after ((self MouseClick) &key)
(when (typep (clickee self) 'Focus)
(unless (control-key-down (evtButtons (osEvent self))) ;; lame debugging enabler; make better
(focus-navigate (focus (clickWindow self)) (clickee self))))
(bwhen (ctxt (clickee self))
(do-mouseclick ctxt (clickWindow self) (osEvent self)))
(to-be self) ;; unnecessary? 2301kt just moved this from after next line
(trc nil "echo click set self clickee" (clickee self))
(bwhen (ctxt (clickee self)) ;; /// looks wrong with do-mouseclick above and now this
(set-mouseclick ctxt self))
)
(defmethod do-mouseclick (other w evt)
(declare (ignorable other w evt)))
(defmethod set-mouseclick (other click)
(declare (ignorable other click)))
(defmethod set-doubleclick? (other click)
(declare (ignorable other click)))
(defmethod not-to-be :around ((self MouseClick))
(when (typep (clickWindow self) 'Window) ;; /// why worry about this?
(trc nil "echo click clearing self from clickee" (clickee self))
(set-mouseclick (clickee self) nil) ;; do this first?
;; (trc "echo click not-to-be-ing self from clickee" self)
(call-next-method)
(set-doubleClick? (clickWindow self) self) ;; from Win32 days
))
(def-c-echo clicked ()
(when (and new-value (clickwindow self))
(trc nil "echo clicked calling control-do-action" self new-value)
(Control-do-action (car new-value) (cdr new-value))))
;----------------------------------------
(def-c-echo clickOver ()
(ctl-handle-over (clickee self) self new-value))
(defmethod ctl-handle-over (self clickStart overInfo)
(declare (ignore self clickStart overInfo)))
;;; (defmethod ctl-handle-over :before ((self control) clickStart overInfo)
;;; (declare (ignore clickStart))
;;; (setf (hilited self) overInfo)) ;; treat as flag: only issue is nil or not
;-----------------------------------------