Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv8311
Modified Files: CELTK.lpr CelloTk.lpr Celtk.lisp composites.lisp demos.lisp lotsa-widgets.lisp run.lisp tk-object.lisp tk-structs.lisp Added Files: notebook.lisp Log Message: Notebook.lisp from Andy and random other recent work
--- /project/cells/cvsroot/Celtk/CELTK.lpr 2008/03/23 23:47:42 1.25 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2008/06/16 12:35:52 1.26 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Mar 4, 2008 15:30)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Jun 3, 2008 13:12)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
@@ -33,7 +33,8 @@ (make-instance 'module :name "ltktest-ci.lisp") (make-instance 'module :name "lotsa-widgets.lisp") (make-instance 'module :name "demos.lisp") - (make-instance 'module :name "andy-expander.lisp")) + (make-instance 'module :name "andy-expander.lisp") + (make-instance 'module :name "notebook.lisp")) :projects (list (make-instance 'project-module :name "..\cells\cells") (make-instance 'project-module :name --- /project/cells/cvsroot/Celtk/CelloTk.lpr 2008/01/03 20:23:30 1.3 +++ /project/cells/cvsroot/Celtk/CelloTk.lpr 2008/06/16 12:35:55 1.4 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 11, 2007 7:25)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.1 [Windows] (Apr 15, 2008 21:33)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
@@ -33,68 +33,76 @@ :main-form nil :compilation-unit t :verbose nil - :runtime-modules '(: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) + :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 '(:top-level :debugger) - :build-flags '(:allow-runtime-debug :purify) + :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 '(:read-init-files nil) + :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-initialization 'celtk::test :on-restart 'do-default-restart)
;; End of Project Definition --- /project/cells/cvsroot/Celtk/Celtk.lisp 2008/01/03 20:23:30 1.42 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2008/06/16 12:35:55 1.43 @@ -16,10 +16,11 @@
|#
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.42 2008/01/03 20:23:30 ktilton Exp $ +;;; $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) --- /project/cells/cvsroot/Celtk/composites.lisp 2008/04/11 09:23:51 1.28 +++ /project/cells/cvsroot/Celtk/composites.lisp 2008/06/16 12:35:56 1.29 @@ -148,6 +148,7 @@ Actually holds last event code, :focusin or :focusout") on-key-down on-key-up + (post-event-do nil :cell nil) ;; such as pop up alert for user (show-tool-tips? (c-in t)) :width (c?n 800) :height (c?n 600)) @@ -201,6 +202,8 @@ (setf (keyboard-modifiers .tkw) (delete mod (keyboard-modifiers .tkw))))))
+ + ;;; Helper function that actually executes decoration change (defun %%do-decoration (widget decoration) (let ((path (path widget))) --- /project/cells/cvsroot/Celtk/demos.lisp 2007/01/29 06:48:41 1.27 +++ /project/cells/cvsroot/Celtk/demos.lisp 2008/06/16 12:35:56 1.28 @@ -87,7 +87,7 @@ (make-instance 'entry :id :entree :fm-parent *parent* - :value (c-in "Boots"))))))))) + :value (c-in "kenzo")))))))))
(defun one-deep-menubar () (mk-menubar --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2008/01/03 20:23:30 1.11 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2008/06/16 12:35:56 1.12 @@ -37,7 +37,7 @@ (mk-label :text "aaa" :image-files (list (list 'kt (data-pathname "kt69" "gif"))) :height 400 - :width 300 + :width 200 :image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt)))
(assorted-canvas-items) --- /project/cells/cvsroot/Celtk/run.lisp 2008/04/11 09:23:51 1.29 +++ /project/cells/cvsroot/Celtk/run.lisp 2008/06/16 12:35:56 1.30 @@ -29,11 +29,15 @@ (defun run-window (root-class &optional (resetp t) &rest window-initargs) (assert (symbolp root-class)) (setf *tkw* nil) + (when resetp (cells-reset 'tk-user-queue-handler)) (tk-interp-init-ensure)
(setf *tki* (Tcl_CreateInterp)) + ;(break "ok?") + ;(deep) + ;; not recommended by Tcl doc (tcl-do-when-idle (get-callback 'tcl-idle-proc) 42) (tk-app-init *tki*) (tk-togl-init *tki*) @@ -53,25 +57,28 @@
(tcl-create-command *tki* "do-key-down" (get-callback 'do-on-key-down) (null-pointer) (null-pointer)) (tcl-create-command *tki* "do-key-up" (get-callback 'do-on-key-up) (null-pointer) (null-pointer)) - + (tcl-create-command *tki* "do-double-click-1" (get-callback 'do-on-double-click-1) (null-pointer) (null-pointer)) + (trc "integ" cells::*within-integrity*) + (with-integrity () ;; w/i somehow ensures tkwin slot gets populated (setf *app* (make-instance 'application :kids (c? (the-kids (setf *tkw* (apply 'make-instance root-class :fm-parent *parent* - window-initargs)))) - ))) + window-initargs)))))))
(assert (tkwin *tkw*))
(tk-format `(:fini) "wm deiconify .") - (tk-format-now "bind . <Escape> {destroy .}") + #-its-alive! (tk-format-now "bind . <Escape> {destroy .}") ; ; see above for why we are converting key x-events to application key virtual events: ; (tk-format-now "bind . <KeyPress> {do-key-down %W %K}") (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}") + (tk-format-now "bind . <Double-ButtonPress-1> {do-double-click-1 %W %K; break}") + (block nil (bwhen (ifn (start-up-fn *tkw*)) (funcall ifn *tkw*)) @@ -152,6 +159,9 @@ (otherwise (give-to-window))))) (otherwise (give-to-window))) + (bwhen (do (post-event-do self)) + (setf (post-event-do self) nil) + (funcall do self)) 0)))
;; Our own event loop ! - Use this if it is desirable to do something @@ -220,4 +230,5 @@ ; (defcommand key-down) (defcommand key-up) +(defcommand double-click-1)
--- /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/23 23:47:42 1.16 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2008/06/16 12:35:56 1.17 @@ -31,7 +31,9 @@ :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) + (on-double-click-1 :initarg :on-double-click-1 :accessor on-double-click-1 :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"))
--- /project/cells/cvsroot/Celtk/tk-structs.lisp 2008/01/03 20:23:30 1.7 +++ /project/cells/cvsroot/Celtk/tk-structs.lisp 2008/06/16 12:35:56 1.8 @@ -162,6 +162,8 @@
(defun xbe-x (xbe) (xbe x xbe)) (defun xbe-y (xbe) (xbe y xbe)) +(defun xbe-button (xbe) (xbe button xbe)) +(export! xbe-x xbe-y xbe-button xbe)
;; --------------------------------------------
--- /project/cells/cvsroot/Celtk/notebook.lisp 2008/06/16 12:35:56 NONE +++ /project/cells/cvsroot/Celtk/notebook.lisp 2008/06/16 12:35:56 1.1 (in-package :celtk)
;--- n o t e b o o k ----------------------------------------------
#+test (test-nb)
(deftk notebook (widget decoration-mixin) () (:tk-spec notebook -height -padding -width) (:default-initargs :id (gentemp "NB") :packing nil))
(defmethod make-tk-instance ((self notebook)) (tk-format `(:make-tk ,self) "ttk::notebook ~a" (^path)) (tk-format `(:pack ,self) "pack ~a -expand yes -fill both" (^path)))
(defobserver .kids ((self notebook)) (loop for k in (^kids) do (trc "ttk::notebook adds" k (type-of k) (md-name k) (path k)) (tk-format `(:post-make-tk ,self) "~a add ~a -text ~a" (^path) (path k) (text k))))
;--- t a b -----------------------------------------------------------
(deftk tab (frame-stack widget) () (:tk-spec tab -state -sticky -padding -text -image) (:default-initargs :id (gentemp "TB")))
(defmacro mk-tab ((&rest inits) &body body) `(make-instance 'tab :fm-parent *parent* ,@inits :kids (c? (the-kids ,@body))))
(defmethod make-tk-instance ((self tab)) (tk-format `(:make-tk ,self) "frame ~a" (^path)))
;--- example usage ---------------------------------------------------
(defmd nb-test (window) (kids (c? (the-kids (mk-notebook :width 100 :kids (c? (the-kids (mk-tab (:text "first") (mk-stack ("tab with container") (mk-label :text "hi"))) (mk-tab (:text "second") (mk-label :text "a") (mk-label :text "b")))))))))
(defun test-nb () (test-window 'nb-test))
-
ktilton