widget.lisp

   1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
   2 #|
   3
   4     Celtk -- Cells, Tcl, and Tk
   5
   6 Copyright (C) 2006 by Kenneth Tilton
   7
   8 This library is free software; you can redistribute it and/or
   9 modify it under the terms of the Lisp Lesser GNU Public License
  10  (http://opensource.franz.com/preamble.html), known as the LLGPL.
  11
  12 This library is distributed  WITHOUT ANY WARRANTY; without even
  13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15 See the Lisp Lesser GNU Public License for more details.
  16
  17 |#
  18
  19 (in-package :Celtk)
  20
  21 ;;; --- widget tkwin window glue -----------------------
  22
  23 (defun widget-to-tkwin (self)
  24   (tk-name-to-window *tki* (path self) (tk-main-window *tki*)))
  25
  26 (defun xwin-register (self)
  27   (when (tkwin self)
  28     (let ((xwin (tkwin-window (tkwin self))))
  29       (unless (zerop xwin)
  30         (setf (gethash xwin (xwins .tkw)) self)
  31         xwin))))
  32
  33 (defun tkwin-widget (tkwin)
  34   (assert *tkw*)
  35   (assert (tkwins *tkw*) () "Widget hash NIL for *tkw* ~a" *tkw*)
  36   (gethash (pointer-address tkwin) (tkwins *tkw*)))
  37
  38 (defun xwin-widget (xwin) ;; assignment of xwin is deferred so...all this BS..
  39   (when (plusp xwin)
  40     (or (gethash xwin (xwins *tkw*))
  41       (loop for self being the hash-values of (tkwins *tkw*)
  42           using (hash-key tkwin)
  43           unless (xwin self) ;; we woulda found it by now
  44           do (when (eql xwin (xwin-register self))
  45                (return-from xwin-widget self))
  46           finally (trc "xwin-widget > no widget for xwin " xwin)))))
  47
  48 ;;; --- widget -----------------------------------------
  49
  50 (defmodel widget (family tk-object)
  51   ((path :accessor path :initarg :path
  52      :initform (c? (eko (nil "path" self (parent-path (fm-parent self))(md-name self))
  53                      (format nil "~(~a.~a~)"
  54                        (parent-path (fm-parent self))
  55                        (md-name self)))))
  56    (tkwin :cell nil :accessor tkwin :initform nil)
  57    (xwin :cell nil :accessor xwin :initform nil)
  58    (packing :reader packing :initarg :packing :initform nil)
  59    (gridding :reader gridding :initarg :gridding :initform nil)
  60    (parent-x :reader parent-x :initarg :parent-x :initform nil)
  61    (parent-y :reader parent-y :initarg :parent-y :initform nil)
  62    (relx :reader relx :initarg :relx :initform nil)
  63    (rely :reader rely :initarg :rely :initform nil)
  64    (enabled :reader enabled :initarg :enabled :initform t)
  65    (event-handler :reader event-handler :initarg :event-handler :initform nil)
  66    (menus :reader menus :initarg :menus :initform nil
  67      :documentation "An assoc of an arbitrary key and the associated CLOS menu instances (not their tk ids)")
  68    (image-files :reader image-files :initarg :image-files :initform nil)
  69    (tk-selector :reader tk-selector :initarg :tk-selector
  70      :initform (c? (upper self tk-selector))))
  71   (:default-initargs
  72       :id (gentemp "W")
  73     :event-handler nil #+debug (lambda (self xe)
  74                                  (TRC "debug event handler" self (tk-event-type (xsv type xe))))))
  75
  76 (eval-now!
  77   (export '()))
  78
  79 (defun tk-create-event-handler-ex (widget callback-name &rest masks)
  80   (let ((self-tkwin (widget-to-tkwin widget)))
  81     (assert (not (null-pointer-p self-tkwin)))
  82     (trc nil "setting up widget virtual-event handler" widget callback-name :tkwin self-tkwin :masks masks)
  83     (tk-create-event-handler self-tkwin
  84       (foreign-masks-combine 'tk-event-mask :PointerMotionMask)
  85       (get-callback callback-name)
  86       self-tkwin)
  87     (tk-create-event-handler self-tkwin
  88       (apply 'foreign-masks-combine 'tk-event-mask masks)
  89       (get-callback callback-name)
  90       self-tkwin)))
  91
  92 (defun widget-menu (self key)
  93   (or (find key (^menus) :key 'md-name)
  94     (break "The only menus I see are~{ ~a,~} not requested ~a" (mapcar 'md-name (^menus)) key)))
  95
  96 (defmacro ^widget-menu (key)
  97   `(widget-menu self ,key))
  98
  99 (defun tkwin-register (self)
 100   (let ((tkwin (or (tkwin self)
 101                   (setf (tkwin self)
 102                     (tk-name-to-window *tki* (^path) (tk-main-window *tki*))))))
 103     (if (not (zerop tkwin))
 104         (trc nil "got tkwin" self tkwin)
 105       (break "under *tki* ~a unable to get window-ptr for ~a in main ~a" *tki* (^path) (tk-main-window *tki*)))
 106     (setf (gethash (pointer-address tkwin) (tkwins .tkw)) self)))
 107
 108 (defmethod make-tk-instance ((self widget))
 109   (setf (gethash (^path) (dictionary .tkw)) self)
 110   (trc nil "mktki" self (^path))
 111   (with-integrity (:client `(:make-tk ,self))
 112     (when (tk-class self)
 113       (tk-format-now "~(~a~) ~a ~{~(~a~) ~a~^ ~}" ;; call to this GF now integrity-wrapped by caller
 114         (tk-class self) (path self)(tk-configurations self)))))
 115
 116 (defmethod tk-class :around ((self widget))
 117   (conc$ (when (tile? self) "TTK::") (call-next-method)))
 118
 119 (defmethod make-tk-instance :after ((self widget))
 120   (with-integrity (:client `(:post-make-tk ,self))
 121     (tkwin-register self)
 122     (tk-create-event-handler-ex self 'widget-event-handler-callback -1)))
 123
 124 (defobserver parent-x ((self widget))
 125   (unless (typep self 'window)
 126     (when new-value
 127       (tk-format `(:grid ,self) ;; placing is like grid for this sort
 128         "place ~a ~a -x ~a -y ~a" (if old-value "configure" "")
 129         (^path) new-value (^parent-y)))))
 130
 131 (defcallback widget-event-handler-callback :void  ((client-data :pointer)(xe :pointer))
 132   (bif (self (tkwin-widget client-data))
 133         (widget-event-handle self xe)
 134         ;; sometimes I hit the next branch restarting after crash....
 135         (trc "widget-event-handler > no widget for tkwin ~a" client-data))
 136   #+nahhh(handler-case
 137       (bif (self (tkwin-widget client-data))
 138         (widget-event-handle self xe)
 139         ;; sometimes I hit the next branch restarting after crash....
 140         (trc "widget-event-handler > no widget for tkwin ~a" client-data))
 141     (excl:simple-break (error)
 142       (declare (ignorable error))
 143       (trc "widget-event-handler-callback honoring break" error)
 144      (invoke-debugger error)
 145       )
 146     (t (error)
 147       (declare (ignorable error))
 148       (trc "widget-event-handler-callback ignoring error" error)
 149       ;;#-demo (invoke-debugger error)
 150       ))
 151 ;;;  #+demo
 152 ;;;  (handler-case
 153 ;;;      (bif (self (tkwin-widget client-data))
 154 ;;;        (widget-event-handle self xe)
 155 ;;;        ;; sometimes I hit the next branch restarting after crash....
 156 ;;;        (trc "widget-event-handler > no widget for tkwin ~a" client-data))
 157 ;;;    (t (error)
 158 ;;;      (declare (ignorable error))
 159 ;;;      #-demo (invoke-debugger error)
 160 ;;;      ))
 161 ;;;  #+development
 162 ;;;  (progn
 163 ;;;
 164 ;;;    (bif (self (tkwin-widget client-data))
 165 ;;;      (widget-event-handle self xe)
 166 ;;;      ;; sometimes I hit the next branch restarting after crash....
 167 ;;;      (trc "widget-event-handler > no widget for tkwin ~a" client-data)))
 168   )
 169
 170 (export! widget-event-handle)
 171
 172 (defmethod widget-event-handle ((self widget) xe) ;; override for class-specific handling
 173   (trc nil "bingo widget-event-handle" (xevent-type xe))
 174   (bif (h (^event-handler)) ;; support instance-specific handlers
 175     (funcall h self xe)
 176     (case (xevent-type xe)
 177       (:buttonpress (trc "button pressed:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe)))
 178       (:buttonrelease (trc "button released:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe)))(:MotionNotify
 179        (xevent-dump xe))
 180       (:virtualevent))))
 181
 182 (defmethod tk-configure ((self widget) option value)
 183   (tk-format `(:configure ,self ,option) "~a configure ~(~a~) ~a" (path self) option (tk-send-value value)))
 184
 185
 186 (defmethod not-to-be :after ((self widget))
 187   (when (or (and (eql self .tkw) (not (find .tkw *windows-destroyed*)))
 188           (not (find .tkw *windows-being-destroyed*)))
 189     (trc "not-to-be destroying widget" (^path))
 190     (break "not to be")
 191     (tk-format `(:forget ,self) "pack forget ~a" (^path))
 192     (tk-format `(:destroy ,self) "destroy ~a" (^path))))
 193
 194 ;;; --- commander mix-in --------------------------------
 195
 196 (defclass commander ()
 197   ()
 198   (:default-initargs
 199       :command (c? (format nil "do-on-command ~a" (^path)))))
 200
 201
 202 ;;; --- items -----------------------------------------------------------------------
 203
 204 (eval-now!
 205   (export '(canvas-offset ^canvas-offset coords-tweak ^coords-tweak caret-tweak ^caret-tweak
 206              decorations ^decorations)))
 207
 208 (defmodel item-geometer () ;; mix-in
 209   ()
 210   #+vestigial?
 211   ((canvas-offset :initarg :canvas-offset :accessor canvas-offset
 212      :initform (c_? (eko (nil "standard canvas offset" self (type-of self) (^p-offset))
 213                      (c-offset self))))
 214    (caret-tweak :initarg :caret-tweak :accessor caret-tweak :initform '(0 0))
 215    (l-bounds :initarg :l-bounds :initform nil :reader l-bounds
 216      :documentation "Vector of local left, top, right, bottom")
 217    (p-offset :initarg :p-offset :reader p-offset :initform '(0 0))
 218    (p-bounds :initarg :p-bounds :reader p-bounds
 219      :documentation "Vector of parent-relative left, top, right, bottom"
 220      :initform (c_? (when (and (^l-bounds)(^p-offset) )
 221                      (bounds-offset (^l-bounds) (^p-offset))))))
 222   (:documentation "For things like mx-power, which inhabit canvases but need no item for visual representation."))
 223
 224 (defmethod l-bounds :around (i)
 225   (or (call-next-method)
 226     (break "no l-bounds for ~a" i)))
 227
 228 (defmethod anchor (other)(declare (ignore other)) nil)
 229
 230 (defmodel item (item-geometer tk-object)
 231   ((id-no :cell nil :initarg :id-no :accessor id-no :initform nil)
 232    (l-coords :initarg :l-coords :initform nil :accessor l-coords)
 233    (coords-tweak :initarg :coords-tweak :initform '(0 0) :accessor coords-tweak
 234      :documentation "Text items need this to get positioned according to baseline")
 235    (coords :initarg :coords :accessor coords
 236      :initform nil #+old (c_? (eko (nil "final coords" self (anchor self)(^l-coords)(^canvas-offset)(^coords-tweak))
 237                      (loop for coord-xy = (^l-coords) then (cddr coord-xy)
 238                          while coord-xy
 239                          nconcing (mapcar '+ coord-xy (^canvas-offset) (^coords-tweak))))))
 240    (decorations :initarg :decorations :accessor decorations :initform nil
 241      :documentation "eg, For a left parens text item, the corresponding right parens text item")
 242    )
 243   (:documentation "Things you put on a canvas")
 244   (:default-initargs
 245       :id (gentemp "I")))
 246
 247 (defmethod make-tk-instance :around ((self item))
 248   (when (upper self canvas)
 249     (call-next-method)))
 250
 251 (defmethod make-tk-instance ((self item))
 252   (when (tk-class self)
 253     (with-integrity (:client `(:make-tk ,self))
 254       (ASSERT (^coords) () "Item ~a missing req'd coords" self)
 255       (setf (id-no self) (tk-eval "~a create ~a ~{ ~a~}  ~{~(~a~) ~a~^ ~}"
 256                            (path (upper self canvas))
 257                            (down$ (tk-class self))
 258                            (coords self)
 259                            (tk-configurations self))))))
 260
 261 (defmethod tk-configure ((self item) option value)
 262   (assert (id-no self) () "cannot configure item ~a until instantiated and id obtained" self)
 263   (tk-format `(:configure ,self ,option)
 264     "~A itemconfigure ~a ~a ~a" (path .parent) (id-no self) (down$ option) (tk-send-value value)))
 265
 266 (defobserver coords ()
 267   (when (and (id-no self) new-value)
 268     (trc nil "coords observer setting item" self (id-no self))
 269     (tk-format `(:configure ,self)
 270       "~a coords ~a ~{ ~a~}" (path .parent) (id-no self) new-value)))
 271
 272 (defmethod not-to-be :after ((self item))
 273   (unless (find .tkw *windows-destroyed*)
 274     ;(trc "whacking item" self)
 275     (tk-format `(:delete ,self) "~a delete ~a" (path (upper self widget)) (id-no self))))
 276
 277 ;;; --- widget mixins ------------------------------
 278
 279 ;;; --- tk-selector ---------------------------------------------------
 280
 281 (defmodel tk-selector () ;; mixin
 282   ((selection :initform nil :accessor selection :initarg :selection)
 283    (tk-variable :initform nil :accessor tk-variable :initarg :tk-variable
 284      :documentation "The TK node name to set as the selection changes (not the TK -variable option)"))
 285   (:default-initargs
 286       :selection (c-in nil)
 287       :tk-variable (c? (^path))))
 288
 289 (defobserver selection ((self tk-selector))
 290   ;
 291   ; handling varies on this, so we hand off to standard GF lest the PROGN
 292   ; method combo on slot-listener cause multiple handling
 293   ;
 294   (tk-output-selection self new-value old-value old-value-boundp))
 295
 296 (defmethod tk-output-selection (self new-value old-value old-value-boundp)
 297   (declare (ignorable old-value old-value-boundp))
 298   (trc nil "selection output" self new-value)
 299   (when new-value
 300     (with-integrity (:client `(:variable ,self))
 301       (let ((v$ (if (stringp new-value) ;; just going slow on switching over to C API before changing tk-send-value
 302                     new-value
 303                     (tk-send-value new-value))))
 304         (tcl-set-var *tki* (tk-variable self) v$ (var-flags :tcl-namespace-only))))))
 305
 306
 307
 308
 309
 310 ;;; --- menus ---------------------------------
 311
 312 (defun pop-up (menu x y)
 313   (trc nil "popping up" menu x y)
 314   (tk-format-now "tk_popup ~A ~A ~A" (path menu) x y))