Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Moved to github, ported to Linux (almost)

  • Loading branch information...
commit 8630194751acd7aebcb55df9b216e275d3415589 0 parents
@kennytilton authored
Showing with 11,718 additions and 0 deletions.
  1. +253 −0 .#Celtk.lisp.1.40
  2. +277 −0 .#composites.lisp.1.23
  3. +215 −0 .#tk-interp.lisp.1.18
  4. +119 −0 .#tk-object.lisp.1.14
  5. +214 −0 .#togl.lisp.1.25
  6. +226 −0 .#togl.lisp.1.28
  7. +10 −0 CelloTk-test.lisp
  8. +109 −0 CelloTk.lpr
  9. +43 −0 Celtk.asd
  10. +95 −0 Celtk3D.lpr
  11. +39 −0 andy-expander.lisp
  12. +12 −0 asdf-projects.lisp
  13. +96 −0 button.lisp
  14. +96 −0 canvas.lisp
  15. +297 −0 cellogears.lisp
  16. +277 −0 celtk.lisp
  17. +109 −0 celtk.lpr
  18. +92 −0 cffi.lpr
  19. +294 −0 composites.lisp
  20. BIN  demo.mov
  21. +221 −0 demos.lisp
  22. +122 −0 entry.lisp
  23. +578 −0 fileevent.lisp
  24. +98 −0 font.lisp
  25. +104 −0 frame.lisp
  26. +17 −0 gears.asd
  27. +88 −0 gears/charlie-1-2.lisp
  28. +291 −0 gears/gears.lisp
  29. +92 −0 gears/gears.lpr
  30. +80 −0 gears/nehe-02.cl
  31. +291 −0 gears/nehe-1.cl
  32. +46 −0 item-pictorial.lisp
  33. +97 −0 item-shaped.lisp
  34. +1,047 −0 keysym.lisp
  35. BIN  kt69.gif
  36. +58 −0 label.lisp
  37. +61 −0 layout.lisp
  38. +87 −0 load.lisp
  39. +87 −0 load.lisp~
  40. +280 −0 lotsa-widgets.lisp
  41. +457 −0 ltktest-ci.lisp
  42. +295 −0 menu.lisp
  43. +64 −0 movie.lisp
  44. +137 −0 multichoice.lisp
  45. +61 −0 notebook.lisp
  46. +255 −0 run.lisp
  47. +122 −0 scroll.lisp
  48. +43 −0 text-item.lisp
  49. +117 −0 timer.lisp
  50. +186 −0 tk-events.lisp
  51. +236 −0 tk-interp.lisp
  52. +121 −0 tk-object.lisp
  53. +213 −0 tk-structs.lisp
  54. +228 −0 togl.lisp
  55. +307 −0 widget.lisp
  56. +2,258 −0 x1.xbm
