/[cells]/Celtk/Celtk.lisp
ViewVC logotype

Contents of /Celtk/Celtk.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5