[cells-devel] Emailing: MouseClick.lisp - cells-devel - mailman3.common-lisp.net

21 Feb 2004

      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

;-----------------------------------------