tk-events.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
  20 (in-package :celtk)
  21
  22
  23 (defcfun ("Tcl_DoOneEvent" Tcl_DoOneEvent) :int
  24   (flags :int))
  25
  26 (defcfun ("Tcl_DoWhenIdle" tcl-do-when-idle) :void
  27   (tcl-idle-proc :pointer)
  28   (client-data :pointer))
  29
  30 (defcfun ("Tcl_SetResult" tcl-set-result) :void
  31   (interp :pointer)
  32   (result :string)
  33   (free-proc :pointer))
  34
  35 (defcfun ("Tcl_GetString" tcl-get-string) :string
  36   (tcl-obj :pointer))
  37
  38 (defcallback tcl-idle-proc :void ((client-data :pointer))
  39   (unless (c-stopped)
  40     (print (list :idle-proc :client-data client-data))))
  41
  42 ;; Tk_MainLoop
  43
  44 (defcfun ("Tk_MainLoop" Tk_MainLoop) :void)
  45
  46 (defcfun ("Tk_CreateEventHandler" tk-create-event-handler) :void
  47   (tkwin :pointer)
  48   (mask :int)
  49   (proc :pointer)
  50   (client-data :pointer))
  51
  52 (defcenum tk-event-type ;; do not try to generate masks from these!
  53     "Ok for interpreting type field in event, but not for (expt 2 etype) to get mask"
  54   (:KeyPress 2)
  55   :KeyRelease
  56   :ButtonPress
  57   :ButtonRelease
  58   :MotionNotify
  59   :EnterNotify
  60   :LeaveNotify
  61   :FocusIn
  62   :FocusOut
  63   :KeymapNotify
  64   :Expose
  65   :GraphicsExpose
  66   :NoExpose
  67   :VisibilityNotify
  68   :CreateNotify
  69   :DestroyNotify
  70   :UnmapNotify
  71   :MapNotify
  72   :MapRequest
  73   :ReparentNotify
  74   :ConfigureNotify
  75   :ConfigureRequest
  76   :GravityNotify
  77   :ResizeRequest
  78   :CirculateNotify
  79   :CirculateRequest
  80   :PropertyNotify
  81   :SelectionClear
  82   :SelectionRequest
  83   :SelectionNotify
  84   :ColormapNotify
  85   :ClientMessage
  86   :MappingNotify
  87   :virtualEvent
  88   :ActivateNotify
  89   :DeactivateNotify
  90   :MouseWheelEvent)
  91
  92
  93
  94 (defcenum tk-event-mask
  95     "Use to filter events when calling tk-create-event-handler"
  96   :NoEventMask
  97   (:KeyPressMask                        #.(ash 1 0))
  98   (:KeyReleaseMask              #.(ash 1 1))
  99   (:ButtonPressMask             #.(ash 1 2))
 100   (:ButtonReleaseMask           #.(ash 1 3))
 101   (:EnterWindowMask             #.(ash 1 4))
 102   (:LeaveWindowMask             #.(ash 1 5))
 103   (:PointerMotionMask           #.(ash 1 6))
 104   (:PointerMotionHintMask       #.(ash 1 7))
 105   (:Button1MotionMask           #.(ash 1 8))
 106   (:Button2MotionMask           #.(ash 1 9))
 107   (:Button3MotionMask           #.(ash 1 10))
 108   (:Button4MotionMask           #.(ash 1 11))
 109   (:Button5MotionMask           #.(ash 1 12))
 110   (:ButtonMotionMask            #.(ash 1 13))
 111   (:KeymapStateMask             #.(ash 1 14))
 112   (:ExposureMask                        #.(ash 1 15))
 113   (:VisibilityChangeMask        #.(ash 1 16))
 114   (:StructureNotifyMask         #.(ash 1 17))
 115   (:ResizeRedirectMask          #.(ash 1 18))
 116   (:SubstructureNotifyMask      #.(ash 1 19))
 117   (:SubstructureRedirectMask    #.(ash 1 20))
 118   (:FocusChangeMask             #.(ash 1 21))
 119   (:PropertyChangeMask          #.(ash 1 22))
 120   (:ColormapChangeMask          #.(ash 1 23))
 121   (:OwnerGrabButtonMask         #.(ash 1 24))
 122   (:MouseWheelMask            #.(ash 1 28))
 123   (:ActivateMask                    #.(ash 1 29))
 124   (:VirtualEventMask          #.(ash 1 30)))
 125
 126
 127 (defun tk-event-type (n) ;; do not try to generate masks from these!
 128   (ignore-errors
 129    (foreign-enum-keyword 'tk-event-type n)))
 130
 131 (defun tk-event-mask-symbol (n) ;; do not try to generate masks from these!
 132   (ignore-errors
 133    (foreign-enum-keyword 'tk-event-mask n)))
 134
 135 (defun foreign-masks-combine (enum-type &rest mask-specs)
 136   (reduce 'logior (loop for mask-spec in mask-specs
 137                         collecting (etypecase mask-spec
 138                                      (number mask-spec)
 139                                      (keyword (foreign-enum-value enum-type mask-spec))))
 140     :initial-value 0))
 141
 142
 143 ;; sample event handler
 144
 145 (defcallback dump-event :void  ((client-data :pointer)(xe :pointer))
 146   (call-dump-event client-data xe))
 147
 148 (defun call-dump-event (client-data xe)
 149   ;;(trc "tkep> serial" (xsv serial xe))
 150   #+shh (loop for win being the hash-keys of (tkwins *tkw*)
 151         do (print `(win ,win :xwin ,(tkwin-window win) ,(tkwin-widget win) ,(path (tkwin-widget win)))))
 152   ;;(trc "    > same-screen" (xsv same-screen xe))
 153
 154   (trc "tkep> " (tk-event-type (mem-aref xe :int)) :client-data client-data)
 155   (case (tk-event-type (mem-aref xe :int))
 156     (:motionnotify
 157      (trc nil "motionnotify" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe)))
 158     (:virtualevent
 159      (trc "    > :type" (format nil "<<~a>>" (xsv name xe)) :time (xsv time xe) :state (xsv state xe))
 160      (trc "    > :x" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe))
 161      (trc "    > event/root/sub" (mapcar (lambda (w) (when w (path w)))
 162                                 (list (xwin-widget (xsv event-window xe))
 163                                   (xwin-widget (xsv root-window xe))
 164                                   (xwin-widget (xsv sub-window xe)))))
 165
 166      (trc "    > data" (unless (null-pointer-p (xsv user-data xe))
 167                          (tcl-get-string (xsv user-data xe)))))))
 168
 169 (defun xevent-dump (xe)
 170   (case (tk-event-type (mem-aref xe :int))
 171     (:motionnotify
 172      (trc nil "motionnotify" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe)))
 173     (:virtualevent
 174      (trc "    > :type" (format nil "<<~a>>" (xsv name xe)) :time (xsv time xe) :state (xsv state xe))
 175      (trc "    > :x" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe))
 176      (trc "    > event/root/sub" (mapcar (lambda (w) (when w (path w)))
 177                                 (list (xwin-widget (xsv event-window xe))
 178                                   (xwin-widget (xsv root-window xe))
 179                                   (xwin-widget (xsv sub-window xe)))))
 180
 181      (trc "    > data" (unless (null-pointer-p (xsv user-data xe))
 182                          (tcl-get-string (xsv user-data xe)))))
 183     (otherwise
 184      (trc "tkep> " (tk-event-type (mem-aref xe :int))))))
 185
 186