253 .#Celtk.lisp.1.40
@@ -0,0 +1,253 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Celtk -- Cells, Tcl, and Tk
+
+Copyright (C) 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.40 2007/01/29 22:58:41 ktilton Exp $
+
+(pushnew :tile *features*)
+
+(defpackage :celtk
+ (:nicknames "CTK")
+ (:use :common-lisp :utils-kt :cells :cffi)
+ (:export
+ #:right #:left
+ #:<1> #:tk-event-type #:xsv #:name #:x #:y #:x-root #:y-root
+ #:title$ #:pop-up #:path #:parent-path #:^keyboard-modifiers
+ #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget
+ #:mk-panedwindow
+ #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label
+ #:^selection #:selection #:tk-selector
+ #:mk-checkbutton #:button #:mk-button #:mk-button-ex #:entry #:mk-entry #:text
+ #:frame-stack #:mk-frame-stack #:path #:^path
+ #:mk-menu-entry-radiobutton #:mk-menu-entry-checkbutton
+ #:mk-menu-radio-group #:mk-menu-entry-separator
+ #:mk-menu-entry-command #:mk-menu-entry-command-ex
+ #:menu #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar
+ #:^entry-values #:tk-eval #:tk-eval-list #:scale #:mk-scale #:mk-popup-menubutton
+ #:item #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc
+ #:text-item #:mk-text-item #:item-geometer
+ #:rectangle #:mk-rectangle #:bitmap #:mk-bitmap #:canvas #:mk-canvas #:mk-frame-row
+ #:mk-scrolled-list #:listbox-item #:mk-spinbox
+ #:mk-scroller #:mk-menu-entry-cascade-ex
+ #:with-ltk #:tk-format #:send-wish #:value #:.tkw
+ #:tk-user-queue-handler #:user-errors #:^user-errors
+ #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps
+ #:^widget-menu #:widget-menu #:tk-format-now
+ #:coords #:^coords #:tk-translate-keysym
+ #:*tkw*))
+
+(defpackage :celtk-user
+ (:use :common-lisp :utils-kt :cells :celtk))
+
+(in-package :Celtk)
+
+
+#+(and allegrocl ide (not runtime-system))
+(ide::defdefiner defcallback defun)
+
+(defvar *tki* nil)
+(defparameter *windows-being-destroyed* nil)
+(defparameter *windows-destroyed* nil)
+
+(defparameter *tk-last* nil "Debug aid. Last recorded command send to Tk")
+
+(defparameter *tkw* nil)
+
+(define-symbol-macro .tkw (nearest self window))
+
+; --- tk-format --- talking to wish/Tk -----------------------------------------------------
+
+(defparameter +tk-client-task-priority+
+ '(:delete :forget :destroy
+ :pre-make-tk :make-tk :make-tk-menubutton :post-make-tk
+ :variable :bind :selection :trace :configure :grid :pack :fini))
+
+(defun tk-user-queue-sort (task1 task2)
+ "Intended for use as user queue sorter, to make Tk happy by giving it stuff in the order it needs to work properly."
+ (destructuring-bind (type1 self1 &rest dbg) task1
+ (declare (ignorable dbg))
+ (destructuring-bind (type2 self2 &rest dbg) task2
+ (declare (ignorable dbg))
+ (let ((p1 (position type1 +tk-client-task-priority+))
+ (p2 (position type2 +tk-client-task-priority+)))
+ (cond
+ ((< p1 p2) t)
+ ((< p2 p1) nil)
+ (t (case type1 ;; they are the same if we are here
+ (:make-tk
+ (fm-ordered-p self1 self2))
+ (:pack
+ (fm-ascendant-p self2 self1)))))))))
+
+
+(defun tk-user-queue-handler (user-q)
+ (loop for (defer-info . nil) in (fifo-data user-q)
+ unless (find (car defer-info) +tk-client-task-priority+)
+ do (error "unknown tk client task type ~a in task: ~a " (car defer-info) defer-info))
+
+ (loop for (defer-info . task) in (prog1
+ (stable-sort (fifo-data user-q) 'tk-user-queue-sort :key 'car)
+ (fifo-clear user-q))
+ do
+ (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info)
+ (funcall task :user-q defer-info)))
+
+#+save
+(defun tk-format-now (fmt$ &rest fmt-args)
+ (unless (find *tkw* *windows-destroyed*)
+ (let* ((*print-circle* nil)
+ (tk$ (apply 'format nil fmt$ fmt-args)))
+ ;
+ ; --- debug stuff ---------------------------------
+ ;
+
+ (let ((yes '(#+shhh "play-me"))
+ (no '("font")))
+ (declare (ignorable yes no))
+ (when (and (or ;; (null yes)
+ (find-if (lambda (s) (search s tk$)) yes))
+ #+hunh? (not (find-if (lambda (s) (search s tk$)) no)))
+ (format t "~&tk> ~a~%" tk$)))
+ (assert *tki*)
+
+ ; --- end debug stuff ------------------------------
+ ;
+ ; --- serious stuff ---
+ ;
+ (setf *tk-last* tk$)
+ (tcl-eval-ex *tki* tk$))))
+
+(defun tk-format-now (fmt$ &rest fmt-args)
+ (unless (find *tkw* *windows-destroyed*)
+ (let* ((*print-circle* nil)
+ (tk$ (apply 'format nil fmt$ fmt-args)))
+ (let ((yes ) ; '("menubar" "cd"))
+ (no '()))
+ (declare (ignorable yes no))
+ (when (find-if (lambda (s) (search s tk$)) yes)
+ (format t "~&tk> ~a~%" tk$)))
+ (assert *tki*)
+ (setf *tk-last* tk$)
+ (tcl-eval-ex *tki* tk$))))
+
+(defun tk-format (defer-info fmt$ &rest fmt-args)
+ "Format then send to wish (via user queue)"
+ (assert (or (eq defer-info :grouped)
+ (consp defer-info)) () "need defer-info to sort command ~a. Specify :grouped if caller is managing user-queue"
+ (apply 'format nil fmt$ fmt-args))
+
+ (when (eq defer-info :grouped)
+ (setf defer-info nil))
+ (flet ((do-it ()
+ (apply 'tk-format-now fmt$ fmt-args)))
+ (if defer-info
+ (with-integrity (:client defer-info)
+ (do-it))
+ (do-it))))
+
+(defmethod tk-send-value ((s string))
+ #+whoa (if nil #+not (find #\\ s) ;; welllll, we cannot send: -text "[" to Tk because t misinterprets it, so we have to send the octal
+ ; which begins with \. There is probably a better way ///
+ (format nil "\"~a\"" s) ;; no good if \ is in file path as opposed to escaping
+ (format nil "~s" s) ; this fails where I want to send a /Tk/ escape sequence "\065"
+ ; because the ~s directive adds its own escaping
+ ;;(format nil "{~a}" s) ;this fails, too, not sure why
+ )
+ (if (find #\space s)
+ (format nil "{~a}" s)
+ (format nil "~s" s)))
+
+(defmethod tk-send-value ((c character))
+ ;
+ ; all this just to display "[". Unsolved is how we will
+ ; send a text label with a string /containing/ the character #\[
+ ;
+ (trc nil "tk-send-value" c (char-code c) (format nil "\"\\~3,'0o\"" (char-code c)))
+ (format nil "\"\\~3,'0o\"" (char-code c)))
+
+(defmethod tk-send-value (other)
+ (format nil "~a" other))
+
+(defmethod tk-send-value ((s symbol))
+ (down$ s))
+
+(defmethod tk-send-value ((p package))
+ (package-name p))
+
+(defmethod tk-send-value ((values list))
+ (format nil "{~{~a~^ ~}}" (mapcar 'tk-send-value values)))
+
+(defmethod parent-path ((nada null)) "")
+(defmethod parent-path ((other t)) "")
+
+
+; --- tk eval ----------------------------------------------------
+
+(defmethod path-index (self) (path self))
+
+(defun tk-eval (tk-form$ &rest fmt-args
+ &aux (tk$ (apply 'format nil tk-form$ fmt-args)))
+ (assert *tki* () "Global *tki* is not bound to anything, let alone a Tcl interpreter")
+ (tk-format :grouped tk$)
+ (tcl-get-string-result *tki*)
+ )
+
+(defun tk-eval-var (var)
+ (tk-eval "set ~a" var))
+
+(defun tk-eval-list (tk-form$ &rest fmt-args)
+ (tk-format :grouped (apply 'format nil tk-form$ fmt-args))
+ (parse-tcl-list-result (tcl-get-string-result *tki*)))
+
+#+test
+(parse-tcl-list-result "-ascent 58 -descent 15 -linespace 73 -fixed 0")
+
+(defun parse-tcl-list-result (result &aux item items)
+ (when (plusp (length result))
+ (trc nil "parse-tcl-list-result" result)
+ (labels ((is-spaces (s)
+ (every (lambda (c) (eql c #\space)) s))
+ (gather-item ()
+ (unless (is-spaces item)
+ ;(trc "item chars" (reverse item))
+ ;(trc "item string" (coerce (reverse item) 'string))
+ (push (coerce (nreverse item) 'string) items)
+ (setf item nil))))
+ (loop with inside-braces
+ for ch across result
+ if (eql ch #\{)
+ do (if inside-braces
+ (break "whoa, nested braces: ~a" result)
+ (setf inside-braces t))
+ else if (eql ch #\})
+ do (setf inside-braces nil)
+ (gather-item)
+ (setf item nil)
+ else if (eql ch #\space)
+ if inside-braces do (push ch item)
+ else do (gather-item)
+ (setf item nil)
+ else do (push ch item)
+ finally (gather-item)
+ (return (nreverse items))))))
+
+
+
+
+
+
+
277 .#composites.lisp.1.23
@@ -0,0 +1,277 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Celtk -- Cells, Tcl, and Tk
+
+Copyright (C) 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :Celtk)
+
+(eval-now!
+ (export '(title$ active .time decoration)))
+
+(export! application
+ keyboard-modifiers
+ iconify
+ deiconify
+ full-screen-no-deco-window
+ screen-width
+ screen-height)
+
+;;; --- decoration -------------------------------------------
+
+(defmd decoration-mixin ()
+ (decoration (c-in nil)))
+
+;;; --- toplevel ---------------------------------------------
+
+(deftk toplevel (widget decoration-mixin)
+ ()
+ (:tk-spec toplevel
+ -borderwidth -cursor -highlightbackground -highlightcolor
+ -highlightthickness -padx -pady -relief
+ -takefocus -background -tk-class -colormap
+ -container -height -menu -screen
+ -use -visual -width)
+ (:default-initargs
+ :id (gentemp "TOP")))
+
+;; --- panedwindow -----------------------------------------
+
+(deftk panedwindow (widget decoration-mixin)
+ ()
+ (:tk-spec panedwindow
+ -background -borderwidth -cursor -height
+ -orient -relief -width
+ -handlepad
+ -handlesize
+ -opaqueresize
+ -sashcursor
+ -sashpad
+ -sashrelief
+ -sashwidth
+ -showhandle)
+ (:default-initargs
+ :id (gentemp "PW")
+ :packing nil))
+
+(defmethod make-tk-instance ((self panedwindow))
+ (tk-format `(:make-tk ,self) "panedwindow ~a -orient ~(~a~)"
+ (^path) (or (orient self) "vertical"))
+ (tk-format `(:pack ,self) "pack ~a -expand yes -fill both" (^path)))
+
+(defmethod parent-path ((self panedwindow)) (^path))
+
+(defobserver .kids ((self panedwindow))
+ (loop for k in (^kids)
+ do (trc "panedwindow adds" k (type-of k) (md-name k) (path k))
+ (tk-format `(:post-make-tk ,self) "~a add ~a" (^path) (path k))))
+
+; --------------------------------------------------------
+
+(defmodel composite-widget (widget)
+ ((kids-packing :initarg :kids-packing :accessor kids-packing :initform nil)))
+
+(defvar *app*)
+
+(defmodel application (family)
+ ((app-time :initform (c-in (now))
+ :initarg :app-time
+ :accessor app-time)))
+
+(define-symbol-macro .time (app-time *app*))
+
+(defmethod path ((self application)) nil)
+
+(defvar *app-idle-tasks*)
+(defun app-idle-tasks-clear ()
+ (setf *app-idle-tasks* nil))
+(defun app-idle-task-new (task-fn)
+ (push task-fn *app-idle-tasks*)
+ *app-idle-tasks*)
+
+(defun app-idle-task-destroy (task-fn)
+ (setf *app-idle-tasks*
+ (delete task-fn *app-idle-tasks*)))
+
+#+crazier
+(defun app-idle-task-destroy (task-cell)
+ (setf *app-idle-tasks*
+ (if (eq task-cell *app-idle-tasks*)
+ (cdr *app-idle-tasks*)
+ (mapl (lambda (tasks)
+ (when (eq task-cell (cdr tasks))
+ (rplacd tasks (cdr task-cell))))))))
+
+
+(defun app-idle (self)
+ (loop for w in (^kids)
+ do (when (not (eq :arrow (cursor w)))
+ (setf (cursor w) :arrow)))
+ (setf (^app-time) (now))
+ (loop for task in *app-idle-tasks*
+ do (funcall task self task)))
+
+(defmd window (toplevel composite-widget decoration-mixin)
+ (title$ (c? (string-capitalize (class-name (class-of self)))))
+ (dictionary (make-hash-table :test 'equalp))
+ (tkwins (make-hash-table))
+ (xwins (make-hash-table))
+ (cursor :arrow :cell nil)
+ (keyboard-modifiers (c-in nil))
+ (callbacks (make-hash-table :test #'eq))
+ (edit-style (c-in nil))
+ (tk-scaling (c? 1.3 #+tki (read-from-string (tk-eval "tk scaling"))))
+ tkfonts-to-load
+ tkfont-sizes-to-load
+ (tkfont-info (tkfont-info-loader))
+ start-up-fn
+ close-fn
+ initial-focus
+ (focus-state (c-in nil) :documentation "This is about the window having the focus on the desktop, not the key focus.
+Actually holds last event code, :focusin or :focusout")
+ on-key-down
+ on-key-up
+ :width (c?n 800)
+ :height (c?n 600))
+
+(defmethod (setf cursor) :after (new-value (self window))
+ (when new-value
+ (tk-format-now ". configure -cursor ~a" (string-downcase (symbol-name new-value)))))
+
+(export! .control-key-p .alt-key-p .shift-key-p focus-state ^focus-state)
+(define-symbol-macro .control-key-p (find :control (keyboard-modifiers .tkw)))
+(define-symbol-macro .alt-key-p (find :alt (keyboard-modifiers .tkw)))
+(define-symbol-macro .shift-key-p (find :shift (keyboard-modifiers .tkw)))
+
+(defmethod make-tk-instance ((self window))
+ (setf (gethash (^path) (dictionary .tkw)) self))
+
+(defun screen-width ()
+ (let ((*tkw* *tkw*))
+ (tk-format-now "winfo screenwidth .")))
+
+(defun screen-height ()
+ (let ((*tkw* *tkw*))
+ (tk-format-now "winfo screenheight .")))
+
+(defmodel full-screen-no-deco-window (window)
+ ())
+
+(defmethod initialize-instance :before ((self full-screen-no-deco-window)
+ &key &allow-other-keys)
+ (tk-format '(:pre-make-tk self)
+ "wm geometry . [winfo screenwidth .]x[winfo screenheight .]+0+0")
+ (tk-format '(:pre-make-tk self) "update idletasks")
+ #-macosx (tk-format '(:pre-make-tk self) "wm attributes . -topmost yes")
+ (tk-format '(:pre-make-tk self) "wm overrideredirect . yes")
+ )
+
+
+
+(defmethod do-on-key-down :before (self &rest args &aux (keysym (car args)))
+ (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw))
+ (bwhen (mod (keysym-to-modifier keysym))
+ (eko (nil "modifiers after adding" mod)
+ (pushnew mod (keyboard-modifiers .tkw)))))
+
+(defmethod do-on-key-up :before (self &rest args &aux (keysym (car args)))
+ (trc nil "ctk::do-on-key-up before" keysym (keyboard-modifiers .tkw))
+ (bwhen (mod (keysym-to-modifier keysym))
+ (eko (nil "modifiers after removing" mod)
+ (setf (keyboard-modifiers .tkw)
+ (delete mod (keyboard-modifiers .tkw))))))
+
+;;; Helper function that actually executes decoration change
+(defun %%do-decoration (widget decoration)
+ (break "hunh?")
+ (let ((path (path widget)))
+ (ecase decoration
+ (:none (progn
+ (tk-format '(:pre-make-tk decoration)
+ "wm withdraw ~a" path)
+ (tk-format '(:pre-make-tk decoration)
+ "wm overrideredirect ~a 1" path)
+ (tk-format '(:pre-make-tk decoration)
+ "wm deiconify ~a" path)
+ (tk-format '(:pre-make-tk decoration)
+ "update idletasks" path)
+ ))
+ (:normal (progn
+ (tk-format '(:pre-make-tk decoration)
+ "wm withdraw ~a" path)
+ (tk-format '(:pre-make-tk decoration)
+ "wm overrideredirect ~a 0" path)
+ (tk-format '(:pre-make-tk decoration)
+ "wm deiconify ~a" path)
+ (tk-format '(:pre-make-tk decoration)
+ "update idletasks" path))))))
+
+;;; Decoration observer for all widgets that inherit from decoration-mixin
+;;; On Mac OS X this is a one-way operation. When created without decorations
+;;; then it is not possible to restore the decorations and vice versa. So on
+;;; OS X the window decoration will stay as you created the window with.
+
+(defobserver decoration ((self decoration-mixin)) ;; == wm overrideredirect 0|1
+ (assert (or (eq new-value nil) ;; Does not change decoration
+ (eq new-value :normal) ;; "normal"
+ (eq new-value :none))) ;; No title bar, no nothing ...
+ (if (not (eq new-value old-value))
+ (%%do-decoration self new-value)))
+
+(defobserver initial-focus ()
+ (when new-value
+ (tk-format '(:fini new-value) "focus ~a" (path new-value))))
+
+(defun tkfont-info-loader ()
+ (c? (eko (nil "tkfinfo")
+ (loop with scaling = (^tk-scaling)
+ for (tkfont fname) in (^tkfonts-to-load)
+ collect (cons tkfont
+ (apply 'vector
+ (loop for fsize in (^tkfont-sizes-to-load)
+ for id = (format nil "~(~a-~2,'0d~)" tkfont fsize)
+ for tkf = (tk-eval "font create ~a -family {~a} -size ~a"
+ id fname fsize)
+ for (nil ascent nil descent nil linespace nil fixed) = (tk-eval-list "font metrics ~a" tkf)
+ collect
+ (progn (trc nil "tkfontloaded" id fname fsize tkfont tkf)
+ (make-tkfinfo :ascent (round (parse-integer ascent :junk-allowed t) scaling)
+ :id id
+ :family fname
+ :size fsize
+ :descent (round (parse-integer descent :junk-allowed t) scaling)
+ :linespace (round (parse-integer linespace :junk-allowed t) scaling)
+ :fixed (plusp (parse-integer fixed :junk-allowed t))
+ :em (round (parse-integer
+ (tk-eval "font measure ~(~a~) \"m\"" tkfont) :junk-allowed t)
+ scaling))))))))))
+
+(defobserver title$ ((self window))
+ (tk-format '(:configure "title") "wm title . ~s" (or new-value "Untitled")))
+
+(defmethod path ((self window)) ".")
+(defmethod parent-path ((self window)) "")
+
+(defmethod iconify ((self window))
+ (%%do-decoration self :normal)
+ (tk-format `(:fini) "wm iconify ~a" (^path)))
+
+(defmethod deiconify ((self window))
+ (%%do-decoration self (decoration self))
+ (tk-format `(:fini) "wm deiconify ~a" (^path)))
+
+
+
+
215 .#tk-interp.lisp.1.18
@@ -0,0 +1,215 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Celtk -- Cells, Tcl, and Tk
+
+Copyright (C) 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+
+(in-package :celtk)
+
+;; Tcl/Tk
+
+(define-foreign-library Tcl
+ (:darwin (:framework "Tcl"))
+ (:windows (:or "Tcl85.dll"))
+ (:unix "libtcl.so")
+ (t (:default "libtcl")))
+
+(define-foreign-library Tk
+ (:darwin (:framework "Tk"))
+ (:windows (:or "Tk85.dll"))
+ (:unix "libtk.so")
+ (t (:default "libtk")))
+
+(define-foreign-library Tile
+ ;(:darwin (:framework "Tk"))
+ (:windows (:or (exe-dll "tile078")))
+ ;(:unix "libtk.so")
+ (t (:default "libtk")))
+
+(defctype tcl-retcode :int)
+
+(defcenum tcl-retcode-values
+ (:tcl-ok 0)
+ (:tcl-error 1))
+
+(defmethod translate-from-foreign (value (type (eql 'tcl-retcode)))
+ (unless (eq value (foreign-enum-value 'tcl-retcode-values :tcl-ok))
+ (error "Tcl error: ~a" (tcl-get-string-result *tki*)))
+ value)
+
+;; --- initialization ----------------------------------------
+
+(defcfun ("Tcl_FindExecutable" tcl-find-executable) :void
+ (argv0 :string))
+
+(defcfun ("Tcl_Init" Tcl_Init) tcl-retcode
+ (interp :pointer))
+
+(defcfun ("Tk_Init" Tk_Init) tcl-retcode
+ (interp :pointer))
+
+(defcallback Tk_AppInit tcl-retcode
+ ((interp :pointer))
+ (tk-app-init interp))
+
+(defun tk-app-init (interp)
+ (Tcl_Init interp)
+ (Tk_Init interp)
+ ;;(format t "~%*** Tk_AppInit has been called.~%")
+ ;; Return OK
+ (foreign-enum-value 'tcl-retcode-values :tcl-ok))
+
+ ;; Tk_Main
+
+(defcfun ("Tk_MainEx" %Tk_MainEx) :void
+ (argc :int)
+ (argv :string)
+ (Tk_AppInitProc :pointer)
+ (interp :pointer))
+
+(defun Tk_Main ()
+ (with-foreign-string (argv (argv0))
+ (%Tk_MainEx 1 argv
+ (get-callback 'Tk_AppInit)
+ (Tcl_CreateInterp))))
+
+;; Tcl_CreateInterp
+
+(defcfun ("Tcl_CreateInterp" Tcl_CreateInterp) :pointer)
+
+(defcfun ("Tcl_DeleteInterp" tcl-delete-interp) :void
+ (interp :pointer))
+
+;;; --- windows ----------------------------------
+
+(defcfun ("Tk_GetNumMainWindows" tk-get-num-main-windows) :int)
+(defcfun ("Tk_MainWindow" tk-main-window) :pointer (interp :pointer))
+
+(defcfun ("Tk_NameToWindow" tk-name-to-window) :pointer
+ (interp :pointer)
+ (pathName :string)
+ (related-tkwin :pointer))
+
+;;; --- eval -----------------------------------------------
+
+(defcfun ("Tcl_EvalFile" %Tcl_EvalFile) tcl-retcode
+ (interp :pointer)
+ (filename-cstr :string))
+
+(defun Tcl_EvalFile (interp filename)
+ (with-foreign-string (filename-cstr filename)
+ (%Tcl_EvalFile interp filename-cstr)))
+
+(defcfun ("Tcl_Eval" tcl-eval) tcl-retcode
+ (interp :pointer)
+ (script-cstr :string))
+
+(defcfun ("Tcl_EvalEx" tcl_evalex) tcl-retcode
+ (interp :pointer)
+ (script-cstr :string)
+ (num-bytes :int)
+ (flags :int))
+
+(defun tcl-eval-ex (i s)
+ (tcl_evalex i s -1 0))
+
+(defcfun ("Tcl_GetVar" tcl-get-var) :string (interp :pointer)(varName :string)(flags :int))
+
+(defcfun ("Tcl_SetVar" tcl-set-var) :string
+ (interp :pointer)
+ (var-name :string)
+ (new-value :string)
+ (flags :int))
+
+(defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string
+ (interp :pointer))
+
+;; ----------------------------------------------------------------------------
+;; Tcl_CreateCommand - used to implement direct callbacks
+;; ----------------------------------------------------------------------------
+
+(defcfun ("Tcl_CreateCommand" tcl-create-command) :pointer
+ (interp :pointer)
+ (cmdName :string)
+ (proc :pointer)
+ (client-data :pointer)
+ (delete-proc :pointer))
+
+;; ----------------------------------------------------------------------------
+;; Tcl/Tk channel related stuff
+;; ----------------------------------------------------------------------------
+
+(defcfun ("Tcl_RegisterChannel" Tcl_RegisterChannel) :void
+ (interp :pointer)
+ (channel :pointer))
+
+(defcfun ("Tcl_UnregisterChannel" Tcl_UnregisterChannel) :void
+ (interp :pointer)
+ (channel :pointer))
+
+(defcfun ("Tcl_MakeFileChannel" Tcl_MakeFileChannel) :pointer
+ (handle :int)
+ (readOrWrite :int))
+
+(defcfun ("Tcl_GetChannelName" Tcl_GetChannelName) :string
+ (channel :pointer))
+
+(defcfun ("Tcl_GetChannelType" Tcl_GetChannelType) :pointer
+ (channel :pointer))
+
+
+(defcfun ("Tcl_GetChannel" Tcl_GetChannel) :pointer
+ (interp :pointer)
+ (channelName :string)
+ (modePtr :pointer))
+
+;; Initialization mgmt - required to avoid multiple library loads
+
+(defvar *initialized* nil)
+
+(defun set-initialized ()
+ (setq *initialized* t))
+
+(defun reset-initialized ()
+ (setq *initialized* nil))
+
+#+doit
+(reset-initialized)
+
+(defun argv0 ()
+ #+allegro (sys:command-line-argument 0)
+ #+lispworks (nth 0 system:*line-arguments-list*) ;; portable to OS X
+ #+sbcl (nth 0 sb-ext:*posix-argv*)
+ #+openmcl (car ccl:*command-line-argument-list*)
+ #-(or allegro lispworks sbcl openmcl)
+ (error "argv0 function not implemented for this lisp"))
+
+(defun tk-interp-init-ensure ()
+ (unless *initialized*
+ (use-foreign-library Tcl)
+ (use-foreign-library Tk)
+ ;(use-foreign-library Tile)
+ (use-foreign-library Togl)
+ (tcl-find-executable (argv0))
+ (set-initialized)))
+
+;; Send a script to a piven Tcl/Tk interpreter
+
+(defun eval-script (interp script)
+ (assert interp)
+ (assert script)
+ (tcl-eval interp script))
+
119 .#tk-object.lisp.1.14
@@ -0,0 +1,119 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Celtk -- Cells, Tcl, and Tk
+
+Copyright (C) 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :Celtk)
+
+;;; --- tk-object ------------------
+
+
+(defmodel tk-object (model)
+ ((.md-name :cell nil :initform (gentemp "TK") :initarg :id)
+ (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class)
+
+ (timers :owning t :initarg :timers :accessor timers :initform nil)
+ (on-command :initarg :on-command :accessor on-command :initform nil)
+ (on-key-down :initarg :on-key-down :accessor on-key-down :initform nil
+ :documentation "Long story. Tcl C API weak for keypress events. This gets dispatched
+eventually thanks to DEFCOMMAND")
+ (on-key-up :initarg :on-key-up :accessor on-key-up :initform nil)
+ (user-errors :initarg :user-errors :accessor user-errors :initform nil)
+ (tile? :initform t :cell nil :reader tile? :initarg :tile?))
+ (:documentation "Root class for widgets and (canvas) items"))
+
+(export! valid? ^valid?)
+
+(defun valid? (self)
+ (not (^user-errors)))
+
+(defmacro ^valid? ()
+ '(valid? self))
+
+(defmethod md-awaken :before ((self tk-object))
+ (make-tk-instance self))
+
+(defmethod parent-path ((self tk-object)) (path self))
+
+;;; --- deftk --------------------
+
+(defmacro deftk (class superclasses (&rest std-slots) &rest defclass-options)
+ (destructuring-bind (&optional tk-class &rest tk-options)
+ (cdr (find :tk-spec defclass-options :key 'car))
+
+ (setf tk-options (tk-options-normalize tk-options))
+
+ `(eval-now!
+ (defmodel ,class ,(or superclasses '(tk-object))
+ (,@(append std-slots (loop for (slot-name nil) in tk-options
+ collecting `(,slot-name :initform nil
+ :initarg ,(intern (string slot-name) :keyword)
+ :accessor ,slot-name))))
+ ,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car)
+ (:default-initargs
+ ,@(when tk-class `(:tk-class ',tk-class))
+ ,@(cdr (find :default-initargs defclass-options :key 'car))))
+ (defmethod tk-class-options append ((self ,class))
+ ',tk-options)
+ (export ',(loop for (slot nil) in tk-options
+ nconcing (list slot (intern (conc$ "^" slot)))))
+ (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits)
+ `(make-instance ',',class
+ :fm-parent *parent*
+ ,@inits)))))
+
+(defun tk-options-normalize (tk-options)
+ "normalize '(-aaa (tk-bbb -bbb)) => '((aaa -aaa)(tk-bbb -bbb))"
+ (loop for tk-option-def in tk-options
+ for slot-name = (intern (de- (if (atom tk-option-def)
+ tk-option-def (car tk-option-def))))
+ collecting (list slot-name (if (atom tk-option-def)
+ tk-option-def (cadr tk-option-def)))))
+
+(eval-now!
+ (defun de- (sym)
+ (remove #\- (symbol-name sym) :end 1)))
+
+(defgeneric tk-class-options (self)
+ (:method-combination append)
+ (:method :around (self)
+ (or (get (type-of self) 'tk-class-options)
+ (setf (get (type-of self) 'tk-class-options)
+ (loop with all = (remove-duplicates (call-next-method) :key 'second)
+ for old in (when (tile? self)
+ (case (type-of self)
+ (label '(pady padx height indicatoron relief tk-label))
+ (otherwise '(pady padx #+hmmm height indicatoron relief tk-label))));;
+ do (setf old (delete old all :key 'car))
+ finally (return all))))))
+
+(defun tk-config-option (self slot-name)
+ (second (assoc slot-name (tk-class-options self))))
+
+(defmethod slot-value-observe progn (slot-name (self tk-object) new-value old-value old-value-boundp cell)
+ (declare (ignorable old-value cell))
+ (when old-value-boundp ;; initial propagation to Tk happens during make-tk-instance
+ (bwhen (tco (tk-config-option self slot-name)) ;; (get slot-name 'tk-config-option))
+ (tk-configure self (string tco) (or new-value "")))))
+
+(defun tk-configurations (self)
+ (loop with configs
+ for (slot-name tk-option) in (tk-class-options self)
+ when tk-option
+ do (bwhen (slot-value (funcall slot-name self)) ;; must go thru accessor with Cells, not 'slot-value
+ (setf configs (nconc (list tk-option (tk-send-value slot-value)) configs)))
+ finally (return configs)))
+
214 .#togl.lisp.1.25
@@ -0,0 +1,214 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Togl Bindings and Cells/Tk Interfaces
+
+Copyright (C) 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :celtk)
+
+
+(define-foreign-library Togl
+ (:darwin (:or "libTogl1.7.dylib"
+ "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib"))
+ (:windows (:or "togl17.dll"))
+ (:unix "/usr/lib/Togl1.7/libTogl1.7.so"))
+
+(defctype togl-struct-ptr-type :pointer)
+
+;;; --- Togl (Version 1.7 and above needed!) -----------------------------
+
+(defcfun ("Togl_Init" Togl-Init) tcl-retcode
+ (interp :pointer))
+
+(defcfun ("Togl_PostRedisplay" togl-post-redisplay) :void
+ (togl-struct-ptr :pointer))
+
+(defcfun ("Togl_SwapBuffers" togl-swap-buffers) :void
+ (togl-struct-ptr :pointer))
+
+(defcfun ("Togl_Ident" Togl-Ident) :string
+ (togl-struct-ptr :pointer))
+
+(defcfun ("Togl_Width" Togl-Width) :int
+ (togl-struct-ptr :pointer))
+
+(defcfun ("Togl_Height" Togl-Height) :int
+ (togl-struct-ptr :pointer))
+
+(defcfun ("Togl_Interp" Togl-Interp) :pointer
+ (togl-struct-ptr :pointer))
+
+;; Togl_AllocColor
+;; Togl_FreeColor
+
+;; Togl_LoadBitmapFont
+;; Togl_UnloadBitmapFont
+
+;; Togl_SetClientData
+;; Togl_ClientData
+
+;; Togl_UseLayer
+;; Togl_ShowOverlay
+;; Togl_HideOverlay
+;; Togl_PostOverlayRedisplay
+;; Togl_OverlayDisplayFunc
+;; Togl_ExistsOverlay
+;; Togl_GetOverlayTransparentValue
+;; Togl_IsMappedOverlay
+;; Togl_AllocColorOverlay
+;; Togl_FreeColorOverlay
+;; Togl_DumpToEpsFile
+
+(eval-now!
+ (export '(togl with-togl togl-interp togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func
+ togl togl-timer-using-class togl-post-redisplay togl-reshape-using-class
+ togl-display-using-class togl-width togl-height togl-create-using-class)))
+
+;; --- gotta call this bad boy during initialization, I guess any time after we have an interpreter
+;;
+
+(defun tk-togl-init (interp)
+ ;(assert (not (zerop (tcl-init-stubs interp "8.1" 0))))
+ ;(assert (not (zerop (tk-init-stubs interp "8.1" 0))))
+ (togl-init interp)
+ (togl-create-func (callback togl-create))
+ (togl-destroy-func (callback togl-destroy))
+ (togl-display-func (callback togl-display))
+ (togl-reshape-func (callback togl-reshape))
+ (togl-timer-func (callback togl-timer)) ;; probably want to make this optional
+ )
+
+(export! togl-ptr-set ^togl-ptr-set)
+
+(deftk togl (widget)
+ ((togl-ptr :cell nil :initform nil :initarg :togl-ptr :accessor togl-ptr)
+ (togl-ptr-set :initform (c-in nil) :initarg :togl-ptr-set :accessor togl-ptr-set
+ :documentation "very complicated, don't ask (togl-ptr cannot wait on ufb processing)")
+ (cb-create :initform nil :initarg :cb-create :reader cb-create)
+ (cb-display :initform nil :initarg :cb-display :reader cb-display)
+ (cb-reshape :initform nil :initarg :cb-reshape :reader cb-reshape)
+ (cb-destroy :initform nil :initarg :cb-destroy :reader cb-destroy)
+ (cb-timer :initform nil :initarg :cb-timer :reader cb-timer))
+ (:tk-spec togl
+ -width ;; 400 Width of widget in pixels.
+ -height ;; 400 Height of widget in pixels.
+ -ident ;; "" A user identification string ignored by togl.
+ ;; This can be useful in your C callback functions
+ ;; to determine which Togl widget is the caller.
+ -rgba ;; true If true, use RGB(A) mode
+ ;; If false, use Color Index mode
+ -redsize ;; 1 Min bits per red component
+ -greensize ;; 1 Min bits per green component
+ -bluesize ;; 1 Min bits per blue component
+ -double ;; false If false, request a single buffered window
+ ;; If true, request double buffered window
+ -depth ;; false If true, request a depth buffer
+ -depthsize ;; 1 Min bits of depth buffer
+ -accum ;; false If true, request an accumulation buffer
+ -accumredsize ;; 1 Min bits per accum red component
+ -accumgreensize ;; 1 Min bits per accum green component
+ -accumbluesize ;; 1 Min bits per accum blue component
+ -accumalphasize ;; 1 Min bits per accum alpha component
+ -alpha ;; false If true and -rgba is true, request an alpha
+ ;; channel
+ -alphasize ;; 1 Min bits per alpha component
+ -stencil ;; false If true, request a stencil buffer
+ -stencilsize ;; 1 Min number of stencil bits
+ -auxbuffers ;; 0 Desired number of auxiliary buffers
+ -privatecmap ;; false Only applicable in color index mode.
+ ;; If false, use a shared read-only colormap.
+ ;; If true, use a private read/write colormap.
+ -overlay ;; false If true, request overlay planes.
+ -stereo ;; false If true, request a stereo-capable window.
+ (-timer-interval -time) ;; 1 Specifies the interval, in milliseconds, for
+ ; calling the C timer callback function which
+ ; was registered with Togl_TimerFunc.
+ -sharelist ;; "" Name of an existing Togl widget with which to
+ ; share display lists.
+ ; NOT YET IMPLEMENTED FOR WINDOWS 95/NT.
+ -sharecontext ;; "" Name of an existing Togl widget with which to
+ ; share the OpenGL context. NOTE: most other
+ ; attributes such as double buffering, RGBA vs CI,
+ ; ancillary buffer specs, etc are then ignored.
+ ; NOT YET IMPLEMENTED FOR WINDOWS 95/NT.
+ -indirect ;; false If present, request an indirect rendering context.
+ ; A direct rendering context is normally requested.
+ ; NOT SIGNIFICANT FOR WINDOWS 95/NT.
+ )
+ (:default-initargs
+ :double t
+ :rgba t
+ :alpha t
+ :id (gentemp "TOGL")
+ :ident (c? (^path))))
+
+(defmacro with-togl ((togl-form width-var height-var) &body body &aux (togl (gensym))(togl-ptr (gensym)))
+ `(let* ((,togl ,togl-form)
+ (,togl-ptr (togl-ptr ,togl)))
+ (when ,togl-ptr
+ (let ((*tki* (togl-interp ,togl-ptr))
+ (,width-var (togl-width ,togl-ptr))
+ (,height-var (togl-height ,togl-ptr)))
+ ,@body))))
+
+(defmacro def-togl-callback (root (&optional (ptr-var 'togl-ptr)(self-var 'self)) &body preamble)
+ (let ((register$ (format nil "TOGL-~a-FUNC" root))
+ (cb$ (format nil "TOGL-~a" root))
+ (cb-slot$ (format nil "CB-~a" root))
+ (uc$ (format nil "TOGL-~a-USING-CLASS" root)))
+ `(progn
+ (defcfun (,(format nil "Togl_~:(~a~)Func" root) ,(intern register$))
+ :void
+ (callback :pointer))
+ (defcallback ,(intern cb$) :void ((,ptr-var :pointer))
+ (unless (c-stopped)
+ (bif (,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*))
+ (gethash (togl-ident ,ptr-var)(dictionary *tkw*))))
+ (progn
+ ,@preamble
+ (trc nil "selves" ,cb$ (togl-ident ,ptr-var) (gethash (pointer-address ,ptr-var) (tkwins *tkw*))(gethash (togl-ident ,ptr-var)(dictionary *tkw*)))
+ (,(intern uc$) ,self-var))
+ (trc "WARNING: Togl callback ~a sees unknown togl pointer ~a :address ~a :ident ~a"
+ ,cb$ ,ptr-var (pointer-address ,ptr-var) (togl-ident ,ptr-var)))))
+ (defmethod ,(intern uc$) :around ((self togl))
+ (if (,(intern cb-slot$) self)
+ (funcall (,(intern cb-slot$) self) self)
+ (call-next-method)))
+ (defmethod ,(intern uc$) ((self togl))))))
+
+(def-togl-callback create ()
+ (trc "___________________ TOGL SET UP _________________________________________" togl-ptr )
+;;; ;
+;;; ; just comment out these next two lines if not using Cello
+;;; ;
+;;; (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready
+;;; (kt-opengl:kt-opengl-reset)
+;;; ; ^^^^^ above two needed only for cello ^^^^^^
+;;; ;
+ (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred
+ (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK
+ (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))
+
+(def-togl-callback display ())
+(def-togl-callback reshape ())
+(def-togl-callback destroy ())
+(def-togl-callback timer ())
+
+(defmethod make-tk-instance ((self togl))
+ (with-integrity (:client `(:make-tk ,self))
+ (setf (gethash (^path) (dictionary .tkw)) self)
+ (trc nil "making togl!!!!!!!!!!!!" (path self)(tk-configurations self))
+ (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}"
+ (path self)(tk-configurations self))))
226 .#togl.lisp.1.28
@@ -0,0 +1,226 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Togl Bindings and Cells/Tk Interfaces
+
+Copyright (C) 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :celtk)
+
+
+(define-foreign-library Togl
+ (:darwin (:or "libTogl1.7.dylib"
+ "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib"))
+ (:windows (:or "togl17.dll"))
+ (:unix "/usr/lib/Togl1.7/libTogl1.7.so"))
+
+(defctype togl-struct-ptr-type :pointer)
+
+;;; --- Togl (Version 1.7 and above needed!) -----------------------------
+
+(defcfun ("Togl_Init" Togl-Init) tcl-retcode
+ (interp :pointer))
+
+(defcfun ("Togl_PostRedisplay" togl-post-redisplay) :void
+ (togl-struct-ptr :pointer))
+
+(defcfun ("Togl_SwapBuffers" togl-swap-buffers) :void
+ (togl-struct-ptr :pointer))
+
+(defcfun ("Togl_Ident" Togl-Ident) :string
+ (togl-struct-ptr :pointer))
+
+(defcfun ("Togl_Width" Togl-Width) :int
+ (togl-struct-ptr :pointer))
+
+(defcfun ("Togl_Height" Togl-Height) :int
+ (togl-struct-ptr :pointer))
+
+(defcfun ("Togl_Interp" Togl-Interp) :pointer
+ (togl-struct-ptr :pointer))
+
+;; The following functions are not CFFI-translated yet ...
+
+;; Togl_AllocColor
+;; Togl_FreeColor
+
+;; Togl_LoadBitmapFont
+;; Togl_UnloadBitmapFont
+
+;; Togl_SetClientData
+;; Togl_ClientData
+
+;; Togl_UseLayer
+;; Togl_ShowOverlay
+;; Togl_HideOverlay
+;; Togl_PostOverlayRedisplay
+;; Togl_OverlayDisplayFunc
+;; Togl_ExistsOverlay
+;; Togl_GetOverlayTransparentValue
+;; Togl_IsMappedOverlay
+;; Togl_AllocColorOverlay
+;; Togl_FreeColorOverlay
+;; Togl_DumpToEpsFile
+
+(eval-now!
+ (export '(togl with-togl togl-interp togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func
+ togl togl-timer-using-class togl-post-redisplay togl-reshape-using-class
+ togl-display-using-class togl-width togl-height togl-create-using-class)))
+
+;; --- gotta call this bad boy during initialization, I guess any time after we have an interpreter
+;;
+
+(defun tk-togl-init (interp)
+ ;(assert (not (zerop (tcl-init-stubs interp "8.1" 0)))) ;; Only meaningful on Windows
+ ;(assert (not (zerop (tk-init-stubs interp "8.1" 0)))) ;; dito
+ (togl-init interp)
+ (togl-create-func (callback togl-create))
+ (togl-destroy-func (callback togl-destroy))
+ (togl-display-func (callback togl-display))
+ (togl-reshape-func (callback togl-reshape))
+ (togl-timer-func (callback togl-timer)) ;; probably want to make this optional
+ )
+
+(export! togl-ptr-set ^togl-ptr-set)
+
+(deftk togl (widget)
+ ((togl-ptr :cell nil :initform nil :initarg :togl-ptr :accessor togl-ptr)
+ (togl-ptr-set :initform (c-in nil) :initarg :togl-ptr-set :accessor togl-ptr-set
+ :documentation "very complicated, don't ask (togl-ptr cannot wait on ufb processing)")
+ (cb-create :initform nil :initarg :cb-create :reader cb-create)
+ (cb-display :initform nil :initarg :cb-display :reader cb-display)
+ (cb-reshape :initform nil :initarg :cb-reshape :reader cb-reshape)
+ (cb-destroy :initform nil :initarg :cb-destroy :reader cb-destroy)
+ (cb-timer :initform nil :initarg :cb-timer :reader cb-timer))
+ (:tk-spec togl
+ -width ;; 400 Width of widget in pixels.
+ -height ;; 400 Height of widget in pixels.
+ -ident ;; "" A user identification string ignored by togl.
+ ;; This can be useful in your C callback functions
+ ;; to determine which Togl widget is the caller.
+ -rgba ;; true If true, use RGB(A) mode
+ ;; If false, use Color Index mode
+ -redsize ;; 1 Min bits per red component
+ -greensize ;; 1 Min bits per green component
+ -bluesize ;; 1 Min bits per blue component
+ -double ;; false If false, request a single buffered window
+ ;; If true, request double buffered window
+ -depth ;; false If true, request a depth buffer
+ -depthsize ;; 1 Min bits of depth buffer
+ -accum ;; false If true, request an accumulation buffer
+ -accumredsize ;; 1 Min bits per accum red component
+ -accumgreensize ;; 1 Min bits per accum green component
+ -accumbluesize ;; 1 Min bits per accum blue component
+ -accumalphasize ;; 1 Min bits per accum alpha component
+ -alpha ;; false If true and -rgba is true, request an alpha
+ ;; channel
+ -alphasize ;; 1 Min bits per alpha component
+ -stencil ;; false If true, request a stencil buffer
+ -stencilsize ;; 1 Min number of stencil bits
+ -auxbuffers ;; 0 Desired number of auxiliary buffers
+ -privatecmap ;; false Only applicable in color index mode.
+ ;; If false, use a shared read-only colormap.
+ ;; If true, use a private read/write colormap.
+ -overlay ;; false If true, request overlay planes.
+ -stereo ;; false If true, request a stereo-capable window.
+ (-timer-interval -time) ;; 1 Specifies the interval, in milliseconds, for
+ ; calling the C timer callback function which
+ ; was registered with Togl_TimerFunc.
+ -sharelist ;; "" Name of an existing Togl widget with which to
+ ; share display lists.
+ ; NOT YET IMPLEMENTED FOR WINDOWS 95/NT.
+ -sharecontext ;; "" Name of an existing Togl widget with which to
+ ; share the OpenGL context. NOTE: most other
+ ; attributes such as double buffering, RGBA vs CI,
+ ; ancillary buffer specs, etc are then ignored.
+ ; NOT YET IMPLEMENTED FOR WINDOWS 95/NT.
+ -indirect ;; false If present, request an indirect rendering context.
+ ; A direct rendering context is normally requested.
+ ; NOT SIGNIFICANT FOR WINDOWS 95/NT.
+ )
+ (:default-initargs
+ :double t
+ :rgba t
+ :alpha t
+ :id (gentemp "TOGL")
+ :ident (c? (^path))))
+
+(defmacro with-togl ((togl-form width-var height-var) &body body &aux (togl (gensym))(togl-ptr (gensym)))
+ `(let* ((,togl ,togl-form)
+ (,togl-ptr (togl-ptr ,togl)))
+ (when ,togl-ptr
+ (let ((*tki* (togl-interp ,togl-ptr))
+ (,width-var (togl-width ,togl-ptr))
+ (,height-var (togl-height ,togl-ptr)))
+ ,@body))))
+
+(defmacro def-togl-callback (root (&optional (ptr-var 'togl-ptr)(self-var 'self)) &body preamble)
+ (let ((register$ (format nil "TOGL-~a-FUNC" root))
+ (cb$ (format nil "TOGL-~a" root))
+ (cb-slot$ (format nil "CB-~a" root))
+ (uc$ (format nil "TOGL-~a-USING-CLASS" root)))
+ `(progn
+ (defcfun (,(format nil "Togl_~:(~a~)Func" root) ,(intern register$))
+ :void
+ (callback :pointer))
+ (defcallback ,(intern cb$) :void ((,ptr-var :pointer))
+ (unless (c-stopped)
+ (bif (,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*))
+ (gethash (togl-ident ,ptr-var)(dictionary *tkw*))))
+ (progn
+ ,@preamble
+ (trc nil "selves" ,cb$ (togl-ident ,ptr-var) (gethash (pointer-address ,ptr-var) (tkwins *tkw*))(gethash (togl-ident ,ptr-var)(dictionary *tkw*)))
+ (,(intern uc$) ,self-var))
+ (trc "WARNING: Togl callback ~a sees unknown togl pointer ~a :address ~a :ident ~a"
+ ,cb$ ,ptr-var (pointer-address ,ptr-var) (togl-ident ,ptr-var)))))
+ (defmethod ,(intern uc$) :around ((self togl))
+ (if (,(intern cb-slot$) self)
+ (funcall (,(intern cb-slot$) self) self)
+ (call-next-method)))
+ (defmethod ,(intern uc$) ((self togl))))))
+
+
+
+(def-togl-callback create ()
+ (trc "___________________ TOGL SET UP _________________________________________" togl-ptr )
+ ;;
+ ;; Cello dependency here: relies on :CELLO being pushed to *features*!
+ ;;
+ ;;(eval-when (:compile-toplevel :execute)
+ ;; (if (member :cello cl-user::*features*)
+ ;; (progn
+
+ (when (find-package "CL-FTGL")
+ (set (find-symbol "*FTGL-OGL*" "CL-FTGL") togl-ptr)) ;; help debug failure to use lazy cells/classes ;; to defer FTGL till Ogl ready
+
+ (when (find-package "KT-OPENGL")
+ (funcall (symbol-function (find-symbol "KT-OPENGL-RESET" "CL-FTGL"))))
+
+ ;;; ^^^^^ above two needed only for cello ^^^^^^
+ ;;;
+ (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred
+ (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK
+ (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))
+
+(def-togl-callback display ())
+(def-togl-callback reshape ())
+(def-togl-callback destroy ())
+(def-togl-callback timer ())
+
+(defmethod make-tk-instance ((self togl))
+ (with-integrity (:client `(:make-tk ,self))
+ (setf (gethash (^path) (dictionary .tkw)) self)
+ (trc nil "making togl!!!!!!!!!!!!" (path self)(tk-configurations self))
+ (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}"
+ (path self)(tk-configurations self))))
10 CelloTk-test.lisp
@@ -0,0 +1,10 @@
+#|
+
+This library is meant to be the minimal Tk/Togl reuired to support a Cello application that
+dpes not use Tk widgets other than the Window, Menus, and Togl.
+
+This library does not have a test function.
+
+To test, look for Celtk3D which pulls in cl-opengl, this project, and the gears demo.
+
+|#
109 CelloTk.lpr
@@ -0,0 +1,109 @@
+;; -*- lisp-version: "8.1 [Windows] (May 13, 2009 12:58)"; cg: "1.103.2.10"; -*-
+
+(in-package :cg-user)
+
+(defpackage :CELTK)
+
+(define-project :name :celtk
+ :modules (list (make-instance 'module :name "Celtk.lisp")
+ (make-instance 'module :name "tk-structs.lisp")
+ (make-instance 'module :name "tk-interp.lisp")
+ (make-instance 'module :name "tk-events.lisp")
+ (make-instance 'module :name "tk-object.lisp")
+ (make-instance 'module :name "font.lisp")
+ (make-instance 'module :name "widget.lisp")
+ (make-instance 'module :name "layout.lisp")
+ (make-instance 'module :name "timer.lisp")
+ (make-instance 'module :name "menu.lisp")
+ (make-instance 'module :name "composites.lisp")
+ (make-instance 'module :name "frame.lisp")
+ (make-instance 'module :name "togl.lisp")
+ (make-instance 'module :name "run.lisp")
+ (make-instance 'module :name "CelloTk-test.lisp")
+ (make-instance 'module :name "keysym.lisp"))
+ :projects (list (make-instance 'project-module :name
+ "..\\cells\\cells" :show-modules nil)
+ (make-instance 'project-module :name
+ "..\\1-devtools\\cffi\\cffi"
+ :show-modules nil))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :celtk
+ :main-form nil
+ :compilation-unit t
+ :verbose nil
+ :runtime-modules (list :cg-dde-utils :cg.base :cg.bitmap-pane
+ :cg.bitmap-pane.clipboard :cg.bitmap-stream
+ :cg.button :cg.caret :cg.check-box
+ :cg.choice-list :cg.choose-printer
+ :cg.clipboard :cg.clipboard-stack
+ :cg.clipboard.pixmap :cg.color-dialog
+ :cg.combo-box :cg.common-control :cg.comtab
+ :cg.cursor-pixmap :cg.curve :cg.dialog-item
+ :cg.directory-dialog :cg.directory-dialog-os
+ :cg.drag-and-drop :cg.drag-and-drop-image
+ :cg.drawable :cg.drawable.clipboard
+ :cg.dropping-outline :cg.edit-in-place
+ :cg.editable-text :cg.file-dialog
+ :cg.fill-texture :cg.find-string-dialog
+ :cg.font-dialog :cg.gesture-emulation
+ :cg.get-pixmap :cg.get-position
+ :cg.graphics-context :cg.grid-widget
+ :cg.grid-widget.drag-and-drop :cg.group-box
+ :cg.header-control :cg.hotspot :cg.html-dialog
+ :cg.html-widget :cg.icon :cg.icon-pixmap
+ :cg.ie :cg.item-list :cg.keyboard-shortcuts
+ :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane
+ :cg.lisp-text :cg.lisp-widget :cg.list-view
+ :cg.mci :cg.menu :cg.menu.tooltip
+ :cg.message-dialog
+ :cg.multi-line-editable-text
+ :cg.multi-line-lisp-text
+ :cg.multi-picture-button
+ :cg.multi-picture-button.drag-and-drop
+ :cg.multi-picture-button.tooltip :cg.ocx
+ :cg.os-widget :cg.os-window :cg.outline
+ :cg.outline.drag-and-drop
+ :cg.outline.edit-in-place :cg.palette
+ :cg.paren-matching :cg.picture-widget
+ :cg.picture-widget.palette :cg.pixmap
+ :cg.pixmap-widget :cg.pixmap.file-io
+ :cg.pixmap.printing :cg.pixmap.rotate
+ :cg.printing :cg.progress-indicator
+ :cg.project-window :cg.property
+ :cg.radio-button :cg.rich-edit
+ :cg.rich-edit-pane
+ :cg.rich-edit-pane.clipboard
+ :cg.rich-edit-pane.printing
+ :cg.sample-file-menu :cg.scaling-stream
+ :cg.scroll-bar :cg.scroll-bar-mixin
+ :cg.selected-object :cg.shortcut-menu
+ :cg.static-text :cg.status-bar
+ :cg.string-dialog :cg.tab-control
+ :cg.template-string :cg.text-edit-pane
+ :cg.text-edit-pane.file-io
+ :cg.text-edit-pane.mark :cg.text-or-combo
+ :cg.text-widget :cg.timer :cg.toggling-widget
+ :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray
+ :cg.up-down-control :cg.utility-dialog
+ :cg.web-browser :cg.web-browser.dde
+ :cg.wrap-string :cg.yes-no-list
+ :cg.yes-no-string :dde)
+ :splash-file-module (make-instance 'build-module :name "")
+ :icon-file-module (make-instance 'build-module :name "")
+ :include-flags (list :top-level :debugger)
+ :build-flags (list :allow-runtime-debug :purify)
+ :autoload-warning t
+ :full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
+ :default-command-line-arguments "+M +t \"Console for Debugging\""
+ :additional-build-lisp-image-arguments (list :read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :build-number 0
+ :on-initialization 'celtk::test
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
43 Celtk.asd
@@ -0,0 +1,43 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+#+(or allegro lispworks cmu mcl clisp cormanlisp sbcl scl)
+(progn
+ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))))
+
+(asdf:defsystem :celtk
+ :name "celtk"
+ :author "Kenny Tilton <kentilton@gmail.com>"
+ :version "2.0"
+ :maintainer "Kenny Tilton <kentilton@gmail.com>"
+ :licence "Lisp LGPL"
+ :description "Tcl/Tk with Cells Inside(tm)"
+ :long-description "A Cells-driven portable GUI, ultimately implmented by Tcl/Tk"
+ :depends-on (:cells :cffi :gui-geometry)
+ :serial t
+ :components ((:file "Celtk")
+ (:file "tk-structs")
+ (:file "tk-interp")
+ (:file "tk-events")
+ (:file "tk-object")
+ (:file "widget")
+ (:file "layout")
+ (:file "font")
+ (:file "timer")
+ (:file "menu")
+ (:file "label")
+ (:file "entry")
+ (:file "button")
+ (:file "multichoice")
+ (:file "scroll")
+ (:file "canvas")
+ (:file "text-item")
+ (:file "item-pictorial")
+ (:file "item-shaped")
+ (:file "composites")
+ (:file "frame")
+ (:file "fileevent")
+ (:file "togl")
+ (:file "run")
+ (:file "ltktest-ci")
+ (:file "lotsa-widgets")
+ (:file "demos")))
95 Celtk3D.lpr
@@ -0,0 +1,95 @@
+;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*-
+
+(in-package :cg-user)
+
+(defpackage :CELTK)
+
+(define-project :name :celtk3d
+ :modules (list (make-instance 'module :name "cellogears.lisp"))
+ :projects (list (make-instance 'project-module :name
+ "..\\cells\\cells")
+ (make-instance 'project-module :name
+ "C:\\1-devtools\\cffi\\cffi")
+ (make-instance 'project-module :name
+ "C:\\1-devtools\\cl-opengl\\glu")
+ (make-instance 'project-module :name "CELTK"))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :celtk
+ :main-form nil
+ :compilation-unit t
+ :verbose nil
+ :runtime-modules (list :cg-dde-utils :cg.base :cg.bitmap-pane
+ :cg.bitmap-pane.clipboard :cg.bitmap-stream
+ :cg.button :cg.caret :cg.check-box
+ :cg.choice-list :cg.choose-printer
+ :cg.clipboard :cg.clipboard-stack
+ :cg.clipboard.pixmap :cg.color-dialog
+ :cg.combo-box :cg.common-control :cg.comtab
+ :cg.cursor-pixmap :cg.curve :cg.dialog-item
+ :cg.directory-dialog :cg.directory-dialog-os
+ :cg.drag-and-drop :cg.drag-and-drop-image
+ :cg.drawable :cg.drawable.clipboard
+ :cg.dropping-outline :cg.edit-in-place
+ :cg.editable-text :cg.file-dialog
+ :cg.fill-texture :cg.find-string-dialog
+ :cg.font-dialog :cg.gesture-emulation
+ :cg.get-pixmap :cg.get-position
+ :cg.graphics-context :cg.grid-widget
+ :cg.grid-widget.drag-and-drop :cg.group-box
+ :cg.header-control :cg.hotspot :cg.html-dialog
+ :cg.html-widget :cg.icon :cg.icon-pixmap
+ :cg.ie :cg.item-list :cg.keyboard-shortcuts
+ :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane
+ :cg.lisp-text :cg.lisp-widget :cg.list-view
+ :cg.mci :cg.menu :cg.menu.tooltip
+ :cg.message-dialog
+ :cg.multi-line-editable-text
+ :cg.multi-line-lisp-text
+ :cg.multi-picture-button
+ :cg.multi-picture-button.drag-and-drop
+ :cg.multi-picture-button.tooltip :cg.ocx
+ :cg.os-widget :cg.os-window :cg.outline
+ :cg.outline.drag-and-drop
+ :cg.outline.edit-in-place :cg.palette
+ :cg.paren-matching :cg.picture-widget
+ :cg.picture-widget.palette :cg.pixmap
+ :cg.pixmap-widget :cg.pixmap.file-io
+ :cg.pixmap.printing :cg.pixmap.rotate
+ :cg.printing :cg.progress-indicator
+ :cg.project-window :cg.property
+ :cg.radio-button :cg.rich-edit
+ :cg.rich-edit-pane
+ :cg.rich-edit-pane.clipboard
+ :cg.rich-edit-pane.printing
+ :cg.sample-file-menu :cg.scaling-stream
+ :cg.scroll-bar :cg.scroll-bar-mixin
+ :cg.selected-object :cg.shortcut-menu
+ :cg.static-text :cg.status-bar
+ :cg.string-dialog :cg.tab-control
+ :cg.template-string :cg.text-edit-pane
+ :cg.text-edit-pane.file-io
+ :cg.text-edit-pane.mark :cg.text-or-combo
+ :cg.text-widget :cg.timer :cg.toggling-widget
+ :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray
+ :cg.up-down-control :cg.utility-dialog
+ :cg.web-browser :cg.web-browser.dde
+ :cg.wrap-string :cg.yes-no-list
+ :cg.yes-no-string :dde)
+ :splash-file-module (make-instance 'build-module :name "")
+ :icon-file-module (make-instance 'build-module :name "")
+ :include-flags (list :top-level :debugger)
+ :build-flags (list :allow-runtime-debug :purify)
+ :autoload-warning t
+ :full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
+ :default-command-line-arguments "+M +t \"Console for Debugging\""
+ :additional-build-lisp-image-arguments (list :read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :on-initialization 'celtk::cellogears
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
39 andy-expander.lisp
@@ -0,0 +1,39 @@
+(in-package :celtk)
+
+(defmodel expander (frame-stack)
+ ((label :initarg :label :accessor label :initform (c-in nil))
+ (expansion :initarg :expansion :accessor expansion :initform nil)
+ (expanded :initarg :expanded :accessor expanded :initform (c-in nil)))
+ (:default-initargs
+ :fm-parent (error "expander widget must have some kind of parent")))
+
+(defmacro mk-expander ((&rest inits) &body body)
+ `(make-instance 'expander
+ ,@inits
+ :fm-parent *parent*
+ :expansion (c? (the-kids ,@body))
+ :expanded (c-in t)
+ :kids (c? (the-kids
+ (mk-button-ex ((^label) (setf (expanded (upper self expander))
+ (not (expanded (upper self expander))))))
+ (^expansion)))
+ :kids-packing (c? (when (^kids)
+ (if (^expanded)
+ (format nil "pack~{ ~a~} -side top -anchor nw -padx ~a -pady ~a"
+ (mapcar 'path (^kids))
+ (^padx) (^pady))
+ (format nil "pack forget~{ ~a~}"
+ (mapcar 'path (cdr (^kids)))))))))
+
+
+(defmodel expander-test (window)
+ ()
+ (:default-initargs
+ :kids (c? (the-kids
+ (mk-stack (:packing (c?pack-self))
+ (mk-expander (:label "hi")
+ (mk-label :text "hi")
+ (mk-label :text "ho")))))))
+
+(defun test-andy-expander ()
+ (test-window 'expander-test))
12 asdf-projects.lisp
@@ -0,0 +1,12 @@
+(in-package :cl-user)
+
+
+
+(eval-when (compile load)
+ (require :asdf)
+ (loop for project in '(alexandria trivial-features_0.6 babel_0.3.0 cffi_0.10.5)
+ do (pushnew
+ (namestring (make-pathname :directory `(:absolute "devel" ,(string project))))
+ asdf:*central-registry* :test 'string-equal))
+ (asdf:oos 'asdf:load-op :cffi))
+
96 button.lisp
@@ -0,0 +1,96 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Celtk -- Cells, Tcl, and Tk
+
+Copyright (C) 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :celtk)
+
+;--- button ----------------------------------------------
+
+(deftk button (commander widget)
+ ()
+ (:tk-spec button
+ -activebackground -activeforeground -anchor
+ -background -bitmap -borderwidth -cursor
+ -disabledforeground (tkfont -font) -foreground
+ -highlightbackground -highlightcolor -highlightthickness -image
+ (tk-justify -justify)
+ -padx -pady -relief -repeatdelay
+ -repeatinterval -takefocus -text -textvariable
+ -underline -wraplength
+ -command -compound -default -height -overrelief -state -width)
+ (:default-initargs
+ :id (gentemp "B")))
+
+
+
+(defmacro mk-button-ex ((text command) &rest initargs)
+ `(make-instance 'button
+ :fm-parent *parent*
+ :text ,text
+ :on-command (c? (lambda (self)
+ (declare (ignorable self))
+ ,command))
+ ,@initargs))
+
+; --- checkbutton ---------------------------------------------
+
+(deftk radiocheck (commander widget)
+ ()
+ (:tk-spec radiocheck
+ -activebackground -activeforeground -anchor
+ -background -bitmap -borderwidth -compound -cursor
+ -disabledforeground (tkfont -font) -foreground
+ -highlightbackground -highlightcolor -highlightthickness -image
+ (tk-justify -justify) -padx -pady -relief -takefocus -text -textvariable
+ -underline -wraplength
+ -command -height -indicatoron -offrelief
+ -overrelief -selectcolor -selectimage -state -tristateimage
+ -tristatevalue (tk-variable -variable) -width))
+
+
+(deftk checkbutton (radiocheck)
+ ()
+ (:tk-spec checkbutton
+ -offvalue -onvalue)
+ (:default-initargs
+ :id (gentemp "CK")
+ :value (c-in nil)
+ :tk-variable (c? (^path))
+ :on-command (lambda (self)
+ (setf (^value) (not (^value))))))
+
+(defobserver .value ((self checkbutton))
+ (tk-format `(:variable ,self) "set ~(~a~) ~a" (path self) (if new-value 1 0)))
+
+; --- radiobutton -------------------------------------
+
+(deftk radiobutton (radiocheck)
+ ()
+ (:tk-spec radiobutton
+ -value)
+ (:default-initargs
+ :id (gentemp "RB")
+ :tk-variable (c? (path (upper self tk-selector)))
+ :on-command (lambda (self)
+ (setf (selection (upper self tk-selector)) (value self)))))
+
+(defmacro mk-radiobutton-ex ((text value) &rest initargs)
+ `(make-instance 'radiobutton
+ :fm-parent *parent*
+ :text ,text
+ :value ,value
+ ,@initargs))
96 canvas.lisp
@@ -0,0 +1,96 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Celtk -- Cells, Tcl, and Tk
+
+Copyright (C) 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :celtk)
+
+(deftk canvas (widget)
+ ((active :initarg :active :accessor active :initform (c-in t))
+ )
+ (:tk-spec canvas
+ -background -borderwidth -cursor
+ -highlightbackground -highlightcolor -highlightthickness
+ -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth
+ -relief -selectbackground -selectborderwidth -selectforeground
+ -state -takefocus -xscrollcommand -yscrollcommand
+ -closeenough -confine -height (scroll-region -scrollregion) -width
+ -xscrollincrement -yscrollincrement)
+ (:default-initargs
+ :xscrollcommand (c-in nil)
+ :yscrollcommand (c-in nil)
+ :id (gentemp "CV")
+ :tile? nil))
+
+(defun focusIn->active ()
+ (list '|<FocusIn>| (lambda (self event &rest args)
+ (declare (ignorable event))
+ (trc "focus in activating" self event args)
+ (setf (^active) t))))
+
+(defun focusOut->active ()
+ (list '|<FocusOut>| (lambda (self event &rest args)
+ (declare (ignorable event))
+ (trc "focus out de-activating" self event args)
+ (setf (^active) nil))))
+
+(deftk arc (item)
+ ()
+ (:tk-spec arc
+ -dash
+ -activedash
+ -disableddash
+ -dashoffset
+ (tk-fill -fill)
+ -activefill
+ -disabledfill
+ -offset
+ -outline
+ -activeoutline
+ -disabledoutline
+ -outlinestipple
+ -activeoutlinestipple
+ -disabledoutlinestipple
+ -stipple
+ -activestipple
+ -disabledstipple
+ -state
+ -tags
+ -width
+ -activewidth
+ -disabledwidth
+ -extent -start -style))
+
+(deftk line (item)
+ ()
+ (:tk-spec line
+ -dash
+ -activedash
+ -disableddash
+ -dashoffset
+ (tk-fill -fill)
+ -activefill
+ -disabledfill
+ -stipple
+ -activestipple
+ -disabledstipple
+ -state
+ -tags
+ -width
+ -activewidth
+ -disabledwidth
+ -arrow -arrowshape -capstyle -joinstyle -smooth -splinesteps))
+
297 cellogears.lisp
@@ -0,0 +1,297 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;; gears.lisp --- Celtk/Togl version of cl-opengl Lisp version of gears.c (GLUT Mesa demos).
+;;;
+;;; Simple program with rotating 3-D gear wheels.
+
+(in-package :celtk)
+
+(defvar *startx*)
+(defvar *starty*)
+(defvar *xangle0*)
+(defvar *yangle0*)
+(defvar *xangle*)
+(defvar *yangle*)
+
+(defparameter *vTime* 100)
+
+(defun cellogears () ;; ACL project manager needs a zero-argument function, in project package
+ (let ((*startx* nil)
+ (*starty* nil)
+ (*xangle0* nil)
+ (*yangle0* nil)
+ (*xangle* 0.2)
+ (*yangle* 0.0))
+ (test-window 'gears-demo)))
+
+(defmodel gears-demo (window)
+ ((gear-ct :initform (c-in 1) :accessor gear-ct :initarg :gear-ct)
+ (scale :initform (c-in 1) :accessor scale :initarg :scale))
+ (:default-initargs
+ :title$ "Rotating Gear Widget Test"
+ :kids (c? (the-kids
+ (mk-stack (:packing (c?pack-self "-side left -fill both"))
+ ;
+ ; An awful use of GUI...
+ ;
+ (mk-checkbutton :id :on-off
+ :text (c? (if (^value) "Stop" "Start"))
+ :value (c-in t))
+ ;
+ ; The pretty bit...
+ ;
+ (make-instance 'gears
+ :fm-parent *parent*
+ :width 400 :height 400
+ :timer-interval (c? (let ((n$ "100"))
+ (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0)))))
+ :double 1 ;; "yes"
+ :event-handler (c? (lambda (self xe)
+ (trc nil "togl event" (tk-event-type (xsv type xe)))
+
+ (case (tk-event-type (xsv type xe))
+ (:virtualevent
+ (trc nil "canvas virtual" (xsv name xe)))
+ (:buttonpress
+ #+not (RotStart self (xsv x xe) (xsv y xe))
+ (RotStart self (xsv x-root xe) (xsv y-root xe)))
+ (:motionnotify
+ #+not (RotMove self (xsv x xe) (xsv y xe))
+ (RotMove self (xsv x-root xe) (xsv y-root xe)))
+ (:buttonrelease
+ (setf *startx* nil))))))
+ (mk-label :text "Click and drag to rotate model"))))))
+
+(defun RotStart (self x y)
+ (setf *startx* x)
+ (setf *starty* y)
+ (setf *xangle0* (rotx self))
+ (setf *yangle0* (roty self)))
+
+(defun RotMove (self x y)
+ (when *startx*
+ (trc nil "rotmove started" x *startx* *xangle0*)
+ (setf *xangle* (+ *xangle0* (- x *startx*)))
+ (setf *yangle* (+ *yangle0* (- y *starty*)))
+ (setf (rotx self) *xangle*)
+ (setf (roty self) *yangle*)
+ (togl-post-redisplay (togl-ptr self))))
+
+(defconstant +pif+ (coerce pi 'single-float))
+
+(defun draw-scaled-gear (scale)
+ (draw-gear 1.0 (* 2.0 scale) 1.0 (* 10 scale) 0.7))
+
+(defmodel gears (togl)
+ ((rotx :initform (c-in 40) :accessor rotx :initarg :rotx)
+ (roty :initform (c-in 25) :accessor roty :initarg :roty)
+ (rotz :initform (c-in 10) :accessor rotz :initarg :rotz)
+ (gear1 :initarg :gear1 :accessor gear1
+ :initform (c_? (trc nil "making list!!!!! 1")
+ (let ((dl (gl:gen-lists 1)))
+ (gl:with-new-list (dl :compile)
+ (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0))
+ (draw-scaled-gear 2))
+ dl)))
+ (gear2 :initarg :gear2 :accessor gear2
+ :initform (c_? (let ((dl (gl:gen-lists 1)))
+ (gl:with-new-list (dl :compile)
+ (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0))
+ (draw-scaled-gear 1))
+ dl)))
+ (gear3 :initarg :gear3 :accessor gear3
+ :initform (c_? (let ((dl (gl:gen-lists 1)))
+ (gl:with-new-list (dl :compile)
+ (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0))
+ (draw-scaled-gear 1))
+ dl)))
+
+ (angle :initform (c-in 0.0) :accessor angle :initarg :angle)
+ (frame-count :cell nil :initform 0 :accessor frame-count)
+ (t0 :cell nil :initform 0 :accessor t0)
+ ;
+ (width :initarg :wdith :initform 400 :accessor width)
+ (height :initarg :wdith :initform 400 :accessor height)))
+
+(defmethod togl-timer-using-class ((self gears))
+ (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time))
+ (when (fmv :on-off)
+ (incf (^angle) 5.0)
+ (togl-post-redisplay (togl-ptr self)))
+ ;(loop until (zerop (ctk::Tcl_DoOneEvent 2)))
+ )
+
+(defmethod togl-create-using-class ((self gears))
+ (gl:light :light0 :position #(5.0 5.0 10.0 0.0))
+ (gl:enable :cull-face :lighting :light0 :depth-test)
+ (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0))
+ (gl:enable :normalize)
+ (truc self))
+
+(defmethod togl-reshape-using-class ((self gears))
+ (trc nil "reshape")
+ (truc self t)
+ )
+
+(defun truc (self &optional truly)
+ (let ((width (Togl-width (togl-ptr self)))
+ (height (Togl-height (togl-ptr self))))
+ (trc nil "enter gear reshape" self width (width self))
+ (gl:viewport 0 (- height (height self)) (width self) (height self))
+ (unless truly
+ (gl:matrix-mode :projection)
+ (gl:load-identity)
+ (let ((h (/ height width)))
+ (gl:frustum -1 1 (- h) h 5 60)))
+ (progn
+ (gl:matrix-mode :modelview)
+ (gl:load-identity)
+ (gl:translate 0 0 -30))))
+
+
+(defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo))))
+ (declare (ignorable scale))
+ (trc nil "display angle" (^rotx)(^roty)(^rotz))
+ (gl:clear-color 0 0 0 1)
+ (gl:clear :color-buffer-bit :depth-buffer-bit)
+
+ (gl:with-pushed-matrix
+ (gl:rotate (^rotx) 1 0 0)
+ (gl:rotate (^roty) 0 1 0)
+ (gl:rotate (^rotz) 0 0 1)
+
+ (gl:with-pushed-matrix
+ (gl:translate -3 -2 0)
+ (gl:rotate (^angle) 0 0 1)
+ (gl:call-list (^gear1)))
+
+ (gl:with-pushed-matrix
+ (gl:translate 3.1 -2 0)
+ (gl:rotate (- (* -2 (^angle)) 9) 0 0 1)
+ (gl:call-list (^gear2)))
+
+ (gl:with-pushed-matrix ; gear3
+ (gl:translate -3.1 4.2 0.0)
+ (gl:rotate (- (* -2 (^angle)) 25) 0 0 1)
+ (gl:call-list (^gear3))))
+
+ (Togl-Swap-Buffers (togl-ptr self))
+
+ #+shhh (print-frame-rate self))
+
+(defun draw-gear (inner-radius outer-radius width n-teeth tooth-depth)
+ "Draw a gear."
+ (declare (single-float inner-radius outer-radius width tooth-depth)
+ (fixnum n-teeth))
+ (let ((r0 inner-radius)
+ (r1 (- outer-radius (/ tooth-depth 2.0)))
+ (r2 (+ outer-radius (/ tooth-depth 2.0)))
+ (da (/ (* 2.0 +pif+) n-teeth 4.0)))
+ (gl:shade-model :flat)
+ (gl:normal 0 0 1)
+ ;; Draw front face.
+ (gl:with-primitives :quad-strip
+ (dotimes (i (1+ n-teeth))
+ (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
+ (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
+ (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
+ (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
+ (gl:vertex (* r1 (cos (+ angle (* 3 da))))
+ (* r1 (sin (+ angle (* 3 da))))
+ (* width 0.5)))))
+ ;; Draw front sides of teeth.
+ (gl:with-primitives :quads
+ (dotimes (i n-teeth)
+ (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
+ (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
+ (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
+ (* width 0.5))
+ (gl:vertex (* r2 (cos (+ angle (* 2 da))))
+ (* r2 (sin (+ angle (* 2 da))))
+ (* width 0.5))
+ (gl:vertex (* r1 (cos (+ angle (* 3 da))))
+ (* r1 (sin (+ angle (* 3 da))))
+ (* width 0.5)))))
+ (gl:normal 0 0 -1)
+ ;; Draw back face.
+ (gl:with-primitives :quad-strip
+ (dotimes (i (1+ n-teeth))
+ (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
+ (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))
+ (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))
+ (gl:vertex (* r1 (cos (+ angle (* 3 da))))
+ (* r1 (sin (+ angle (* 3 da))))
+ (* width -0.5))
+ (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)))))
+ ;; Draw back sides of teeth.
+ (gl:with-primitives :quads
+ (dotimes (i n-teeth)
+ (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
+ (gl:vertex (* r1 (cos (+ angle (* 3 da))))
+ (* r1 (sin (+ angle (* 3 da))))
+ (* (- width) 0.5))
+ (gl:vertex (* r2 (cos (+ angle (* 2 da))))
+ (* r2 (sin (+ angle (* 2 da))))
+ (* (- width) 0.5))
+ (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
+ (* (- width) 0.5))
+ (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5)))))
+ ;; Draw outward faces of teeth.
+ (gl:with-primitives :quad-strip
+ (dotimes (i n-teeth)
+ (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
+ (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
+ (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5))
+ (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle))))
+ (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle))))
+ (len (sqrt (+ (* u u) (* v v)))))
+ (setq u (/ u len))
+ (setq v (/ u len))
+ (gl:normal v (- u) 0.0)
+ (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
+ (* width 0.5))
+ (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da)))
+ (* (- width) 0.5))
+ (gl:normal (cos angle) (sin angle) 0.0)
+ (gl:vertex (* r2 (cos (+ angle (* 2 da))))
+ (* r2 (sin (+ angle (* 2 da))))
+ (* width 0.5))
+ (gl:vertex (* r2 (cos (+ angle (* 2 da))))
+ (* r2 (sin (+ angle (* 2 da))))
+ (* (- width) 0.5))
+ (setq u (- (* r1 (cos (+ angle (* 3 da))))
+ (* r2 (cos (+ angle (* 2 da))))))
+ (setq v (- (* r1 (sin (+ angle (* 3 da))))
+ (* r2 (sin (+ angle (* 2 da))))))
+ (gl:normal v (- u) 0.0)
+ (gl:vertex (* r1 (cos (+ angle (* 3 da))))
+ (* r1 (sin (+ angle (* 3 da))))
+ (* width 0.5))
+ (gl:vertex (* r1 (cos (+ angle (* 3 da))))
+ (* r1 (sin (+ angle (* 3 da))))
+ (* (- width) 0.5))
+ (gl:normal (cos angle) (sin angle) 0.0))))
+ (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5))
+ (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* (- width) 0.5)))
+ ;; Draw inside radius cylinder.
+ (gl:shade-model :smooth)
+ (gl:with-primitives :quad-strip
+ (dotimes (i (1+ n-teeth))
+ (let ((angle (/ (* i 2.0 +pif+) n-teeth)))
+ (gl:normal (- (cos angle)) (- (sin angle)) 0.0)
+ (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* (- width) 0.5))
+ (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)))))))
+
+(defun print-frame-rate (window)
+ (with-slots (frame-count t0) window
+ (incf frame-count)
+ (let ((time (get-internal-real-time)))
+ (when (= t0 0)
+ (setq t0 time))
+ (when (>= (- time t0) (* 5 internal-time-units-per-second))
+ (let* ((seconds (/ (- time t0) internal-time-units-per-second))
+ (fps (/ frame-count seconds)))
+ (declare (ignorable fps))
+ #+shh (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%"
+ frame-count seconds fps))
+ (setq t0 time)
+ (setq frame-count 0)))))
277 celtk.lisp
@@ -0,0 +1,277 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Celtk -- Cells, Tcl, and Tk
+
+Copyright (C) 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.43 2008/06/16 12:35:55 ktilton Exp $
+
+;(pushnew :tile *features*) ;; frgo, 2007-09-21: Need to do this only when tile actually loaded
+
+
+(defpackage :celtk
+ (:nicknames #:ctk)
+ (:use :common-lisp :utils-kt :cells :cffi)
+ (:export
+ #:right #:left
+ #:<1> #:tk-event-type #:xsv #:name #:x #:y #:x-root #:y-root
+ #:title$ #:pop-up #:path #:parent-path #:^keyboard-modifiers
+ #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget
+ #:mk-panedwindow
+ #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label
+ #:^selection #:selection #:tk-selector
+ #:mk-checkbutton #:button #:mk-button #:mk-button-ex #:entry #:mk-entry #:text
+ #:frame-stack #:mk-frame-stack #:path #:^path
+ #:mk-menu-entry-radiobutton #:mk-menu-entry-checkbutton
+ #:mk-menu-radio-group #:mk-menu-entry-separator
+ #:mk-menu-entry-command #:mk-menu-entry-command-ex
+ #:menu #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar
+ #:^entry-values #:tk-eval #:tk-eval-list #:scale #:mk-scale #:mk-popup-menubutton
+ #:item #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc
+ #:text-item #:mk-text-item #:item-geometer
+ #:rectangle #:mk-rectangle #:bitmap #:mk-bitmap #:canvas #:mk-canvas #:mk-frame-row
+ #:mk-scrolled-list #:listbox-item #:mk-spinbox
+ #:mk-scroller #:mk-menu-entry-cascade-ex
+ #:with-ltk #:tk-format #:send-wish #:value #:.tkw
+ #:tk-user-queue-handler #:user-errors #:^user-errors
+ #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps
+ #:^widget-menu #:widget-menu #:tk-format-now
+ #:coords #:^coords #:tk-translate-keysym
+ #:*tkw*))
+
+(defpackage :celtk-user
+ (:use :common-lisp :utils-kt :cells :celtk))
+
+(in-package :celtk)
+
+
+#+(and allegrocl ide (not runtime-system))
+(ide::defdefiner defcallback defun)
+
+(defvar *tki* nil)
+(defparameter *windows-being-destroyed* nil)
+(defparameter *windows-destroyed* nil)
+
+(defparameter *tk-last* nil "Debug aid. Last recorded command send to Tk")
+
+(defparameter *tkw* nil)
+
+(define-symbol-macro .tkw (nearest self window))
+
+; --- tk-format --- talking to wish/Tk -----------------------------------------------------
+
+(defparameter *tk-client-task-priority*
+ '(:delete :forget :destroy
+ :pre-make-tk :make-tk :make-tk-menubutton :post-make-tk
+ :variable :bind :selection :trace :configure :grid :pack :fini))
+
+(defun tk-user-queue-sort (task1 task2)
+ "Intended for use as user queue sorter, to make Tk happy by giving it stuff in the order it needs to work properly."
+ (destructuring-bind (type1 self1 &rest dbg) task1
+ (declare (ignorable dbg))
+ (destructuring-bind (type2 self2 &rest dbg) task2
+ (declare (ignorable dbg))
+ (let ((p1 (position type1 *tk-client-task-priority*))
+ (p2 (position type2 *tk-client-task-priority*)))
+ (cond
+ ((< p1 p2) t)
+ ((< p2 p1) nil)
+ (t (case type1 ;; they are the same if we are here
+ (:make-tk
+ (fm-ordered-p self1 self2))
+ (:pack
+ (fm-ascendant-p self2 self1)))))))))
+
+
+(defun tk-user-queue-handler (user-q)
+ (loop for (defer-info . nil) in (fifo-data user-q)
+ unless (find (car defer-info) *tk-client-task-priority*)
+ do (error "unknown tk client task type ~a in task: ~a " (car defer-info) defer-info))
+
+ (loop for (defer-info . task) in (prog1
+ (stable-sort (fifo-data user-q) 'tk-user-queue-sort :key 'car)
+ (fifo-clear user-q))
+ do
+ (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info)
+ (funcall task :user-q defer-info)))
+
+#+save
+(defun tk-format-now (fmt$ &rest fmt-args)
+ (unless (find *tkw* *windows-destroyed*)
+ (let* ((*print-circle* nil)
+ (tk$ (apply 'format nil fmt$ fmt-args)))
+ ;
+ ; --- debug stuff ---------------------------------
+ ;
+
+ (let ((yes '(#+shhh "play-me"))
+ (no '("font")))
+ (declare (ignorable yes no))
+ (when (and (or ;; (null yes)
+ (find-if (lambda (s) (search s tk$)) yes))
+ #+hunh? (not (find-if (lambda (s) (search s tk$)) no)))
+ (format t "~&tk> ~a~%" tk$)))
+ (assert *tki*)
+
+ ; --- end debug stuff ------------------------------
+ ;
+ ; --- serious stuff ---
+ ;
+ (setf *tk-last* tk$)
+ (tcl-eval-ex *tki* tk$))))
+
+(defparameter *tk-fmt* nil)
+(export! *tk-fmt*)
+
+(defparameter *tk-log* nil)
+
+(defun tk-format-now (fmt$ &rest fmt-args)
+ (unless (find *tkw* *windows-destroyed*)
+ (let* ((*print-circle* nil)
+ (tk$ (apply 'format nil fmt$ fmt-args)))
+ (let ((yes ) ; '("menubar" "cd"))
+ (no '()))
+ (declare (ignorable yes no))
+ (when (find-if (lambda (s) (search s tk$)) yes)
+ (format t "~&tk> ~a~%" tk$)))
+ (assert *tki*)
+ (setf *tk-last* tk$)
+ (when *tk-log*
+ (princ tk$ *tk-log*)
+ (terpri *tk-log*)
+ (force-output *tk-log*))
+ (when *tk-fmt* (print `(:tkfmt ,tk$)))
+ (let ((rtn (tcl-eval-ex *tki* tk$)))
+ (unless (zerop rtn)
+ (trc "tkfmt ERROR!!!" rtn :on (apply 'format nil fmt$ fmt-args)))
+ rtn))))
+
+(export! alert-ok alert-ok-ex)
+
+(defun alert-ok-ex (wtitle s &optional (ok$ (without-repeating :alok '("Ok" "Cool" "Gotcha" "Super" "Word") )))
+ (tk-format-now (conc$ (format nil "tk_dialog .oops {~a} {" wtitle)
+ s (format nil "} {} {~a} {~:*~a}" ok$))))
+
+(defun alert-ok (s &optional (ok$ (without-repeating :alok '("Ok" "Cool" "Gotcha" "Super" "Word") )))
+ (tk-format-now (conc$ "tk_dialog .oops {<cough>} {"
+ s (format nil "} {} {~a} {~:*~a}" ok$))))
+
+(defun tk-format (defer-info fmt$ &rest fmt-args)
+ "Format then send to wish (via user queue)"
+ (assert (or (eq defer-info :grouped)
+ (consp defer-info)) () "need defer-info to sort command ~a. Specify :grouped if caller is managing user-queue"
+ (apply 'format nil fmt$ fmt-args))
+
+ (when (eq defer-info :grouped)
+ (setf defer-info nil))
+ (flet ((do-it ()
+ (apply 'tk-format-now fmt$ fmt-args)))
+ (if defer-info
+ (with-integrity (:client defer-info)
+ (do-it))
+ (do-it))))
+
+(defmethod tk-send-value ((s string))
+ #+whoa (if nil #+not (find #\\ s) ;; welllll, we cannot send: -text "[" to Tk because t misinterprets it, so we have to send the octal
+ ; which begins with \. There is probably a better way ///
+ (format nil "\"~a\"" s) ;; no good if \ is in file path as opposed to escaping
+ (format nil "~s" s) ; this fails where I want to send a /Tk/ escape sequence "\065"
+ ; because the ~s directive adds its own escaping
+ ;;(format nil "{~a}" s) ;this fails, too, not sure why
+ )
+ (if (find #\space s)
+ (format nil "{~a}" s)
+ (format nil "~s" s)))
+
+(defmethod tk-send-value ((c character))
+ ;
+ ; all this just to display "[". Unsolved is how we will
+ ; send a text label with a string /containing/ the character #\[
+ ;
+ (trc nil "tk-send-value" c (char-code c) (format nil "\"\\~3,'0o\"" (char-code c)))
+ (format nil "\"\\~3,'0o\"" (char-code c)))
+
+(defmethod tk-send-value (other)
+ (format nil "~a" other))
+
+(defmethod tk-send-value ((s symbol))
+ (down$ s))
+
+(defmethod tk-send-value ((p package))
+ (package-name p))
+
+(defmethod tk-send-value ((values list))
+ (format nil "{~{~a~^ ~}}" (mapcar 'tk-send-value values)))
+
+(defmethod parent-path ((nada null)) "")
+(defmethod parent-path ((other t)) "")
+
+
+; --- tk eval ----------------------------------------------------
+
+(defmethod path-index (self) (path self))
+
+(defun tk-eval (tk-form$ &rest fmt-args
+ &aux (tk$ (apply 'format nil tk-form$ fmt-args)))
+ (assert *tki* () "Global *tki* is not bound to anything, let alone a Tcl interpreter")
+ (tk-format :grouped tk$)
+ (tcl-get-string-result *tki*)
+ )
+
+(defun tk-eval-var (var)
+ (tk-eval "set ~a" var))
+
+(defun tk-eval-list (tk-form$ &rest fmt-args)
+ (tk-format :grouped (apply 'format nil tk-form$ fmt-args))
+ (parse-tcl-list-result (tcl-get-string-result *tki*)))
+
+#+test
+(parse-tcl-list-result "-ascent 58 -descent 15 -linespace 73 -fixed 0")
+
+(defun parse-tcl-list-result (result &aux item items)
+ (when (plusp (length result))
+ (trc nil "parse-tcl-list-result" result)
+ (labels ((is-spaces (s)
+ (every (lambda (c) (eql c #\space)) s))
+ (gather-item ()
+ (unless (is-spaces item)
+ ;(trc "item chars" (reverse item))
+ ;(trc "item string" (coerce (reverse item) 'string))
+ (push (coerce (nreverse item) 'string) items)
+ (setf item nil))))
+ (loop with inside-braces
+ for ch across result
+ if (eql ch #\{)
+ do (if inside-braces
+ (break "whoa, nested braces: ~a" result)
+ (setf inside-braces t))
+ else if (eql ch #\})
+ do (setf inside-braces nil)
+ (gather-item)
+ (setf item nil)
+ else if (eql ch #\space)
+ if inside-braces do (push ch item)
+ else do (gather-item)
+ (setf item nil)
+ else do (push ch item)
+ finally (gather-item)
+ (return (nreverse items))))))
+
+
+
+
+
+
+
109 celtk.lpr
@@ -0,0 +1,109 @@
+;; -*- lisp-version: "8.2 [64-bit Linux (x86-64)] (Mar 3, 2010 14:34)"; cg: "1.134"; -*-
+
+(in-package :cg-user)
+
+(defpackage :celtk)
+
+(define-project :name :celtk
+ :modules (list (make-instance 'module :name "asdf-projects.lisp")
+ (make-instance 'module :name "celtk.lisp")
+ (make-instance 'module :name "tk-structs.lisp")
+ (make-instance 'module :name "tk-interp.lisp")
+ (make-instance 'module :name "tk-events.lisp")
+ (make-instance 'module :name "tk-object.lisp")
+ (make-instance 'module :name "widget.lisp")
+ (make-instance 'module :name "layout.lisp")
+ (make-instance 'module :name "font.lisp")
+ (make-instance 'module :name "timer.lisp")
+ (make-instance 'module :name "menu.lisp")
+ (make-instance 'module :name "label.lisp")