Celtk.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 ;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.42 2008/01/03 20:23:30 ktilton Exp $
  20
  21 ;(pushnew :tile *features*) ;; frgo, 2007-09-21: Need to do this only when tile actually loaded
  22
  23 (defpackage :celtk
  24   (:nicknames "CTK")
  25   (:use :common-lisp :utils-kt :cells :cffi)
  26   (:export
  27    #:right #:left
  28    #:<1> #:tk-event-type #:xsv #:name #:x #:y #:x-root #:y-root
  29    #:title$ #:pop-up #:path #:parent-path #:^keyboard-modifiers
  30    #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget
  31    #:mk-panedwindow
  32    #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label
  33    #:^selection #:selection #:tk-selector
  34    #:mk-checkbutton #:button #:mk-button #:mk-button-ex  #:entry #:mk-entry #:text
  35    #:frame-stack #:mk-frame-stack #:path #:^path
  36    #:mk-menu-entry-radiobutton #:mk-menu-entry-checkbutton
  37    #:mk-menu-radio-group #:mk-menu-entry-separator
  38    #:mk-menu-entry-command #:mk-menu-entry-command-ex
  39    #:menu #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar
  40    #:^entry-values #:tk-eval #:tk-eval-list #:scale #:mk-scale #:mk-popup-menubutton
  41    #:item #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc
  42    #:text-item #:mk-text-item #:item-geometer
  43    #:rectangle #:mk-rectangle #:bitmap #:mk-bitmap #:canvas #:mk-canvas #:mk-frame-row
  44    #:mk-scrolled-list #:listbox-item #:mk-spinbox
  45    #:mk-scroller #:mk-menu-entry-cascade-ex
  46    #:with-ltk #:tk-format #:send-wish #:value #:.tkw
  47    #:tk-user-queue-handler #:user-errors #:^user-errors
  48    #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps
  49    #:^widget-menu #:widget-menu #:tk-format-now
  50    #:coords #:^coords #:tk-translate-keysym
  51    #:*tkw*))
  52
  53 (defpackage :celtk-user
  54   (:use :common-lisp :utils-kt :cells :celtk))
  55
  56 (in-package :Celtk)
  57
  58
  59 #+(and allegrocl ide (not runtime-system))
  60 (ide::defdefiner defcallback defun)
  61
  62 (defvar *tki* nil)
  63 (defparameter *windows-being-destroyed* nil)
  64 (defparameter *windows-destroyed* nil)
  65
  66 (defparameter *tk-last* nil "Debug aid. Last recorded command send to Tk")
  67
  68 (defparameter *tkw* nil)
  69
  70 (define-symbol-macro .tkw (nearest self window))
  71
  72 ; --- tk-format --- talking to wish/Tk -----------------------------------------------------
  73
  74 (defparameter +tk-client-task-priority+
  75     '(:delete :forget :destroy
  76        :pre-make-tk :make-tk :make-tk-menubutton :post-make-tk
  77        :variable :bind :selection :trace :configure :grid :pack :fini))
  78
  79 (defun tk-user-queue-sort (task1 task2)
  80   "Intended for use as user queue sorter, to make Tk happy by giving it stuff in the order it needs to work properly."
  81   (destructuring-bind (type1 self1 &rest dbg) task1
  82       (declare (ignorable dbg))
  83       (destructuring-bind (type2 self2 &rest dbg) task2
  84         (declare (ignorable dbg))
  85         (let ((p1 (position type1 +tk-client-task-priority+))
  86               (p2 (position type2 +tk-client-task-priority+)))
  87           (cond
  88            ((< p1 p2) t)
  89            ((< p2 p1) nil)
  90            (t (case type1 ;; they are the same if we are here
  91                 (:make-tk
  92                  (fm-ordered-p self1 self2))
  93                 (:pack
  94                  (fm-ascendant-p self2 self1)))))))))
  95
  96
  97 (defun tk-user-queue-handler (user-q)
  98   (loop for (defer-info . nil) in (fifo-data user-q)
  99         unless (find (car defer-info) +tk-client-task-priority+)
 100         do (error "unknown tk client task type ~a in task: ~a " (car defer-info) defer-info))
 101
 102   (loop for (defer-info . task) in (prog1
 103                                        (stable-sort (fifo-data user-q) 'tk-user-queue-sort :key 'car)
 104                                      (fifo-clear user-q))
 105         do
 106         (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info)
 107         (funcall task :user-q defer-info)))
 108
 109 #+save
 110 (defun tk-format-now (fmt$ &rest fmt-args)
 111   (unless (find *tkw* *windows-destroyed*)
 112     (let* ((*print-circle* nil)
 113            (tk$ (apply 'format nil fmt$ fmt-args)))
 114       ;
 115       ; --- debug stuff ---------------------------------
 116       ;
 117
 118       (let ((yes '(#+shhh "play-me"))
 119             (no  '("font")))
 120         (declare (ignorable yes no))
 121         (when (and (or ;; (null yes)
 122                     (find-if (lambda (s) (search s tk$)) yes))
 123                 #+hunh? (not (find-if (lambda (s) (search s tk$)) no)))
 124           (format t "~&tk> ~a~%" tk$)))
 125       (assert *tki*)
 126
 127       ; --- end debug stuff ------------------------------
 128       ;
 129       ; --- serious stuff ---
 130       ;
 131       (setf *tk-last* tk$)
 132       (tcl-eval-ex *tki* tk$))))
 133
 134 (defun tk-format-now (fmt$ &rest fmt-args)
 135   (unless (find *tkw* *windows-destroyed*)
 136     (let* ((*print-circle* nil)
 137            (tk$ (apply 'format nil fmt$ fmt-args)))
 138       (let ((yes ) ; '("menubar" "cd"))
 139             (no  '()))
 140         (declare (ignorable yes no))
 141         (when (find-if (lambda (s) (search s tk$)) yes)
 142           (format t "~&tk> ~a~%" tk$)))
 143       (assert *tki*)
 144       (setf *tk-last* tk$)
 145       (tcl-eval-ex *tki* tk$))))
 146
 147 (defun tk-format (defer-info fmt$ &rest fmt-args)
 148   "Format then send to wish (via user queue)"
 149   (assert (or (eq defer-info :grouped)
 150             (consp defer-info)) () "need defer-info to sort command ~a. Specify :grouped if caller is managing user-queue"
 151     (apply 'format nil fmt$ fmt-args))
 152
 153   (when (eq defer-info :grouped)
 154     (setf defer-info nil))
 155   (flet ((do-it ()
 156            (apply 'tk-format-now fmt$ fmt-args)))
 157     (if defer-info
 158         (with-integrity (:client defer-info)
 159           (do-it))
 160     (do-it))))
 161
 162 (defmethod tk-send-value ((s string))
 163   #+whoa (if nil #+not (find #\\ s) ;; welllll, we cannot send: -text "[" to Tk because t misinterprets it, so we have to send the octal
 164                                                        ; which begins with \. There is probably a better way ///
 165       (format nil "\"~a\"" s) ;; no good if \ is in file path as opposed to escaping
 166       (format nil "~s" s)                                  ; this fails where I want to send a /Tk/ escape sequence "\065"
 167                                                        ; because the ~s directive adds its own escaping
 168   ;;(format nil "{~a}" s)                                ;this fails, too, not sure why
 169   )
 170   (if (find #\space s)
 171       (format nil "{~a}" s)
 172     (format nil "~s" s)))
 173
 174 (defmethod tk-send-value ((c character))
 175   ;
 176   ; all this just to display "[". Unsolved is how we will
 177   ; send a text label with a string /containing/ the character #\[
 178   ;
 179   (trc nil "tk-send-value" c (char-code c) (format nil "\"\\~3,'0o\"" (char-code c)))
 180   (format nil "\"\\~3,'0o\"" (char-code c)))
 181
 182 (defmethod tk-send-value (other)
 183   (format nil "~a" other))
 184
 185 (defmethod tk-send-value ((s symbol))
 186   (down$ s))
 187
 188 (defmethod tk-send-value ((p package))
 189   (package-name p))
 190
 191 (defmethod tk-send-value ((values list))
 192   (format nil "{~{~a~^ ~}}" (mapcar 'tk-send-value values)))
 193
 194 (defmethod parent-path ((nada null)) "")
 195 (defmethod parent-path ((other t)) "")
 196
 197
 198 ; --- tk eval  ----------------------------------------------------
 199
 200 (defmethod path-index (self) (path self))
 201
 202 (defun tk-eval (tk-form$ &rest fmt-args
 203                  &aux (tk$ (apply 'format nil tk-form$ fmt-args)))
 204   (assert *tki* () "Global *tki* is not bound to anything, let alone a Tcl interpreter")
 205   (tk-format :grouped tk$)
 206   (tcl-get-string-result *tki*)
 207   )
 208
 209 (defun tk-eval-var (var)
 210   (tk-eval "set ~a" var))
 211
 212 (defun tk-eval-list (tk-form$ &rest fmt-args)
 213   (tk-format :grouped (apply 'format nil tk-form$ fmt-args))
 214   (parse-tcl-list-result (tcl-get-string-result *tki*)))
 215
 216 #+test
 217 (parse-tcl-list-result "-ascent 58 -descent 15 -linespace 73 -fixed 0")
 218
 219 (defun parse-tcl-list-result (result &aux item items)
 220   (when (plusp (length result))
 221     (trc nil "parse-tcl-list-result" result)
 222     (labels ((is-spaces (s)
 223                (every (lambda (c) (eql c #\space)) s))
 224              (gather-item ()
 225                (unless (is-spaces item)
 226                  ;(trc "item chars" (reverse item))
 227                  ;(trc "item string" (coerce (reverse item) 'string))
 228                  (push (coerce (nreverse item) 'string) items)
 229                  (setf item nil))))
 230       (loop with inside-braces
 231           for ch across result
 232           if (eql ch #\{)
 233           do (if inside-braces
 234                  (break "whoa, nested braces: ~a" result)
 235                (setf inside-braces t))
 236           else if (eql ch #\})
 237           do (setf inside-braces nil)
 238             (gather-item)
 239             (setf item nil)
 240           else if (eql ch #\space)
 241           if inside-braces do (push ch item)
 242           else do (gather-item)
 243             (setf item nil)
 244           else do (push ch item)
 245           finally (gather-item)
 246             (return (nreverse items))))))
 247
 248
 249
 250
 251
 252
 253