run.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
  22
  23 ;;; --- running a Celtk (window class, actually) --------------------------------------
  24
  25 (eval-now!
  26  (export '(tk-scaling run-window test-window *ctk-dbg*)))
  27
  28 (defparameter *ctk-dbg* nil)
  29
  30 (defun run-window (root-class &optional (resetp t) &rest window-initargs)
  31   (declare (ignorable root-class))
  32   (setf *tkw* nil)
  33   (when resetp
  34     (cells-reset 'tk-user-queue-handler))
  35   (tk-interp-init-ensure)
  36
  37   (setf *tki* (Tcl_CreateInterp))
  38   ;; not recommended by Tcl doc (tcl-do-when-idle (get-callback 'tcl-idle-proc) 42)
  39   (tk-app-init *tki*)
  40   (tk-togl-init *tki*)
  41   (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}")
  42
  43   (tk-format-now "package require snack")
  44   (tk-format-now "package require tile")
  45   #-unix
  46   ;;(tk-format-now "package require QuickTimeTcl")
  47   (tk-format-now "snack::sound s")
  48 ;;;  (tk-format-now (conc$ "snack::sound s -load "
  49 ;;;                   (snackify-pathname (make-pathname :directory '(:absolute  "sounds")
  50 ;;;                                        :name "ahem_x" :type "wav")
  51 ;;;                     #+vs (car (directory (make-pathname :directory '(:absolute  "sounds")))))))
  52 ;;;  (tk-format-now "s play -blocking yes")
  53 ;;;  (sleep 2)
  54 ;;;  (tk-format-now "s play")
  55
  56   (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer))
  57
  58   ;; these next exist because of limitations in the Tcl API. eg, the keypress event does not
  59   ;; include enough info to extract the keysym directly, and the function to extract the
  60   ;; keysym is not exposed. The keysym, btw, is the portable representation of key events.
  61
  62   (tcl-create-command *tki* "do-key-down" (get-callback 'do-on-key-down) (null-pointer) (null-pointer))
  63   (tcl-create-command *tki* "do-key-up" (get-callback 'do-on-key-up) (null-pointer) (null-pointer))
  64
  65   (with-integrity () ;; w/i somehow ensures tkwin slot gets populated
  66     (setf *app*
  67       (make-instance 'application
  68         :kids (c? (the-kids
  69                    (setf *tkw* (apply 'make-instance root-class
  70                                  :fm-parent *parent*
  71                                  window-initargs))))
  72         )))
  73
  74   (assert (tkwin *tkw*))
  75
  76   (tk-format `(:fini) "wm deiconify .")
  77   (tk-format-now "bind . <Escape> {destroy .}")
  78   ;
  79   ; see above for why we are converting key x-events to application key virtual events:
  80   ;
  81   (tk-format-now "bind . <KeyPress> {do-key-down %W %K}")
  82   (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}")
  83   (bwhen (ifn (start-up-fn *tkw*))
  84     (funcall ifn *tkw*))
  85   (CG:kill-splash-screen)
  86   (tcl-do-one-event-loop)
  87   )
  88
  89
  90
  91 (defun ensure-destruction (w key)
  92   (declare (ignorable key))
  93   ;(TRC "ensure.destruction entry" key W (type-of w))
  94   (unless (find w *windows-being-destroyed*)
  95     ;(TRC "ensure.destruction not-to-being" key W)
  96
  97     (let ((*windows-being-destroyed* (cons w *windows-being-destroyed*)))
  98       (not-to-be w))))
  99
 100 (defparameter *keyboard-modifiers*
 101   (loop with km = (make-hash-table :test 'equalp)
 102       for (keysym mod) in '(("Shift_L" :shift)
 103                           ("Shift_R" :shift)
 104                           ("Alt_L" :alt)
 105                           ("Alt_R" :alt)
 106                           ("Control_L" :control)
 107                           ("Control_R" :control))
 108       do (setf (gethash keysym km) mod)
 109       finally (return km)))
 110
 111 (defun keysym-to-modifier (keysym)
 112   (gethash keysym *keyboard-modifiers*))
 113
 114 (defmethod widget-event-handle ((self window) xe)
 115   (let ((*tkw* self))
 116     (unless (find (xevent-type xe) '(:MotionNotify))
 117       #+xxx (TRC "main window event" self *tkw* (xevent-type xe)))
 118     (flet ((give-to-window ()
 119              (bwhen (eh (event-handler *tkw*))
 120                (funcall eh *tkw* xe))))
 121       (case (xevent-type xe)
 122         ((:focusin :focusout) (setf (^focus-state) (xevent-type xe)))
 123         ((:MotionNotify :buttonpress)
 124          #+shhh (call-dump-event client-data xe))
 125
 126         (:configurenotify
 127          (setf (^width) (parse-integer (tk-eval "winfo width .")))
 128          (with-cc :height
 129            (setf (^height) (parse-integer (tk-eval "winfo height ."))))
 130          )
 131
 132
 133
 134         (:destroyNotify
 135          (pushnew *tkw* *windows-destroyed*)
 136          (ensure-destruction *tkw* :destroyNotify))
 137
 138         (:virtualevent
 139          (bwhen (n$ (xsv name xe))
 140            (trc nil "main-window-proc :" n$ (unless (null-pointer-p (xsv user-data xe))
 141                                               (tcl-get-string (xsv user-data xe))))
 142            (case (read-from-string (string-upcase n$))
 143              (keypress ;(break "this works??: going after keysym")
 144                (let ((keysym (tcl-get-string (xsv user-data xe))))
 145                          (trc nil "keypress keysym!!!!" (tcl-get-string (xsv user-data xe)))
 146                          (bIf (mod (keysym-to-modifier keysym))
 147                            (eko (nil "modifiers now")
 148                              (pushnew mod (keyboard-modifiers *tkw*)))
 149                            (trc "unhandled pressed keysym" keysym))))
 150              (keyrelease (break "this works??: going after keysym")
 151                (let ((keysym (tcl-get-string (xsv user-data xe))))
 152                            (bIf (mod (keysym-to-modifier keysym))
 153                              (eko (nil "modifiers now")
 154                                (setf (keyboard-modifiers *tkw*)
 155                                  (delete mod (keyboard-modifiers *tkw*))))
 156                              (trc "unhandled released keysym" keysym))))
 157              (close-window
 158               (ensure-destruction *tkw* :close-window))
 159
 160              (window-destroyed
 161               (ensure-destruction *tkw* :window-destroyed))
 162
 163              (otherwise
 164               (give-to-window)))))
 165         (otherwise (give-to-window)))
 166       0)))
 167
 168 ;; Our own event loop ! - Use this if it is desirable to do something
 169 ;; else between events
 170
 171 (defparameter *event-loop-delay*  .10 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)")
 172
 173 (defparameter *doe-last* 0)
 174
 175 (defun tcl-do-one-event-loop ()
 176   (app-idle-tasks-clear)
 177   (loop while (plusp (tk-get-num-main-windows))
 178       do (loop until (zerop (Tcl_DoOneEvent 2)) ;; 2== TCL_DONT_WAIT
 179              do (when (and *ctk-dbg* (> (- (now) *doe-last*) 1))
 180                     (trcx doe-loop)
 181                   (setf *doe-last* (now)))
 182                (app-idle *app*))
 183         (app-idle *app*)
 184         (sleep *event-loop-delay*) ;; give the IDE a few cycles
 185       finally
 186         (trc nil "Tcl-do-one-event-loop sees no more windows" *tki*)
 187         (tcl-delete-interp *tki*) ;; probably unnecessary
 188         (setf *app* nil *tkw* nil *tki* nil)))
 189
 190 (defmethod window-idle ((self window)))
 191
 192 (defun test-window (root-class &optional (resetp t) &rest window-initargs)
 193   "nails existing window as a convenience in iterative development"
 194   (declare (ignorable root-class))
 195
 196   #+notquite (when (and *tkw* (fm-parent *tkw*)) ;; probably a better way to test if the window is still alive
 197     (not-to-be (fm-parent *tkw*))
 198     (setf *tkw* nil ctk::*app* nil))
 199
 200   (apply 'run-window root-class resetp window-initargs))
 201
 202 ;;; --- commands -----------------------------------------------------------------
 203
 204 (defmacro defcommand (name)
 205   (let ((do-on-name (read-from-string (format nil "DO-ON-~a" name)))
 206         (^on-name (read-from-string (format nil "^ON-~a" name))))
 207     `(progn
 208        (defmethod ,do-on-name (self &rest args)
 209          (bwhen (cmd (,^on-name))
 210            (apply cmd self args))
 211          0)
 212
 213        (defcallback ,do-on-name :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer))
 214          (declare (ignore client-data))
 215          (let ((*tki* interp)
 216                (args (loop for argn upfrom 1 below argc
 217                          collecting (mem-aref argv :string argn))))
 218            (bif (self (gethash (car args) (dictionary *tkw*)))
 219              (progn
 220                (trc nil "defcommand > " ',^on-name self (cdr args))
 221                (apply ',do-on-name self (rest args)))
 222              (progn
 223                (break ",do-on-name> Target widget ~a does not exist" (car args))
 224                #+anyvalue? (tcl-set-result interp
 225                              (format nil ",do-on-name> Target widget ~a does not exist" (car args))
 226                              (null-pointer))
 227                1)))))))
 228
 229 (defcommand command)
 230 ;
 231 ; see notes elsewhere for why Tcl API deficiencies require augmented key handling via app virtual events
 232 ;
 233 (defcommand key-down)
 234 (defcommand key-up)
 235