From ktilton at common-lisp.net Thu Mar 16 05:07:44 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 16 Mar 2006 00:07:44 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060316050744.660723A00E@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv21247 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import From ktilton at common-lisp.net Thu Mar 16 05:15:15 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 16 Mar 2006 00:15:15 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060316051515.252C67E02C@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv22087 Added Files: CELTK.lpr Celtk.asd Celtk.lisp canvas.lisp composites.lisp demos.lisp kt69.gif load.lisp ltk-kt.lisp menu.lisp textual.lisp tk-format.lisp widgets.lisp Log Message: Initial release of a portable Common Lisp GUI, with Cells and LTk Inside --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/16 05:15:14 NONE +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/16 05:15:14 1.1 ;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :CELTK) (define-project :name :celtk :modules (list (make-instance 'module :name "ltk-kt.lisp") (make-instance 'module :name "notes.lisp") (make-instance 'module :name "Celtk.lisp") (make-instance 'module :name "tk-format.lisp") (make-instance 'module :name "menu.lisp") (make-instance 'module :name "composites.lisp") (make-instance 'module :name "textual.lisp") (make-instance 'module :name "widgets.lisp") (make-instance 'module :name "canvas.lisp") (make-instance 'module :name "demos.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :celtk :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) :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) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+M +t \"Console for Debugging\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'celtk::tk-test :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/16 05:15:14 NONE +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/16 05:15:14 1.1 ;;;; -*- 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 " :version "2.0" :maintainer "Kenny Tilton " :licence "MIT Style" :description "Tk via LTk with Cells Inside(tm)" :long-description "A Cells-driven portable GUI built atop the LTk core, ultimately implmented by Tk" :depends-on (:cells) :serial t :components ((:file "ltk-kt") (:file "Celtk") (:file "tk-format") (:file "menu") (:file "composites") (:file "textual") (:file "widgets") (:file "canvas") (:file "demos"))) --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/16 05:15:14 NONE +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/16 05:15:14 1.1 #| Celtic / widget.lisp : Foundation classes Copyright (c) 2004 by Kenneth William Tilton A work derived from Peter Herth's LTk. As a derived work, usage is governed by LTk's "Lisp LGPL" licensing: You have the right to distribute and use this software as governed by the terms of the Lisp Lesser GNU Public License (LLGPL): (http://opensource.franz.com/preamble.html) This program is distributed in the hope that it will be useful, but 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. |# (defpackage :celtk (:nicknames "CTK") (:use :common-lisp :utils-kt :cells) (:import-from #:ltk #:wish-stream #:*wish* #:*ewish* "*DEBUG-TK*" #:peek-char-no-hang #:read-data #:send-wish #:tkescape #:with-ltk #:do-execute #:add-callback) (:export #:window #:panedwindow #:mk-row #:pack-self #:mk-stack #:mk-text-widget #:mk-panedwindow #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label #:selection #:selector #:mk-checkbutton #:mk-button #:mk-button-ex #:mk-entry #:frame-stack #:mk-frame-stack #:pack-layout? #:path #:mk-menu-entry-radiobutton #:mk-menu-entry-checkbutton #:mk-menu-radio-group #:mk-menu-entry-separator #:mk-menu-entry-command #:tk-callback #:mk-menu #:mk-menu-entry-cascade #:mk-menubar #:^entry-values #:tk-eval-list #:mk-scale #:mk-popup-menubutton #:mk-polygon #:mk-oval #:mk-line #:mk-arc #:mk-text-item #:mk-rectangle #:mk-bitmap #:mk-canvas #:mk-frame-row #:mk-scrolled-list #:listbox-item #:mk-spinbox #:with-ltk #:tk-format #:send-wish #:value #:.tkw #:tk-user-queue-handler)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) (in-package :Celtk) (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))) (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) (define-symbol-macro .tkw (nearest self window)) ;;; --- widget ----------------------------------------- (defmodel widget (family tk-object) ((path :accessor path :initarg :path :initform (c? (trc nil "path calc" self (parent-path (fm-parent self)) (md-name self)) (format nil "~(~a.~a~)" (parent-path (fm-parent self)) (md-name self)))) (layout :reader layout :initarg :layout :initform nil) (enabled :reader enabled :initarg :enabled :initform t) (bindings :reader bindings :initarg :bindings :initform nil) (image-files :reader image-files :initarg :image-files :initform nil) (selector :reader selector :initarg :selector :initform (c? (upper self selector)))) (:default-initargs :id (gentemp "W"))) (defmethod make-tk-instance ((self widget)) (setf (gethash (^path) (dictionary .tkw)) self) (when (tk-class self) (tk-format `(:make-tk ,self) "~(~a~) ~a ~{~(~a~) ~a~^ ~}" (tk-class self) (path self)(tk-configurations self)) :stdfctry)) ;;;(defmethod md-awaken :before ((self widget)) ;;; (loop for (name file-pathname) in (^image-files) ;;; do (tk-format "image create photo ~(~a.~a~) -file ~a" ;;; (^path) name (tkescape (namestring file-pathname))))) (defobserver image-files () ; ; I do not know how to create the photo for X before X exists ; though it seems to work. perhaps Tk understands it does not need to ; place the image in a tree and lets the undefined path go? If so, ; just add :pre-make-kt before :make-kt in the sort list ; (loop for (name file-pathname) in (set-difference new-value old-value :key 'car) do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file ~a" (^path) name (tkescape (namestring file-pathname))))) (defobserver bindings () ;;; (w widget) event fun) (loop for (event fmt fn) in new-value for name = (gentemp "BNDG") do (tk-format `(:bind ,self) "bind ~a ~a ~a" ;; {puts {:callback ~a}}" (^path) event (format nil fmt (register-callback self name fn))))) (defobserver layout ((self widget)) (when new-value (assert (null (kids-layout .parent)) () "Do not specify layout (here for ~a) unless parent leaves kids-layout unspecified. This parent is ~a, kids-layout ~a" self (list .parent (type-of .parent)) (kids-layout .parent))) ; ; This use next of the parent instead of self is pretty tricky. It has to do with getting ; the pack commands out nested widgets before parents. The pack command issued on behalf ; of a top frame is sorted on the parent. Now we have to pack the top frame. If we associate ; the command with the frame, the sort is a tie and either might go first. So we continue ; the theme and associate /this/ pack with this top frame's parent. Note that we cannot go the ; normal route and pack the kids in their own context, because multiple kids get packed ; in one pack statement (and we cannot arbitrarily pack with the first kid because this is a nested ; deal and any kid might have kids, so each family packs associated with itself) ; (when (and new-value (not (typep .parent 'panedwindow))) (tk-format `(:pack ,(fm-parent self)) new-value))) (defun pack-self () (c? (format nil "pack ~a" (path self)))) (defmethod tk-configure ((self widget) option value) (tk-format `(:configure ,self ,option) "~A configure ~(~a~) ~a" (path self) option (tk-send-value value))) (defmethod not-to-be :after ((self widget)) (trc nil "not-to-be tk-forgetting true widget" self) (tk-format `(:forget ,self) "pack forget ~a" (^path)) (tk-format `(:destroy ,self) "destroy ~a" (^path))) ;;; --- items ----------------------------------------------------------------------- (defmodel item (tk-object) ((id-no :cell nil :initarg :id-no :accessor id-no :initform nil) (coords :initarg :coords :initform nil)) (:documentation "not full blown widgets, but decorations thereof") (:default-initargs :id (gentemp "I"))) (defmethod make-tk-instance ((self item)) (when (tk-class self) (with-integrity (:client `(:make-tk ,self)) (tk-format :grouped "senddata [~a create ~a ~{ ~a~} ~{~(~a~) ~a~^ ~}]" (path .parent) (down$ (tk-class self)) (coords self) (tk-configurations self)) (setf (id-no self) (read-data))))) (defmethod tk-configure ((self item) option value) (assert (id-no self) () "cannot configure item ~a until instantiated and id obtained" self) (tk-format `(:itemconfigure ,self ,option) "~A itemconfigure ~a ~a {~a}" (path .parent) (id-no self) (down$ option) value)) (defobserver coords () (when (and (id-no self) new-value) (tk-format `(:coords ,self) "~a coords ~a ~{ ~a~}" (path .parent) (id-no self) new-value))) (defmethod not-to-be :after ((self item)) (trc nil "whacking item" self) (tk-format `(:delete ,self) "~a delete ~a" (path (upper self widget)) (id-no self))) (defparameter *tk-changers* nil) ;;; --- 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)) (multiple-value-bind (slots outputs) (loop for (slot-name tk-option) in tk-options collecting `(,slot-name :initform nil :initarg ,(intern (string slot-name) :keyword) :accessor ,slot-name) into slot-defs when tk-option collecting `(defobserver ,slot-name ((self ,class)) (when (and new-value old-value-boundp) (tk-configure self ,(string tk-option) new-value))) into outputs finally (return (values slot-defs outputs))) `(progn (defmodel ,class ,(or superclasses '(widget)) (,@(append std-slots slots)) ,@(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) (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) `(make-instance ',',class :fm-parent *parent* , at inits)) , at outputs)))) (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-when (compile load eval) (defun de- (sym) (remove #\- (symbol-name sym) :end 1))) (defgeneric tk-class-options (self) (:method-combination append)) (defun tk-configurations (self) (loop for (slot-name tk-option) in (remove-duplicates (tk-class-options self) :key 'second) for slot-value = (funcall slot-name self) ;; must go thru accessor with Cells, cannot (slot-value self slot-name) when (and tk-option slot-value) nconcing (list tk-option (tk-send-value slot-value)))) ; --- callbacks ---------------------------------------------------- (defun tk-callback (self id-suffix fn &optional command) (declare (ignorable command)) (let ((id (register-callback self id-suffix fn))) (trc nil "tk-callback" self id command) (list 'callback id))) (defun tk-callbackstring (self id-suffix tk-token fn) (format nil "callbackstring ~s ~a; return 1;" (register-callback self id-suffix fn) (string tk-token))) (defun tk-callbackstring-x (self id-suffix tk-token fn) (format nil "callbackstring ~s ~a" (register-callback self id-suffix fn) (string tk-token))) (defun tk-callbackval (self id-suffix fn &optional command) (declare (ignorable command)) (format nil (or command "callbackval ~s") (register-callback self id-suffix fn))) (defun register-callback (self callback-id fun) (assert callback-id) (let ((id (format nil "~a.~a" (path-index self) callback-id))) ;; (trc "registering callback" self :id (type-of id) id) (add-callback id fun) id)) (defmethod path-index (self) (^path)) (defun tk-eval-var (var) (tk-format :grouped "senddatastring [set ~a]" var) (read-data)) (defun tk-eval-list (self form$) (declare (ignore self)) (tk-format :grouped "senddatastrings [~a]" form$) (read-data)) ;--- selector --------------------------------------------------- (defmodel selector () ;; mixin ((selection :initform nil :accessor selection :initarg :selection) (tk-variable :initform nil :accessor tk-variable :initarg :tk-variable :documentation "The TK node name to set as the selection changes (not the TK -variable option)")) (:default-initargs :selection (c-in nil) :tk-variable (c? (^path)))) (defobserver selection () ; ; handling varies on this, so we hand off to standard GF lest the PROGN ; method combo on slot-listener cause multiple handling ; (tk-output-selection self new-value old-value old-value-boundp)) [9 lines skipped] --- /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/16 05:15:15 1.1 [215 lines skipped] --- /project/cells/cvsroot/Celtk/composites.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/03/16 05:15:15 1.1 [385 lines skipped] --- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/16 05:15:15 1.1 [723 lines skipped] --- /project/cells/cvsroot/Celtk/kt69.gif 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/kt69.gif 2006/03/16 05:15:15 1.1 [1066 lines skipped] --- /project/cells/cvsroot/Celtk/load.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/load.lisp 2006/03/16 05:15:15 1.1 [1082 lines skipped] --- /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/16 05:15:15 1.1 [4453 lines skipped] --- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/16 05:15:15 1.1 [4715 lines skipped] --- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/16 05:15:15 1.1 [4834 lines skipped] --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/16 05:15:15 1.1 [4956 lines skipped] --- /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/16 05:15:15 1.1 [5206 lines skipped] From ktilton at common-lisp.net Thu Mar 16 05:24:41 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 16 Mar 2006 00:24:41 -0500 (EST) Subject: [cells-cvs] CVS cells/doc Message-ID: <20060316052441.46D477C00C@common-lisp.net> Update of /project/cells/cvsroot/cells/doc In directory clnet:/tmp/cvs-serv23131/doc Modified Files: 01-Cell-basics.lisp Added Files: motor-control.lisp Log Message: Cells 3 revision to 01-Cell-basics.lisp, and Bill Clementson's motor-control.lisp / Blog entry --- /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2005/05/06 21:05:55 1.1 +++ /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2006/03/16 05:24:41 1.2 @@ -1,16 +1,8 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cellsS -*- +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells -*- ;;; ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. +;;; All rights reserved. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, @@ -25,18 +17,7 @@ #| -here is a minimal primer on cells, just enough for you to -keep up with the next tutorial. that will be a substantial project -in which we develop a clos object inspector. - -the inspector project will give you a feel for what it is like to -program with cells and cello /after/ you are fluent in the -technology. the intent is not to teach you cello, rather to -motivate your learning it. - -so why the primer on cells? if things like c? and cv and def-c-output -do not mean anything to you, the hunh? factor will be overwhelming. - +[A minimal primer on cells, last tested on march 13, 2006 against cells3] cells ----- @@ -130,6 +111,9 @@ (in-package :cells) +(cells-reset) + + (defmodel stone () ((accel :cell t :initarg :accel :initform 0 :accessor accel) (time-elapsed :cell t :initarg :time-elapsed @@ -141,14 +125,14 @@ (expt (time-elapsed self) 2)) 2)))) -(def-c-output accel ((self stone) new old old-bound-p) - (trc "echo accel" :new new :old old :oldp old-bound-p)) ;; TRC provides print diagnostics +(defobserver accel ((self stone) new old old-bound-p) + (trc "observer sees accel" :new new :old old :oldp old-bound-p)) ;; TRC provides print diagnostics -(def-c-output time-elapsed ((self stone)) ;; short form (I'm lazy) - (trc "echo time-elapsed" :new new-value :old old-value :oldp old-value-boundp)) +(defobserver time-elapsed ((self stone)) ;; short form (I'm lazy) + (trc "observer sees time-elapsed" :new new-value :old old-value :oldp old-value-boundp)) -(def-c-output distance ((self stone)) - (format t "~&echo distance fallen: ~d feet" new-value)) +(defobserver distance ((self stone)) + (format t "~&observer sees distance fallen: ~d feet" new-value)) #| @@ -202,48 +186,30 @@ cell internals enforce this, simply to make possible the optimization of leaving off the overhead of recording a pointless dependency. -next: (def-c-output... +next: (defobserver... -here is the signature for the def-c-output macro: +here is the signature for the defobserver macro: - (defmacro def-c-output (slotname (&optional (self-arg 'self) + (defmacro defobserver (slotname (&optional (self-arg 'self) (new-varg 'new-value) (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) - &body echo-body) ....) + &body observer-body) ....) -def-c-output defines a generic method one can specialize on any of the four +defobserver defines a generic method with method-combination progn, +which one can specialize on any of the four parameters. the method gets called when the slot value changes, and during -initial processing by: +initial processing by shared-initialize (part of make-instance). - (to-be....) - -to-be brings a new model instance to life, including calling -any echos defined for cellular slots. - -why not just do this in initialize-instance? we build complex -models in the form of a tree of many model instances, any of -which may depend on some other model instance to calculate -some part of its state. models find the one they are curious -about by searching the tree. - -this means we cannot just bring a model instance to life at -make-instance time; some cell rule may go looking for another -model instance. we must wait until the instance is -embedded in the larger model tree, then we can kick off to-be. - -likewise, when we yank an instance from the larger model we -will call not-to-be on it. - -the good news is that unless i am doing little tutorial examples -i never think about calling to-be. trees are implemented in part -by a "kids" (short for "children") cell. the echo on that cell -calls to-be on new kids and not-to-be on kids no longer in the list. +shared-initialize brings a new model instance to life, including calling +any observers defined for cellular slots. now evaluate the following: |# +#+evaluatethis + (defparameter *s2* (make-instance 'stone :accel 32 ;; (constant) feet per second per second :time-elapsed (c-in 0))) @@ -251,16 +217,15 @@ #| ...and observe: -0> echo accel :new 32 :old nil :oldp nil -0> echo time-elapsed :new 0 :old nil :oldp nil -echo distance fallen: 0 feet +0> observer sees accel :new 32 :old nil :oldp nil +0> observer sees time-elapsed :new 0 :old nil :oldp nil +observer sees distance fallen: 0 feet -getting back to the output shown above, why echo output on a new instance? - -when we call to-be we want the instance to come to life. that means +getting back to the output shown above, why observer output on a new instance? we want +any new instance to come fully to life. that means evaluating every rule so the dependencies get established, and -propagating cell values outside the model (by calling the echo +propagating cell values outside the model (by calling the observer methods) to make sure the model and outside world (if only the system display) are consistent. @@ -269,16 +234,18 @@ |# +#+evaluatethis + (setf (time-elapsed *s2*) 1) #| ...and observe: -0> echo time-elapsed :new 1 :old 0 :oldp t -echo distance fallen: 16 feet +0> observer sees time-elapsed :new 1 :old 0 :oldp t +observer sees distance fallen: 16 feet behind the scenes: - the slot value time-elapsed got changed from 0 to 1 -- the time-elapsed echo was called +- the time-elapsed observer was called - dependents on time-elapsed (here just distance) were recalculated - go to the first step, this time for the distance slot @@ -287,7 +254,9 @@ the same value it already has: |# -(setf (time-elapsed *s2*) 1) +#+evaluatethis + +(setf (time-elapsed *s2*) 1) #| observe: nothing, since the slot-value did not in fact change. @@ -297,30 +266,42 @@ modifying cells holding naked values: |# -(handler-case - (setf (accel *s2*) 10) - (t (error) (trc "error is" error) - error)) +#+evaluatethis + +(let ((*c-debug* t)) + (handler-case + (setf (accel *s2*) 10) + (t (error) + (cells-reset) ;; clear a *stop* flag used to bring down a runaway model :) + (trc "error is" error) + error))) #| observe: c-setting-debug > constant accel in stone may not be altered..init to (c-in nil) 0> error is # +Without turning on *c-debug* one just gets the runtime error, not the explanation to standard output. + ;----------------------------------------------------------- nor may ruled cells be modified arbitrarily: |# -(handler-case +#+evaluatethis + +(let ((*c-debug* t)) + (handler-case (setf (distance *s2*) 42) - (t (error) (trc "error is" error) - error)) + (t (error) + (cells-reset) + (trc "error is" error) + error))) #| observe: c-setting-debug > ruled distance in stone may not be setf'ed 0> error is # ;----------------------------------------------------------- -aside from c?, cv, and def-c-output, another thing you will see +aside from c?, cv, and defobserver, another thing you will see in cello code is how complex views are constructed using the family class and its slot kids. every model-object has a parent slot, which gets used along with a family's kids slot to @@ -337,10 +318,10 @@ silly examples. all i want to get across is that a lot happens when one changes the kids slot. it happens automatically, and it happens transparently, following the dataflow implicit in the -rules we write, and the side-effects we specify via echo functions. +rules we write, and the side-effects we specify via observer functions. the silly example below just shows the summer (that which sums) getting -a new md-value as the kids change, along with some echo output. in real-world +a new md-value as the kids change, along with some observer output. in real-world applications, where kids represent gui elements often dependent on each other, vastly more can transpire before a simple push into a kids slot has run its course. @@ -356,16 +337,18 @@ :initial-value 0 :key #'md-value)))) -(def-c-output .md-value ((self summer)) +(defobserver md-value ((self summer)) (trc "the sum of the values of the kids is" new-value)) -(def-c-output .kids ((self summer)) +(defobserver .kids ((self summer)) (trc "the values of the kids are" (mapcar #'md-value new-value))) ;----------------------------------------------------------- ; now just evaluate each of the following forms one by one, ; checking results after each to see what is going on ; +#+evaluatethis + (defparameter *f1* (make-instance 'summer)) #| @@ -375,7 +358,11 @@ ;----------------------------------------------------------|# -(push (make-instance 'model :md-value 1) (kids *f1*)) +#+evaluatethis + +(push (make-instance 'model + :fm-parent *f1* + :md-value 1) (kids *f1*)) #| observe: 0> the values of the kids are (1) @@ -383,7 +370,11 @@ ;----------------------------------------------------------|# -(push (make-instance 'model :md-value 2) (kids *f1*)) +#+evaluatethis + +(push (make-instance 'model + :fm-parent *f1* + :md-value 2) (kids *f1*)) #| observe: 0> the values of the kids are (2 1) @@ -391,6 +382,8 @@ ;----------------------------------------------------------|# +#+evaluatethis + (setf (kids *f1*) nil) #| observe: @@ -403,6 +396,8 @@ |# +#+evaluatethis + (setq *s2* (make-instance 'stone :accel 2 :time-elapsed (c-in 3) --- /project/cells/cvsroot/cells/doc/motor-control.lisp 2006/03/16 05:24:41 NONE +++ /project/cells/cvsroot/cells/doc/motor-control.lisp 2006/03/16 05:24:41 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells -*- ;;; ;;; Copyright ? 2004 by Bill Clementson ;;; ;;; Reprinted, reformatted, and modestly revised by permission. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. #| Experimenting with Cells ---------------------------- Thursday, September 11, 2003 Kenny Tilton has been talking about his Cells implementation on comp.lang.lisp for some time but I've only just had a look at it over the past few evenings. It's actually pretty neat. Kenny describes Cells as, conceptually, analogous to a spreadsheet cell (e.g. -- something in which you can put a value or a formula and have it updated automatically based on changes in other "cell" values). Another way of saying this might be that Cells allows you to define classes whose slots can be dynamically (and automatically) updated and for which standard observers can be defined that react to changes in those slots. Hmmm, maybe an example works best. Here's one that's a variation on one of the examples included in the latest distribution. I'll create a "motor" object that reacts to changes in the motor's operating temperature. If the temperature exceeds 100 degrees, the motor will need to be shut off. If it is shut off, the flow from the fuel pump will also need to be closed (otherwise, we get a big pool of fuel on the floor). So, by using Cells in this example, the following will be demonstrated: * Create slots whose values vary based on a formula. The formula can be defined at either class definition time or at object instantiation time. * Dynamically (and automatically) update dependent slot variables (maintaining consistency between dependent class attributes). * Create Observers that react to changes in slot values to handle "external" actions (e.g. - GUI updates, external API calls, etc.). * Automatically filter slot changes so that we only update dependent slots when the right granularity of change occurs. First, define the motor class (Note: defmodel is a macro that wraps a class definition and several method definitions): |# (defmodel motor () ((status :initarg :status :accessor status :initform nil) (fuel-pump :initarg :fuel-pump :accessor fuel-pump :initform (c? (ecase (^status) (:on :open) (:off :closed)))) (temp :initarg :temp :accessor temp :initform (c-in 0)))) #| Note that "status" is a cell with no initial value or formula, "fuel-pump" is a cell that has a formula that depends on the value of "status" (the ^status notation is shorthand to refer to a slot in the same instance), and "temp" is initialized to zero. Next, define observers (this is an optional step) using a Cells macro. These observers act on a change in a slot's value. They don't actually update any dependent slots (this is done automatically by Cells and the programmer doesn't have to explicitly call the slot updates), they just provide a mechanism for the programmer to handle outside dependencies. In this example, we're just printing a message; however, in a real program, we would be calling out to something like an Allen Bradley controller to turn the motor and fuel pump on/off. |# (defobserver status ((self motor)) (trc "motor status changing from" old-value :to new-value)) (defobserver fuel-pump ((self motor)) (trc "motor fuel-pump changing from" old-value :to new-value)) (defobserver temp ((self motor)) (trc "motor temperature changing from" old-value :to new-value)) [67 lines skipped] From ktilton at common-lisp.net Thu Mar 16 05:26:47 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 16 Mar 2006 00:26:47 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20060316052647.DB89D46116@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv23261/utils-kt Modified Files: debug.lisp defpackage.lisp detritus.lisp strings.lisp utils-kt.lpr Log Message: Cells 3 support --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2005/09/26 15:36:05 1.5 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/03/16 05:26:47 1.6 @@ -55,7 +55,7 @@ (assert (stringp ,(car os))) (call-trc t , at os)) ;;,(car os) ,tgt ,@(cdr os))) (progn - (break "trcfailed") + ;; (break "trcfailed") (count-it :trcfailed))) (count-it :tgtnileval))))))) --- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2005/05/06 21:05:56 1.1 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/03/16 05:26:47 1.2 @@ -38,9 +38,11 @@ #:intern$ #:define-constant #:*count* #:*stop* #:*dbg* #:*trcdepth* - #:make-fifo-queue #:fifo-add #:fifo-empty #:fifo-pop #:mapfifo + #:make-fifo-queue #:fifo-queue #:fifo-add #:fifo-delete + #:fifo-empty #:fifo-pop #:fifo-clear + #:fifo-map #:fifo-peek #:fifo-data #:with-fifo-map #:fifo-length - #-mcl #:true + #-(or lispworks mcl) #:true #+clisp #:slot-definition-name #+(and mcl (not openmcl-partial-mop)) #:class-slots -)) + )) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2005/09/26 15:36:05 1.2 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/03/16 05:26:47 1.3 @@ -42,7 +42,7 @@ (copy-list (class-instance-slots c)))) -#-(or mcl) +#-(or lispworks mcl) (progn (defun true (it) (declare (ignore it)) t) (defun false (it) (declare (ignore it)))) @@ -50,7 +50,22 @@ (defun xor (c1 c2) (if c1 (not c2) c2)) -(defun make-fifo-queue () (cons nil nil)) +;;; --- FIFO Queue ----------------------------- + +(defun make-fifo-queue (&rest init-data) + (let ((q (cons nil nil))) + (prog1 q + (loop for id in init-data + do (fifo-add q id))))) + +(deftype fifo-queue () 'cons) + +(defun fifo-data (q) (car q)) +(defun fifo-clear (q) (rplaca q nil)) +(defun fifo-empty (q) (not (fifo-data q))) +(defun fifo-length (q) (length (fifo-data q))) +(defun fifo-peek (q) (car (fifo-data q))) + (defun fifo-add (q new) (if (car q) (let ((last (cdr q)) @@ -60,23 +75,37 @@ (let ((newlist (list new))) (rplaca q newlist) (rplacd q newlist)))) -(defun fifo-queue (q) (car q)) -(defun fifo-empty (q) (not (car q))) + +(defun fifo-delete (q dead) + (let ((c (member dead (fifo-data q)))) + (assert c) + (rplaca q (delete dead (fifo-data q))) + (when (eq c (cdr q)) + (rplacd q (last (fifo-data q)))))) + (defun fifo-pop (q) - (prog1 - (caar q) - (rplaca q (cdar q)))) + (unless (fifo-empty q) + (prog1 + (fifo-peek q) + (rplaca q (cdar q))))) -(defun mapfifo (fn q) +(defun fifo-map (q fn) (loop until (fifo-empty q) do (funcall fn (fifo-pop q)))) +(defmacro with-fifo-map ((pop-var q) &body body) + (let ((qc (gensym))) + `(loop with ,qc = ,q + while (not (fifo-empty ,qc)) + do (let ((,pop-var (fifo-pop ,qc))) + , at body)))) + #+(or) (let ((*print-circle* t)) (let ((q (make-fifo-queue))) (loop for n below 3 do (fifo-add q n)) - (fifo-queue q) + (fifo-delete q 1) (loop until (fifo-empty q) do (print (fifo-pop q))))) @@ -93,3 +122,39 @@ (symbol-value ',name) value))) ,@(when docstring (list docstring)))) + +#+allegro +(defun line-count (path &optional show-files (depth 0)) + (cond + ((excl:file-directory-p path) + (when show-files + (format t "~&~v,8t~a counts:" depth (pathname-directory path))) + (let ((directory-lines + (loop for file in (directory path :directories-are-files nil) + for lines = (line-count file show-files (1+ depth)) + when (and show-files (plusp lines)) + do (bwhen (fname (pathname-name file)) + (format t "~&~v,8t~a ~,40t~d" (1+ depth) fname lines)) + summing lines))) + (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines) + directory-lines)) + + ((find (pathname-type path) '("cl" "lisp" "c" "h" "java") + :test 'string-equal) + (source-line-count path)) + (t 0))) + +(defun source-line-count (path) + (with-open-file (s path) + (loop with lines = 0 + for c = (read-char s nil nil) + while c + when (find c '(#\newline #\return)) + do (incf lines) + finally (return lines)))) + +#+(or) +(line-count (make-pathname + :device "c" + :directory `(:absolute "0dev" "Algebra")) t) + --- /project/cells/cvsroot/cells/utils-kt/strings.lisp 2005/09/26 15:36:05 1.2 +++ /project/cells/cvsroot/cells/utils-kt/strings.lisp 2006/03/16 05:26:47 1.3 @@ -159,7 +159,7 @@ (down$ s)) (defun down$ (s) - (typecase s + (etypecase s (null "") (string (string-downcase s)) (number (format nil "~a" s)) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2005/09/26 15:05:43 1.4 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/03/16 05:26:47 1.5 @@ -1,9 +1,9 @@ -;; -*- lisp-version: "7.0 [Windows] (Sep 4, 2005 16:25)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :COMMON-LISP - (:export #:list + (:export #:list #:make-instance #:t #:nil @@ -12,9 +12,10 @@ (define-project :name :utils-kt :modules (list (make-instance 'module :name "defpackage.lisp") (make-instance 'module :name "debug.lisp") - (make-instance 'module :name "detritus.lisp") (make-instance 'module :name "flow-control.lisp") - (make-instance 'module :name "strings.lisp")) + (make-instance 'module :name "detritus.lisp") + (make-instance 'module :name "strings.lisp") + (make-instance 'module :name "datetime.lisp")) :projects nil :libraries nil :distributed-files nil From ktilton at common-lisp.net Sat Mar 18 00:14:01 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 17 Mar 2006 19:14:01 -0500 (EST) Subject: [cells-cvs] CVS cells/cells-test Message-ID: <20060318001401.6C47930000@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv31950/Cells-test Modified Files: cells-test.lpr Added Files: deep-cells.lisp Log Message: New deep-cells.lisp to demo Cells 3 --- /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2006/03/16 05:22:08 1.3 +++ /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2006/03/18 00:14:01 1.4 @@ -15,7 +15,8 @@ (make-instance 'module :name "output-setf.lisp") (make-instance 'module :name "test-cycle.lisp") (make-instance 'module :name "test-ephemeral.lisp") - (make-instance 'module :name "test-synapse.lisp")) + (make-instance 'module :name "test-synapse.lisp") + (make-instance 'module :name "deep-cells.lisp")) :projects (list (make-instance 'project-module :name "..\\cells")) :libraries nil :distributed-files nil --- /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2006/03/18 00:14:01 NONE +++ /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2006/03/18 00:14:01 1.1 (defvar *client-log*) (defvar *obs-1-count*) (defmodel deep () ((cell-2 :cell :ephemeral :initform (c-in 'two) :accessor :cell-2) (cell-1 :initform (c? (list 'one (^cell-2) (^cell-3))) :accessor :cell-1) (cell-3 :initform (c-in 'c3-unset) :accessor :cell-3))) (defobserver cell-1 () (trc "cell-1 observer raw now enqueing client to run first. (new,old)=" new-value old-value) (with-integrity (:client 1) (trc "cell-1 :client now running" new-value (incf *obs-1-count*)) (eko ("c1-obs->*client-log*: ") (setf *client-log* (list new-value))))) (defobserver cell-2 () (trc "cell-2 observer raw now enqueing change and client to run second. (new,old)=" new-value old-value) (with-integrity (:change) (trc "cell-2 observer :change now running" *client-log*) (ct-assert (equal *client-log* '((one two c3-unset) two c3-unset))) (setf (^cell-3) (case new-value (two 'three) (otherwise 'trouble)))) (with-integrity (:client 2) (trc "client cell-2 :client running") (eko ("c2-obs->*client-log*: ") (setf *client-log* (append *client-log* (list new-value)))))) (defobserver cell-3 () (trc "cell-3 observer raw now enqueing client to run third. (new,old)=" new-value old-value) (with-integrity (:client 3) (trc "cell-3 observer :client now running" new-value) (eko ("c3-obs->*client-log*: ") (setf *client-log* (append *client-log* (list new-value)))))) (defun deep-queue-handler (client-q) (loop for (nil . task) in (prog1 (sort (fifo-data client-q) '< :key 'car) (fifo-clear client-q)) do (trc nil "!!! --- deep-queue-handler dispatching" defer-info) (funcall task))) (def-cell-test go-deep () (cells-reset 'deep-queue-handler) (setf *obs-1-count* 0) (make-instance 'deep) (ct-assert (eql 2 *obs-1-count*)) ;; because the cell-2 observer does a setf on something used by c1 (trc "testing *client-log*" *client-log*) (ct-assert (tree-equal *client-log* '((one nil three) three)))) From ktilton at common-lisp.net Sat Mar 18 00:15:40 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 17 Mar 2006 19:15:40 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20060318001540.77ED230006@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv852 Modified Files: cells-test.asd cells.lpr initialize.lisp integrity.lisp model-object.lisp propagate.lisp Log Message: New doc and test (deep-cells) for Cells 3. One mod to avoid unnecessary :etll-dependents enqueue --- /project/cells/cvsroot/cells/cells-test.asd 2006/03/16 05:28:28 1.2 +++ /project/cells/cvsroot/cells/cells-test.asd 2006/03/18 00:15:40 1.3 @@ -20,7 +20,8 @@ (:file "output-setf") (:file "test-cycle") (:file "test-ephemeral") - (:file "test-synapse"))))) + (:file "test-synapse") + (:file "deep-cells"))))) (defmethod perform :after ((op load-op) (system (eql (find-system :cells-test)))) (funcall (find-symbol "TEST-CELLS" "CELLS"))) --- /project/cells/cvsroot/cells/cells.lpr 2006/03/16 05:28:28 1.7 +++ /project/cells/cvsroot/cells/cells.lpr 2006/03/18 00:15:40 1.8 @@ -49,7 +49,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'cells::test-cells + :on-initialization 'cells::go-deep :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/cells/initialize.lisp 2006/03/16 05:28:28 1.2 +++ /project/cells/cvsroot/cells/initialize.lisp 2006/03/18 00:15:40 1.3 @@ -34,14 +34,14 @@ (defmethod c-awaken-cell ((c cell)) (assert (c-inputp c)) - (when (and (c-ephemeral-p c) + #+goforit(when (and (c-ephemeral-p c) (c-value c)) (c-break "Feature not yet supported: initializing ephemeral to other than nil: [~a]" (c-value c))) ; ; nothing to calculate, but every cellular slot should be output ; - (slot-change (c-slot-name c) (c-model c) (c-value c) nil nil) + (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil) (c-ephemeral-reset c)) (defmethod c-awaken-cell ((c c-ruled)) --- /project/cells/cvsroot/cells/integrity.lisp 2006/03/16 05:28:28 1.5 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/03/18 00:15:40 1.6 @@ -80,29 +80,69 @@ (tagbody tell-dependents (just-do-it :tell-dependents) - - (just-do-it :awaken) ;--- awaken new instances --- + ; + ; while the next step looks separate from the prior, they are closely bound. + ; during :tell-dependents, any number of new model instances can be spawned. + ; as they are spawned, shared-initialize queues them for awakening, which + ; you will recall forces the calculation of ruled cells and observer notification + ; for all cell slots. These latter may enqueue :change or :client tasks, in which + ; case note that they become appended to :change or :client tasks enqueued + ; during :tell-dependents. How come? Because the birth itself of model instances during + ; a datapulse is considered part of that datapulse, so we do want tasks enqueued + ; during their awakening to be handled along with those enqueued by cells of + ; existing model instances. + ; + (just-do-it :awaken) ;--- md-awaken new instances --- + ; + ; we do not go back to check for a need to :tell-dependents because (a) the original propagation + ; and processing of the :tell-dependents queue is a full propagation; no rule can ask for a cell that + ; then decides it needs to recompute and possibly propagate; and (b) the only rules forced awake during + ; awakening need that precisely because no one asked for their values, so their can be no dependents + ; to "tell". I think. :) So... + ; + (assert (null (fifo-peek (ufb-queue :tell-dependents)))) ;--- process client queue ------------------------------ ; (when *stop* (return-from finish-business)) - (trc (fifo-peek (ufb-queue :client)) "!!! finbiz --- USER --- length" (fifo-length (ufb-queue :client))) - + (bwhen (clientq (ufb-queue :client)) (if *client-queue-handler* - (funcall *client-queue-handler* clientq) ;; might be empty/not exist + (funcall *client-queue-handler* clientq) ;; might be empty/not exist, so handlers must check (just-do-it clientq))) ;--- now we can reset ephemerals -------------------- + ; + ; one might be wondering when the observers got notified. That happens + ; Nice historical note: by accident, in the deep-cells test to exercise the new behavior + ; of cells3, I coded an ephemeral cell and initialized it to non-nil, hitting a runtime + ; error (now gone) saying I had no idea what a non-nil ephemeral would mean. That had been + ; my conclusion when the idea occurred to me the first time, so I stuck in an assertion + ; to warn off users. + ; + ; But the new + ; datachange progression defined by Cells3 had already forced me to manage ephemeral resets + ; more predictably (something in the test suite failed). By the time I got the runtime + ; error on deep-cells I was able to confidently take out the error and just let the thing + ; run. deep-cells looks to behave just right, but maybe a tougher test will present a problem? + ; (just-do-it :ephemeral-reset) ;--- do deferred state changes ----------------------- ; - (bwhen (task-info (fifo-pop (ufb-queue :change))) ;; it would be odd, but nils can legally inhabit queues, so be safe... + (bwhen (task-info (fifo-pop (ufb-queue :change))) (trc nil "!!!!!!!!!!!!!!!!!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change))) (destructuring-bind (defer-info . task-fn) task-info (trc nil "finbiz: deferred state change" defer-info) (data-pulse-next (list :finbiz defer-info)) (funcall task-fn) + ; + ; to finish this state change we could recursively call (finish-business), but + ; a goto let's us not use the stack. Someday I envision code that keeps on + ; setf-ing, polling the OS for events, in which case we cannot very well use + ; recursion. But as a debugger someone might want to change the next form + ; to (finish-business) if they are having trouble with a chain of setf's and + ; want to inspect the history on the stack. + ; (go tell-dependents))))) --- /project/cells/cvsroot/cells/model-object.lisp 2006/03/16 05:28:28 1.3 +++ /project/cells/cvsroot/cells/model-object.lisp 2006/03/18 00:15:40 1.4 @@ -133,7 +133,7 @@ ;; but I think anything better creates a run-time hit. ;; (unless (md-slot-cell-flushed self slot-name) ;; slot will have been propagated just after cell was flushed - (slot-change slot-name self (bd-slot-value self slot-name) nil nil))) + (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil))) ((find (c-lazy c) '(:until-asked :always t)) (trc nil "md-awaken deferring c-awaken since lazy" --- /project/cells/cvsroot/cells/propagate.lisp 2006/03/16 05:28:28 1.9 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/03/18 00:15:40 1.10 @@ -85,7 +85,7 @@ ; --- manifest new value as needed --- ; - ; propagation to users jumps back in front of client slot-change handling in cells3 + ; propagation to users jumps back in front of client slot-value-observe handling in cells3 ; because model adopting (once done by the kids change handler) can now be done in ; shared-initialize (since one is now forced to supply the parent to make-instance). ; @@ -95,13 +95,13 @@ ; (c-propagate-to-users c) - (slot-change (c-slot-name c) (c-model c) + (slot-value-observe (c-slot-name c) (c-model c) (c-value c) prior-value prior-value-supplied) ; ; with propagation done, ephemerals can be reset. we also do this in c-awaken, so ; let the fn decide if C really is ephemeral. Note that it might be possible to leave ; this out and use the datapulse to identify obsolete ephemerals and clear them - ; when read. That would avoid ever making again bug I had in which I had the reset inside slot-change, + ; when read. That would avoid ever making again bug I had in which I had the reset inside slot-value-observe, ; thinking that that always followed propagation to users. It would also make ; debugging easier in that I could find the last ephemeral value in the inspector. ; would this be bad for persistent CLOS, in which a DB would think there was still a link @@ -112,14 +112,6 @@ ; --- slot change ----------------------------------------------------------- -(defun slot-change (slot-name self new-value prior-value prior-value-supplied) - (trc nil "slot-change > now!!" self slot-name new-value prior-value) - ;; (count-it :output slot-name) - ; - ; this next guy is a GF with progn method combo, which is why we cannot just use slot-change - ; - (slot-value-observe slot-name self new-value prior-value prior-value-supplied)) - (defmacro defobserver (slotname (&optional (self-arg 'self) (new-varg 'new-value) (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) @@ -172,15 +164,16 @@ ; there is no way one can reliably be sure H will not ask for A ; (trc nil "c-propagate-to-users > queueing" c) - (let ((causation (cons c *causation*))) ;; in case deferred - (with-integrity (:tell-dependents c) - (assert (null *c-calculators*)) - (let ((*causation* causation)) - (trc nil "c-propagate-to-users > notifying users of" c) - (dolist (user (c-users c)) - (unless (member (cr-lazy user) '(t :always :once-asked)) - (trc nil "propagating to user is (used,user):" c user) - (c-value-ensure-current user :user-propagation))))))) + (when (c-users c) + (let ((causation (cons c *causation*))) ;; in case deferred + (with-integrity (:tell-dependents c) + (assert (null *c-calculators*)) + (let ((*causation* causation)) + (trc nil "c-propagate-to-users > notifying users of" c) + (dolist (user (c-users c)) + (unless (member (cr-lazy user) '(t :always :once-asked)) + (trc nil "propagating to user is (used,user):" c user) + (c-value-ensure-current user :user-propagation)))))))) From ktilton at common-lisp.net Sun Mar 19 00:28:38 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 18 Mar 2006 19:28:38 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20060319002838.B4F6D5D0AC@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv11564 Modified Files: cells-test.asd cells.asd Log Message: fix ASDF issues --- /project/cells/cvsroot/cells/cells-test.asd 2006/03/18 00:15:40 1.3 +++ /project/cells/cvsroot/cells/cells-test.asd 2006/03/19 00:28:38 1.4 @@ -10,6 +10,7 @@ :serial t :depends-on (:cells) :components ((:module "cells-test" + ;;:serial t :components ((:file "test") (:file "hello-world") (:file "test-kid-slotting") --- /project/cells/cvsroot/cells/cells.asd 2006/03/16 05:28:28 1.2 +++ /project/cells/cvsroot/cells/cells.asd 2006/03/19 00:28:38 1.3 @@ -6,12 +6,11 @@ (asdf:defsystem :cells :name "cells" - :author "Kenny Tilton " - :version "2.0" - :maintainer "Kenny Tilton " + :author "Kenny Tilton " + :maintainer "Kenny Tilton " :licence "MIT Style" :description "Cells" - :long-description "The Cells dataflow extension to CLOS." + :long-description "Cells: a dataflow extension to CLOS." :serial t :components ((:module "utils-kt" :serial t @@ -24,10 +23,10 @@ (:file "defpackage") (:file "cells") (:file "integrity") + (:file "constructors") (:file "cell-types") (:file "synapse") (:file "synapse-types") - (:file "constructors") (:file "initialize") (:file "md-slot-value") (:file "slot-utilities") From ktilton at common-lisp.net Wed Mar 22 04:08:35 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 21 Mar 2006 23:08:35 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20060322040835.13CDC2001C@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv26430 Modified Files: README.txt cells-test.asd cells.lpr defpackage.lisp load.lisp Log Message: More work on Cells and Celtk --- /project/cells/cvsroot/cells/README.txt 2005/05/06 21:05:45 1.1 +++ /project/cells/cvsroot/cells/README.txt 2006/03/22 04:08:34 1.2 @@ -12,18 +12,22 @@ of tracking dependencies among cells, and propagating values. It is distributed under an MIT-style license. -Documentation is unfortunately quite lacking; the cells-devel list is -still your best source of information. Some documentation can be -found in the doc/ directory of the distribution. See the website at -http://www.common-lisp.net/project/cells/ for more info. +Documentation/support is in the form of: + + the cells-devel mailing list (users and developers both welcome) + .\docs\01-cell-basics.lisp + .\docs\motor-control.lisp ;; actually Bill Clementson's blog entry + extensive examples in the Cells-test regression test suite + the companion Celtk module, which happens also to provide a substantial and + growing portable, native Common Lisp GUI. + +The above examples have all been tested against the current release of Cells. +Now in .\doc is cells-overview.pdf. That is pretty rough and obsolete in re the +code, but some of it might be enlightening. Cells is written in almost-portable ANSI Common Lisp. It makes very light use of the introspective portions of the MOP, and contains a few -workarounds for shortcomings in common implementations. It contains -gratuitous use of silly reader conditionals (eg, #-chya, #-not, etc), -so users wishing to push things like :TEST and :NOT on *FEATURES*, and -users of the New Implementation of Lisp (NIL) should beware. If the -last sentance didn't mean anything to you, you can ignore it. +workarounds for shortcomings in common implementations. Cells is known to currently work on the following Lisp implementations: @@ -43,7 +47,7 @@ a bug in its CLOS implementation, but has not been investigated in great depth. -Cells is belived to work with Corman CL, but has not been recently +Cells is believed to work with Corman CL, but has not been recently tested. In the past, MCL was supported, but a it does not currently pass the test suite. Ressurecting full support for any of these implementations should be easy. --- /project/cells/cvsroot/cells/cells-test.asd 2006/03/19 00:28:38 1.4 +++ /project/cells/cvsroot/cells/cells-test.asd 2006/03/22 04:08:34 1.5 @@ -10,7 +10,7 @@ :serial t :depends-on (:cells) :components ((:module "cells-test" - ;;:serial t + :serial t :components ((:file "test") (:file "hello-world") (:file "test-kid-slotting") --- /project/cells/cvsroot/cells/cells.lpr 2006/03/18 00:15:40 1.8 +++ /project/cells/cvsroot/cells/cells.lpr 2006/03/22 04:08:34 1.9 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Mar 19, 2006 10:49)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/defpackage.lisp 2006/03/16 05:28:28 1.4 +++ /project/cells/cvsroot/cells/defpackage.lisp 2006/03/22 04:08:34 1.5 @@ -51,7 +51,7 @@ #:defmodel #:defobserver #:slot-value-observe #:def-c-unchanged-test #:new-value #:old-value #:old-value-boundp #:c... #:md-awaken - #:mkpart #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids + #:mkpart #:make-kid #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids #:cells-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot #:def-kid-slots #:find-prior #:fm-pos #:kid-no #:fm-includes #:fm-ascendant-common #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib --- /project/cells/cvsroot/cells/load.lisp 2006/03/16 05:28:28 1.2 +++ /project/cells/cvsroot/cells/load.lisp 2006/03/22 04:08:34 1.3 @@ -1,16 +1,14 @@ +#+eval-this-if-you-do-not-autoload-asdf (load (make-pathname :device "c" :directory '(:absolute "0dev" "cells") :name "asdf" :type "lisp")) -(progn - (push (make-pathname :device "c" :directory '(:absolute "0dev" "cells")) +(push (make-pathname :device "c" :directory '(:absolute "0dev" "cells")) asdf:*central-registry*) - (ASDF:OOS 'ASDF:LOAD-OP :CELLS :force t)) - -;;;(push (make-pathname :device "c" -;;; :directory '(:absolute "0dev" "cells" "cells-test")) -;;; asdf:*central-registry*) +#-runtestsuite +(ASDF:OOS 'ASDF:LOAD-OP :CELLS :force t) +#+runtestsuite (ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST :force t) \ No newline at end of file From ktilton at common-lisp.net Wed Mar 22 04:08:35 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 21 Mar 2006 23:08:35 -0500 (EST) Subject: [cells-cvs] CVS cells/cells-test Message-ID: <20060322040835.4D67821001@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv26430/cells-test Modified Files: deep-cells.lisp Log Message: More work on Cells and Celtk --- /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2006/03/18 00:14:01 1.1 +++ /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2006/03/22 04:08:35 1.2 @@ -1,3 +1,5 @@ +(in-package :cells) + (defvar *client-log*) (defvar *obs-1-count*) From ktilton at common-lisp.net Wed Mar 22 04:08:35 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 21 Mar 2006 23:08:35 -0500 (EST) Subject: [cells-cvs] CVS cells/doc Message-ID: <20060322040835.87FF322008@common-lisp.net> Update of /project/cells/cvsroot/cells/doc In directory clnet:/tmp/cvs-serv26430/doc Modified Files: motor-control.lisp Added Files: cells-overview.pdf Log Message: More work on Cells and Celtk --- /project/cells/cvsroot/cells/doc/motor-control.lisp 2006/03/16 05:24:41 1.1 +++ /project/cells/cvsroot/cells/doc/motor-control.lisp 2006/03/22 04:08:35 1.2 @@ -50,6 +50,8 @@ definition and several method definitions): |# +(in-package :cells) + (defmodel motor () ((status :initarg :status :accessor status :initform nil) (fuel-pump :initarg :fuel-pump :accessor fuel-pump --- /project/cells/cvsroot/cells/doc/cells-overview.pdf 2006/03/22 04:08:35 NONE +++ /project/cells/cvsroot/cells/doc/cells-overview.pdf 2006/03/22 04:08:35 1.1 %PDF-1.2 %???? 1 0 obj << /CreationDate (D:191020131000911) /Producer (\376\377\000A\000c\000r\000o\000b\000a\000t\000 \000D\000i\000s\000t\000i\000l\000l\000e\000r\000 \0003\000.\0000\0001\000 \000f\000o\000r\000 \000W\000i\000n\000d\000o\000w\000s) /Title (Untitled Document) /Creator (FrameMaker 5.5.6p145) >> endobj 3 0 obj << /D [2 0 R /XYZ null null null] >> endobj 4 0 obj << /D [2 0 R /XYZ null null null] >> endobj 5 0 obj << /I << /Title (A) >> /F 6 0 R >> endobj 47 0 obj << /D [2 0 R /XYZ 71 47 null] >> endobj 48 0 obj << /D [2 0 R /XYZ 71 725 null] >> endobj 49 0 obj << /D [2 0 R /XYZ 71 692 null] >> endobj 50 0 obj << /D [2 0 R /XYZ 71 665 null] >> endobj 51 0 obj << /D [2 0 R /XYZ 71 639 null] >> endobj 52 0 obj << /Length 259 /Filter /FlateDecode >> stream H?d?Mk?0 ?????Cw??YE?? ?5o+oX?d!??Aq?V*r??L?B??#-???:?I???? ?z????q??J#N,???n??O? 0?="3E????c=??m#:?lF???H?3????9 96?~t/?;AXF??%????[?&0?????????W?w'Y? endstream endobj 53 0 obj << /ProcSet [/PDF /Text ] /Font << /F1 54 0 R /F2 55 0 R >> /ExtGState << /GS1 56 0 R >> >> endobj 59 0 obj << /D [58 0 R /XYZ null null null] >> endobj 61 0 obj << /D [58 0 R /XYZ 71 759 null] >> endobj 62 0 obj << /D [58 0 R /XYZ 71 47 null] >> endobj 63 0 obj << /D [58 0 R /XYZ 71 689 null] >> endobj 64 0 obj << /D [58 0 R /XYZ 71 663 null] >> endobj 65 0 obj << /D [58 0 R /XYZ 71 642 null] >> endobj 66 0 obj << /D [58 0 R /XYZ 71 606 null] >> endobj 67 0 obj << /D [58 0 R /XYZ 71 596 null] >> endobj 68 0 obj << /D [58 0 R /XYZ 71 584 null] >> endobj 69 0 obj << /D [58 0 R /XYZ 71 573 null] >> endobj 70 0 obj << /D [58 0 R /XYZ 71 563 null] >> endobj 71 0 obj << /D [58 0 R /XYZ 71 551 null] >> endobj 72 0 obj << /D [58 0 R /XYZ 71 540 null] >> endobj 73 0 obj << /D [58 0 R /XYZ 71 530 null] >> endobj 74 0 obj << /D [58 0 R /XYZ 71 518 null] >> endobj 75 0 obj << /D [58 0 R /XYZ 71 501 null] >> endobj 76 0 obj << /D [58 0 R /XYZ 71 467 null] >> endobj 77 0 obj << /D [58 0 R /XYZ 71 431 null] >> endobj 78 0 obj << /D [58 0 R /XYZ 71 368 null] >> endobj 79 0 obj << /D [58 0 R /XYZ 71 320 null] >> endobj 80 0 obj << /D [58 0 R /XYZ 71 257 null] >> endobj 81 0 obj << /D [58 0 R /XYZ 71 221 null] >> endobj 82 0 obj << /D [58 0 R /XYZ 71 201 null] >> endobj 83 0 obj << /D [58 0 R /XYZ 71 152 null] >> endobj 84 0 obj << /D [58 0 R /XYZ 71 131 null] >> endobj 85 0 obj << /Length 2572 /Filter /FlateDecode >> stream H??W????}o???@^????jY? f? 6X`yh???h[iY?????SU?d???l^??uc??T?S?/?????9f[?????????1 ??9/??=??l_??[?6?x????)??V??????~?I???????O????/????c?W'???????4dAV??`??YsaD??? ????d1Sk??????3?>]?fy???E?V????????kQ??Nr?A??D ?c?"6???????A?I?w~0?D7l_???2???w0?+bg,?x????m???l?@????{??~???|??[mD q?;????Z?J?????b_???V?k???W?0?,?????#??l?????-???k???wk?0x???)?0??G m?Nj???|G???x'*??te LV???p?C?3O???d?st_?D???????5\??-?!+U%????t???k~??/(??U?9??Q?????v??/??g?8????K??U?F@?Q?o?~???]?D+6>??V;?h=?t ??C??0???{6??|Dij????C?-^z???*?????@???????>D; ]?F1c???M?G4???????,??98???P??Rcs???b??{???t ??[a?BC???? ?n??M?7C??llcA@W??t??A??Wi?#o???M? ?Sn?{??n?_??XO???5ETB;6 ??y?0?P?u??w?????S??s?&????`\)L?24] =?2??H???????(???}z???{fG???C??"i?>?) ?|9 ???=?//x:Y=?= ??3??9yvPS?tl??c|8????^???q???TG1????5s':(??????B ~????????I}"T o\$??GH?????E({h?$???V??d???6uiU?L4to?C4?yq5????e???C??U?:?N?V??????j??U?_YzI2?QB5t????a?%E????i?i;???h`??g?~?a????.??y>??q???@X???)H??q#?u????%??d???6Z{??'Or?"&+E?????{???=?`a????? k????!LQ?r???'?7 4-r??????Yp??S???N??N??Tl?oH8?-??T??:1??&JlaiR??B?????7(?I??????/]X????!.h ???n?? b\Km8I?-i??BT-vF??)??H.? _?[q? y? ?au?u?/? ?-????C?K??g?/3???#???Qwx??? ?R4?????????|)????t???`kh]??V??;??e??]???x~??.`}? endstream endobj 86 0 obj << /ProcSet [/PDF /Text ] /Font << /F1 54 0 R /F2 55 0 R /F3 87 0 R /F4 88 0 R /F5 89 0 R /F6 90 0 R /F7 91 0 R >> /ExtGState << /GS1 56 0 R >> >> endobj 93 0 obj << /D [92 0 R /XYZ null null null] >> endobj 60 0 obj << /P 58 0 R /R [63 63 549 693] /V 6 0 R /N 94 0 R >> endobj 95 0 obj << /D [92 0 R /XYZ 71 759 null] >> endobj 96 0 obj << /D [92 0 R /XYZ 71 47 null] >> endobj 97 0 obj << /D [92 0 R /XYZ 71 687 null] >> endobj 98 0 obj << /D [92 0 R /XYZ 71 666 null] >> endobj 99 0 obj << /D [92 0 R /XYZ 71 632 null] >> endobj 100 0 obj << /D [92 0 R /XYZ 71 596 null] >> endobj 101 0 obj << /D [92 0 R /XYZ 71 561 null] >> endobj 102 0 obj << /D [92 0 R /XYZ 71 470 null] >> endobj 103 0 obj << /D [92 0 R /XYZ 71 393 null] >> endobj 104 0 obj << /D [92 0 R /XYZ 71 372 null] >> endobj 105 0 obj << /D [92 0 R /XYZ 71 296 null] >> endobj 106 0 obj << /D [92 0 R /XYZ 71 162 null] >> endobj 107 0 obj << /Length 2642 /Filter /FlateDecode >> stream H??W]???|7??0?d?R??Zy}O???p??d????K????2??????????????|?tWWW????????0s??y?j?03??????t?6????~i???ff???57??_?? ???W ??~x??s?>_e6??3????,?O{??g]?????C??????y?u1?????~??7??&?;KG?Vlq?]f????????.??,`??Z???g?^,V???7Y?B??h??????|???y???5.?C?????v?\?p??0?????q?????z???u?YVx??3??m?{??Q?gf2??W??3e+g?8???M?????????????c?v????? [q?K!??0Vl.?&???2??@K\/? ????????0????B1?K?s?Z?$?gs?????z??k????p(T???eF?o ?l??7$????????H??=?T]q0m?aZ?????9'Z??"6?'???|?*????=C?`C??uP??K???3????H??j?-????h??=a????,?G*??U????????cmm`?B???a??}]0 ?z?????'V?? ?d????2?5zx????=?250?G????d9????7P??J?v??????????{f??????}?w???(L??l at 9=?????|??? ?^?u????y???X??'t?????S?j?]???v?Ot?T?t?? a??????G{??????0BR??;?? ???#?????? ??O???5????]??v???????;?e?:?U?Nn?C p???:y1E?\ ?????4W????;[%n????P?F?o?m????G~';??4^8(-??b_?Y>W4?r?h4?f=??????????????w? ? ?I????[)?? ????a;VLBdf???Tx)?G&???S?Xe.?n8S??]????)??.?t???????h??KkH[?3????E??????9??\??)=????????F??*????f? ???Jx???D??)Ae!??"o?$??v?{?tg???????????T??C??????Ab??J?6?b????\?Y????*?T?g@??w?!-???bCZ?S ??ow??%V??V(-?1????? ??9?J???6yrV???=?????b???J????[?Bt?? ?'? t??_+:)9Z?W?"?I???Hx?x???3?E ev?z^? 1?H?W?z?!???Jw(??o?T"??????????????J????????z?{?,?????,?K??w ?k??h????TfFjV9ML?L%??V2???8????7y:y?O?J!uV???e????&??.2z=???????`;?}?j^)???n??????#_??*??p"DG???????Mz????\)e#???(??|9GI*O-UT????n?;??4:2?r??!?H??????_?=??/???j??;?????>4??????9?`????a????M?M#?N~??km??g?z?nh?*?~D???"??)?`n`p???>g=[e???*e?/?_?w??[ endstream endobj 108 0 obj << /ProcSet [/PDF /Text ] /Font << /F1 54 0 R /F2 55 0 R /F3 87 0 R /F6 90 0 R >> /ExtGState << /GS1 56 0 R >> >> endobj 110 0 obj << /D [109 0 R /XYZ null null null] >> endobj 94 0 obj << /P 92 0 R /R [63 63 549 693] /V 60 0 R /N 111 0 R >> endobj 112 0 obj << /D [109 0 R /XYZ 71 687 null] >> endobj 113 0 obj << /D [109 0 R /XYZ 71 666 null] >> endobj 114 0 obj << /D [109 0 R /XYZ 71 603 null] >> endobj 115 0 obj << /D [109 0 R /XYZ 71 540 null] >> endobj 116 0 obj << /D [109 0 R /XYZ 71 522 null] >> endobj 117 0 obj << /D [109 0 R /XYZ 71 504 null] >> endobj 118 0 obj << /D [109 0 R /XYZ 71 486 null] >> endobj 119 0 obj << /D [109 0 R /XYZ 71 468 null] >> [2065 lines skipped] From ktilton at common-lisp.net Wed Mar 22 05:26:22 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 22 Mar 2006 00:26:22 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060322052622.49F6159058@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv5809 Modified Files: CELTK.lpr Celtk.asd Celtk.lisp composites.lisp demos.lisp load.lisp ltk-kt.lisp menu.lisp textual.lisp tk-format.lisp widgets.lisp Added Files: ltktest-cells-inside.lisp Log Message: --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/22 05:26:21 1.2 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Mar 19, 2006 10:49)"; cg: "1.81"; -*- (in-package :cg-user) @@ -6,15 +6,16 @@ (define-project :name :celtk :modules (list (make-instance 'module :name "ltk-kt.lisp") - (make-instance 'module :name "notes.lisp") (make-instance 'module :name "Celtk.lisp") (make-instance 'module :name "tk-format.lisp") (make-instance 'module :name "menu.lisp") - (make-instance 'module :name "composites.lisp") (make-instance 'module :name "textual.lisp") (make-instance 'module :name "widgets.lisp") (make-instance 'module :name "canvas.lisp") - (make-instance 'module :name "demos.lisp")) + (make-instance 'module :name "composites.lisp") + (make-instance 'module :name "demos.lisp") + (make-instance 'module :name + "ltktest-cells-inside.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells")) :libraries nil --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/22 05:26:21 1.2 @@ -18,8 +18,10 @@ (:file "Celtk") (:file "tk-format") (:file "menu") - (:file "composites") (:file "textual") (:file "widgets") (:file "canvas") - (:file "demos"))) + (:file "composites") + (:file "demos") + (:file "ltktest-cells-inside"))) + --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/22 05:26:21 1.2 @@ -24,25 +24,28 @@ (:use :common-lisp :utils-kt :cells) (:import-from #:ltk - #:wish-stream #:*wish* #:*ewish* "*DEBUG-TK*" - #:peek-char-no-hang #:read-data - #:send-wish #:tkescape + #:wish-stream #:*wish* #:*ewish* + #:peek-char-no-hang #:read-data #:event-root-x #:event-root-y + #:send-wish #:tkescape #:after #:after-cancel #:bind #:with-ltk #:do-execute #:add-callback) - (:export #:window #:panedwindow #:mk-row #:pack-self #:mk-stack #:mk-text-widget + (:export + #:pop-up #:event-root-x #:event-root-y + #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:mk-panedwindow #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label #:selection #:selector - #:mk-checkbutton #:mk-button #:mk-button-ex #:mk-entry - #:frame-stack #:mk-frame-stack #:pack-layout? #:path + #:mk-checkbutton #:mk-button #:mk-button-ex #: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 #:tk-callback #:mk-menu #:mk-menu-entry-cascade #:mk-menubar + #:mk-menu-entry-command #:tk-callback #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar #:^entry-values #:tk-eval-list #:mk-scale #:mk-popup-menubutton - #:mk-polygon #:mk-oval #:mk-line #:mk-arc #:mk-text-item - #:mk-rectangle #:mk-bitmap #:mk-canvas #:mk-frame-row + #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc #:text-tem #:mk-text-item + #: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)) + #:tk-user-queue-handler #:timer)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -51,13 +54,49 @@ (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))) + (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class) + (timers :initarg :timers :accessor timers :initform nil))) (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) (define-symbol-macro .tkw (nearest self window)) +;;; --- timers ---------------------------------------- + +(defmodel timer () + ((id :initarg :id :accessor id + :initform (c? (bwhen (spawn (^spawn)) + (apply 'after spawn)))) + (tag :cell nil :initarg :tag :accessor tag :initform :anon) + (action :initform nil :initarg :action :accessor action) + (delay :initform 0 :initarg :delay :accessor delay) + (repeat :initform 1 :initarg :repeat :accessor repeat) + (completed :cell :ephemeral :initform (c-in nil) :initarg :completed :accessor completed) + (executions :initarg :executions :accessor executions + :initform (c? (+ (or .cache 0) + (if (^completed) 1 0)))) + (spawn :initarg :spawn :accessor spawn + :initform (c? (if (not (^action)) + (trc "Warning: timer with no associated action" self) + (flet ((spawn-delayed (n) + (list n (lambda () + (funcall (^action) self) + (setf (^completed) t))))) + (bwhen (repeat (^repeat)) + (when (or (zerop (^executions)) + (^completed)) + (typecase repeat + (number (when (< (^executions)(^repeat)) + (spawn-delayed (^delay)))) + (cons (bwhen (delay (nth (^executions) (^repeat))) + (spawn-delayed delay))) + (otherwise (spawn-delayed (^delay)))))))))))) + +(defobserver timers ((self tk-object) new-value old-value) + (dolist (k (set-difference old-value new-value)) + (after-cancel (id k)))) ;; causes tk error if not outstanding? + ;;; --- widget ----------------------------------------- @@ -67,9 +106,11 @@ (format nil "~(~a.~a~)" (parent-path (fm-parent self)) (md-name self)))) - (layout :reader layout :initarg :layout :initform nil) + (packing :reader packing :initarg :packing :initform nil) + (gridding :reader gridding :initarg :gridding :initform nil) (enabled :reader enabled :initarg :enabled :initform t) (bindings :reader bindings :initarg :bindings :initform nil) + (menus :reader menus :initarg :menus :initform nil) (image-files :reader image-files :initarg :image-files :initform nil) (selector :reader selector :initarg :selector :initform (c? (upper self selector)))) @@ -82,33 +123,38 @@ (tk-format `(:make-tk ,self) "~(~a~) ~a ~{~(~a~) ~a~^ ~}" (tk-class self) (path self)(tk-configurations self)) :stdfctry)) -;;;(defmethod md-awaken :before ((self widget)) -;;; (loop for (name file-pathname) in (^image-files) -;;; do (tk-format "image create photo ~(~a.~a~) -file ~a" -;;; (^path) name (tkescape (namestring file-pathname))))) +(defmethod tk-configure ((self widget) option value) + (tk-format `(:configure ,self ,option) "~a configure ~(~a~) ~a" (path self) option (tk-send-value value))) -(defobserver image-files () +(defmethod not-to-be :after ((self widget)) + (trc nil "not-to-be tk-forgetting true widget" self) + (tk-format `(:forget ,self) "pack forget ~a" (^path)) + (tk-format `(:destroy ,self) "destroy ~a" (^path))) + +;;; --- bindings ------------------------------------------------------------ + +(defobserver bindings () ;;; (w widget) event fun) ; - ; I do not know how to create the photo for X before X exists - ; though it seems to work. perhaps Tk understands it does not need to - ; place the image in a tree and lets the undefined path go? If so, - ; just add :pre-make-kt before :make-kt in the sort list + ; when we get dynamic with this cell we will have to do the kids + ; thing and worry about extant new-values, de-bind lost old-values ; - (loop for (name file-pathname) in (set-difference new-value old-value :key 'car) - do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file ~a" - (^path) name (tkescape (namestring file-pathname))))) + (with-integrity (:client `(:bind ,self)) + (dolist (bspec new-value) + (if (eql (length bspec) 3) ;; getting wierd here + (destructuring-bind (event fmt fn) bspec + (let ((name (gentemp "BNDG"))) + (tk-format `(:bind ,self) "bind ~a ~a ~a" ;; {puts {:callback ~a}}" + (^path) event (format nil fmt (register-callback self name fn))))) + (destructuring-bind (event fn) bspec + (bind (^path) event fn)))))) -(defobserver bindings () ;;; (w widget) event fun) - (loop for (event fmt fn) in new-value - for name = (gentemp "BNDG") - do (tk-format `(:bind ,self) "bind ~a ~a ~a" ;; {puts {:callback ~a}}" - (^path) event (format nil fmt (register-callback self name fn))))) +;;; --- packing --------------------------------------------------------- -(defobserver layout ((self widget)) +(defobserver packing ((self widget)) (when new-value - (assert (null (kids-layout .parent)) () - "Do not specify layout (here for ~a) unless parent leaves kids-layout unspecified. -This parent is ~a, kids-layout ~a" self (list .parent (type-of .parent)) (kids-layout .parent))) + (assert (null (kids-packing .parent)) () + "Do not specify packing (here for ~a) unless parent leaves kids-packing unspecified. +This parent is ~a, kids-packing ~a" self (list .parent (type-of .parent)) (kids-packing .parent))) ; ; This use next of the parent instead of self is pretty tricky. It has to do with getting ; the pack commands out nested widgets before parents. The pack command issued on behalf @@ -122,17 +168,27 @@ (when (and new-value (not (typep .parent 'panedwindow))) (tk-format `(:pack ,(fm-parent self)) new-value))) -(defun pack-self () - (c? (format nil "pack ~a" (path self)))) +(defmacro c?pack-self (&optional (modifier$ "")) + `(c? (format nil "pack ~a ~a" (path self) ,modifier$))) -(defmethod tk-configure ((self widget) option value) - (tk-format `(:configure ,self ,option) "~A configure ~(~a~) ~a" (path self) option (tk-send-value value))) +;;; --- grids ------------------------------------------------------------------------- -(defmethod not-to-be :after ((self widget)) - (trc nil "not-to-be tk-forgetting true widget" self) - (tk-format `(:forget ,self) "pack forget ~a" (^path)) - (tk-format `(:destroy ,self) "destroy ~a" (^path))) +(defmodel grid-manager ()()) +(defobserver gridding ((self grid-manager)) + (when new-value + (loop for k in (^kids) + when (gridding k) + do (tk-format `(:grid ,k) (format nil "grid ~a ~a" (path k) (gridding k)))) + (destructuring-bind (&key columns rows) new-value + (when columns + (loop for config in columns + for idx upfrom 0 + do (tk-format `(:grid ,self) (format nil "grid columnconfigure ~a ~a ~a" (^path) idx config)))) + (when columns + (loop for config in rows + for idx upfrom 0 + do (tk-format `(:grid ,self) (format nil "grid rowconfigure ~a ~a ~a" (^path) idx config))))))) ;;; --- items ----------------------------------------------------------------------- @@ -230,7 +286,7 @@ (defun tk-callback (self id-suffix fn &optional command) (declare (ignorable command)) (let ((id (register-callback self id-suffix fn))) - (trc nil "tk-callback" self id command) + (trc nil "tk-callback" self id) (list 'callback id))) (defun tk-callbackstring (self id-suffix tk-token fn) @@ -291,3 +347,21 @@ (tk-variable self) (tk-send-value new-value)))) +;;; --- images ------------------------------------------------------- + +(defobserver image-files () + ; + ; I do not know how to create the photo for X before X exists + ; though it seems to work. perhaps Tk understands it does not need to + ; place the image in a tree and lets the undefined path go? If so, + ; just add :pre-make-kt before :make-kt in the sort list + ; + (loop for (name file-pathname) in (set-difference new-value old-value :key 'car) + do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file ~a" + (^path) name (tkescape (namestring file-pathname))))) + + +;;; --- menus --------------------------------- + +(defun pop-up (menu x y) + (tk-format-now "tk_popup ~A ~A ~A" (path menu) x y)) \ No newline at end of file --- /project/cells/cvsroot/Celtk/composites.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/03/22 05:26:21 1.2 @@ -51,7 +51,7 @@ -showhandle) (:default-initargs :id (gentemp "PW") - :layout nil)) + :packing nil)) (defmethod make-tk-instance ((self panedwindow)) (tk-format `(:make-tk ,self) "panedwindow ~a -orient ~(~a~)" @@ -67,7 +67,10 @@ ; -------------------------------------------------------- -(defmodel window (family) +(defmodel composite-widget (widget) + ((kids-packing :initarg :kids-packing :accessor kids-packing :initform nil))) + +(defmodel window (composite-widget) ((wish :initarg :wish :accessor wish :initform (wish-stream *wish*) #+(or) (c? (do-execute "wish84 -name testwindow" @@ -82,47 +85,46 @@ (defmethod path ((self window)) ".") (defmethod parent-path ((self window)) "") -(defmethod kids-layout ((self window)) nil) ;--- group geometry ----------------------------------------- -(defmodel inline-mixin () - ((kids-layout :initarg :kids-layout :accessor kids-layout :initform nil) - (padx :initarg :padx :accessor padx :initform 0) +(defmodel inline-mixin (composite-widget) + ((padx :initarg :padx :accessor padx :initform 0) (pady :initarg :pady :accessor pady :initform 0) - (layout-side :initarg :layout-side :accessor layout-side :initform 'left) + (packing-side :initarg :packing-side :accessor packing-side :initform 'left) (layout-anchor :initarg :layout-anchor :accessor layout-anchor :initform 'nw)) (:default-initargs :kid-slots (lambda (self) (declare (ignore self)) (list - (mk-kid-slot (layout :if-missing t) + (mk-kid-slot (packing :if-missing t) nil))) ;; suppress default - :kids-layout (c? (format nil "pack~{ ~a~} -side ~a -anchor ~a -padx ~a -pady ~a" - (mapcar 'path (^kids)) - (down$ (^layout-side)) - (down$ (^layout-anchor)) - (^padx)(^pady))))) + :kids-packing (c? (when (^kids) + (format nil "pack~{ ~a~} -side ~a -anchor ~a -padx ~a -pady ~a" + (mapcar 'path (^kids)) + (down$ (^packing-side)) + (down$ (^layout-anchor)) + (^padx)(^pady)))))) -(defobserver kids-layout () +(defobserver kids-packing () (when new-value - (tk-format `(:pack ,self kids-layout) new-value))) + (tk-format `(:pack ,self kids-packing) new-value))) (defmodel row-mixin (inline-mixin) () (:default-initargs - :layout-side 'left)) + :packing-side 'left)) (defmodel stack-mixin (inline-mixin) () (:default-initargs - :layout-side 'top)) + :packing-side 'top)) ;--- f r a m e -------------------------------------------------- -(deftk frame () +(deftk frame (composite-widget) () (:tk-spec frame -borderwidth -cursor -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief @@ -168,3 +170,38 @@ (def-mk-inline mk-row (frame-row labelframe-row)) (def-mk-inline mk-stack (frame-stack labelframe-stack)) + +;--- scroller (of canvas; need to generalize this) ---------- + +(defmodel scroller (grid-manager frame) + ((canvas :initarg :canvas :accessor canvas :initform nil)) + (:default-initargs + :id :cv-scroller + :kids-packing nil + :gridding '(:columns ("-weight {1}" "-weight {0}") + :rows ("-weight {1}" "-weight {0}")) + :kids (c? (the-kids + (^canvas) + (mk-scrollbar :id :hscroll + :orient "horizontal" + :gridding "-row 1 -column 0 -sticky we" + :command (c? (format nil "~a xview" (path (kid1 .parent))))) + (mk-scrollbar :id :vscroll + :orient "vertical" + :gridding "-row 0 -column 1 -sticky ns" + :command (c? (format nil "~a yview" (path (kid1 .parent))))))))) + +(defmacro mk-scroller (&rest iargs) + `(make-instance 'scroller + :fm-parent self + , at iargs)) + +(defmethod initialize-instance :after ((self scroller) &key) + ; + ; Tk does not do late binding on widget refs, so the canvas cannot mention the scrollbars + ; in x/y scrollcommands since the canvas gets made first + ; + (with-integrity (:client `(:post-make-tk ,self)) + (setf (xscrollcommand (kid1 self)) (format nil "~a set" (path (fm! :hscroll)))) + (setf (yscrollcommand (kid1 self)) (format nil "~a set" (path (fm! :vscroll)))))) + --- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/22 05:26:21 1.2 @@ -20,22 +20,22 @@ |# + (in-package :celtk-user) (defun ctk::tk-test () - (tk-test-class 'a-few)) + (cells-reset 'tk-user-queue-handler) + (tk-test-class 'ltktest-cells-inside)) (defparameter *tktest* nil) (defun tk-test-class (root-class) - (cells-reset 'tk-user-queue-handler) - (setf ctk::*tk-send-ct* 0) (with-ltk (:debug 0) (send-wish "proc trc2 {cb n1 n2 op} {puts \"(:callback \\\"$cb\\\" :name1 $n1 :name2 \\\"$n2\\\" :op $op)\"}") - (setf ltk::*debug-tk* nil) - (time (setf *tktest* (make-instance root-class))) - (tk-format `(:fini) "wm deiconify .") - )) + (setf ltk:*debug-tk* nil) + (with-integrity () + (time (setf *tktest* (make-instance root-class)))) + (tk-format `(:fini) "wm deiconify ."))) (defun tk-test-all ()(tk-test-class 'a-few)) (defun mk-font-view () @@ -47,7 +47,7 @@ :kids (c? (the-kids (demo-all-menubar) - (mk-row (:layout (pack-self)) + (mk-row (:packing (c?pack-self)) (mk-label :text "aaa" :image-files (list (list 'kt (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "Celtk") @@ -56,7 +56,7 @@ :width 300 :image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt))) - (assorted-canvas-items) + ;;(assorted-canvas-items) (mk-stack () (mk-text-widget @@ -65,9 +65,9 @@ :height 8 :width 25) - (spin-package-with-symbols)) + (spin-package-with-symbols)) - (mk-stack () + #+nahh (mk-stack () (mk-row (:id :radio-ny :selection (c-in 'yes)) (mk-radiobutton-ex ("yes" 'yes)) (mk-radiobutton-ex ("no" 'no)) @@ -93,7 +93,7 @@ :id :enter-me) (mk-label :text (c? (conc$ "echo " (fm^v :enter-me)))))) - (duelling-scrolled-lists) + #+nahh (duelling-scrolled-lists) ))))) (defun style-by-edit-menu () @@ -124,8 +124,11 @@ (item (when spinner (md-value spinner))) (pkg (find-package (string-upcase item)))) (when pkg - (loop for sym being the present-symbols in pkg - collecting sym)))) + (loop for sym being the symbols in pkg + counting sym into symct + collecting sym into syms + finally (trc "syms found !!!" symct) + (return syms))))) :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* @@ -191,7 +194,7 @@ (defun style-by-widgets () (mk-stack ("Style by Widgets" :id :widstyle) (mk-row (:id :stywid - :layout-side 'left + :packing-side 'left :layout-anchor 'sw) (mk-popup-menubutton :id :font-face @@ -277,7 +280,7 @@ (:default-initargs :kids (c? (the-kids (mk-panedwindow - :layout (pack-self) + :packing (c?pack-self) :orient 'vertical :kids (c? (the-kids (loop repeat 2 @@ -288,9 +291,8 @@ (:default-initargs :md-value (c? (tk-eval-list self "font families")) :pady 2 :padx 4 - :layout-side 'left + :packing-side 'left :layout-anchor 'nw - ;;:kids-layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") :kids (c? (the-kids (mk-spinbox :id :font-face :md-value (c-in (car (^md-value))) @@ -311,14 +313,7 @@ ;;; ---- toplevel -------------------------------- -(defmodel tl-popper (frame-stack) - () - (:default-initargs - :pady 2 :padx 4 - :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") - :kids (c? (the-kids - (mk-button-ex ("Open" (make-instance 'file-open)) - :underline 0))))) + (defmodel file-open (toplevel) --- /project/cells/cvsroot/Celtk/load.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/load.lisp 2006/03/22 05:26:21 1.2 @@ -1,3 +1,4 @@ +#+eval-this-if-you-do-not-autoload-asdf (load (make-pathname :device "c" :directory '(:absolute "0dev" "cells") :name "asdf" @@ -7,10 +8,17 @@ asdf:*central-registry*) (push (make-pathname :device "c" :directory '(:absolute "0dev" "Celtk")) - asdf:*central-registry*) + asdf:*central-registry*) + +#-runtestsuite +(ASDF:OOS 'ASDF:LOAD-OP :CELLS) + +#+runtestsuite +(ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST) -(ASDF:OOS 'ASDF:LOAD-OP :Celtk :force t) +#+checkoutceltk +(ASDF:OOS 'ASDF:LOAD-OP :CELTK) -#+gratuitousfeature +#+testceltk (ctk::tk-test) --- /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/22 05:26:22 1.2 @@ -517,26 +517,26 @@ ;;; start wish and set (wish-stream *wish*) (defun start-wish (&rest keys &key handle-errors handle-warnings (debugger t) - stream) + stream) (declare (ignore handle-errors handle-warnings debugger)) ;; open subprocess (if (null (wish-stream *wish*)) (progn - (setf (wish-stream *wish*) (or stream (do-execute *wish-pathname* *wish-args*)) - (wish-call-with-condition-handlers-function *wish*) - (apply #'make-condition-handler-function keys)) - ;; perform tcl initialisations + (setf (wish-stream *wish*) (or stream (do-execute *wish-pathname* *wish-args*)) + (wish-call-with-condition-handlers-function *wish*) + (apply #'make-condition-handler-function keys)) + ;; perform tcl initialisations (with-ltk-handlers () (init-wish))) - ;; By default, we don't automatically create a new connection, because the - ;; user may have simply been careless and doesn't want to push the old - ;; connection aside. The NEW-WISH restart makes it easy to start another. - (restart-case (ltk-error "There is already an inferior wish.") - (new-wish () - :report "Create an additional inferior wish." - (push *wish* *wish-connections*) - (setf *wish* (make-ltk-connection)) - (apply #'start-wish keys))))) + ;; By default, we don't automatically create a new connection, because the + ;; user may have simply been careless and doesn't want to push the old + ;; connection aside. The NEW-WISH restart makes it easy to start another. + (restart-case (ltk-error "There is already an inferior wish.") + (new-wish () + :report "Create an additional inferior wish." + (push *wish* *wish-connections*) + (setf *wish* (make-ltk-connection)) + (apply #'start-wish keys))))) (defun exit-wish () (with-ltk-handlers () @@ -619,7 +619,7 @@ (handler-case (or (let ((event (pop (wish-event-queue *wish*)))) - (when event (ukt:trc "read-event > popq" event)) + ;; (when event (ukt:trc "read-event > popq" event)) event) (if (or blocking (can-read (wish-stream *wish*))) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 05:26:22 1.2 @@ -57,6 +57,9 @@ :grandpar (fm-parent .parent) (type-of (fm-parent .parent))) (tk-format `(:make-tk ,self) "menu ~a -tearoff 0" (^path))) +(defmacro mk-menu-ex (&rest submenus) + `(mk-menu :kids (c? (the-kids , at submenus)))) + (defmethod make-tk-instance :after ((self menu)) (trc nil "make-tk-instance > traversing menu" self) (fm-menu-traverse self @@ -140,6 +143,11 @@ (:default-initargs :menu (c? (path (kid1 self))))) +(defmacro mk-menu-entry-cascade-ex ((&rest initargs) &rest submenus) + `(mk-menu-entry-cascade + , at initargs + :kids (c? (the-kids (mk-menu :kids (c? (the-kids , at submenus))))))) + (defmethod path ((self menu-entry-cascade)) (format nil "~(~a.~a~)" (path .parent) (md-name self))) --- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/22 05:26:22 1.2 @@ -70,16 +70,13 @@ :textvariable (c? (^path)) :md-value (c-in ""))) -;;;(defmethod make-tk-instance ((self entry)) -;;; (setf (gethash (^path) (dictionary .tkw)) self) -;;; (tk-format "entry ~a -textvariable ~a" (path self)(path self))) - (defmethod md-awaken :after ((self entry)) (tk-format `(:trace ,self) "trace add variable ~a write \"trc2 ~a\"" (^path) (register-callback self 'tracewrite (lambda (&key name1 name2 op) (declare (ignorable name1 name2 op)) + (trc nil "tracewrite BINGO!!!!" (^path) (tk-eval-var (^path))) (let ((new-value (tk-eval-var (^path)))) (unless (string= new-value (^md-value)) (setf (^md-value) new-value))))))) --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/22 05:26:22 1.2 @@ -25,11 +25,9 @@ ; --- tk-format --- talking to wish/Tk ----------------------------------------------------- -(defparameter *tk-send-ct* 0) - (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." - (let ((priority '(:destroy :pre-make-tk :make-tk :post-make-tk :variable :bind :selection :trace :configure :pack :fini))) + (let ((priority '(:destroy :pre-make-tk :make-tk :post-make-tk :variable :bind :selection :trace :configure :grid :pack :fini))) (destructuring-bind (type1 self1 &rest dbg) task1 (declare (ignorable dbg)) (assert type1) @@ -58,45 +56,39 @@ (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info) (funcall task))) -(defun tk-format (defer-info fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args))) +(defun tk-format-now (fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args))) + ; + ; --- pure debug stuff --- + ; + (let ((yes '( "scroll")) ;; '("scroll" "pkg-sym")) + (no '())) + (declare (ignorable yes no)) + (when nil #+not (and (find-if (lambda (s) (search s tk$)) yes) + (not (find-if (lambda (s) (search s tk$)) no))) + (format t "~&tk[~a] ~a> ~A~%" dbg #+nah cells::*data-pulse-id* defer-info tk$) + #+nah (unless (find #\" tk$) + (break "bad set ~a" tk$)))) + (assert (wish-stream *wish*)) ;; when not?? + ; + ; --- serious stuff --- + ; + (format (wish-stream *wish*) "~A~%" tk$) + (force-output (wish-stream *wish*))) + +(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" tk$) - - ;; sigh, it can happen outside a path (assert (not (search "nil" tk$)) () "What is NIL doing in TK message ~a?" tk$) + (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 ((core (dbg) - (declare (ignorable dbg)) - ; - ; --- pure debug stuff --- - ; - (let ((yes '("font-face")) - (no '("pkg-sym-list"))) - (declare (ignorable yes no)) - (when nil #+bzzt (and (find-if (lambda (s) (search s tk$)) yes) - (not (find-if (lambda (s) (search s tk$)) no))) - (format t "~&tk[~a] ~a> ~A~%" dbg #+nah cells::*data-pulse-id* defer-info tk$) - #+nah (unless (find #\" tk$) - (break "bad set ~a" tk$)))) - (assert (wish-stream *wish*)) ;; when not?? - ; - ; --- serious stuff --- - ; - (format (wish-stream *wish*) "~A~%" tk$) - (force-output (wish-stream *wish*)) - ; - ; --- mo better debug ----------------- - ; - #+sighh (loop - while (peek-char-no-hang *ewish*) - do (break "ewish!!!!!!!> ~a" (read-line defun*ewish* nil nil))))) + (flet ((do-it () + (apply 'tk-format-now fmt$ fmt-args))) (if defer-info (with-integrity (:client defer-info) - (core :wi)) - (core :im)))) + (do-it)) + (do-it)))) (defmethod tk-send-value ((s string)) (format nil "~s" #+not "{~a}" s)) @@ -113,9 +105,6 @@ (defmethod tk-send-value ((values list)) (format nil "{~{~a~^ ~}}" (mapcar 'tk-send-value values))) -(defmacro pack-layout? (fmt$ &rest args) - `(c? (format nil "pack ~a ~?" (^path) ,fmt$ (list , at args)))) - (defmethod parent-path ((nada null)) "") (defmethod parent-path ((self t)) (^path)) --- /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/22 05:26:22 1.2 @@ -42,8 +42,8 @@ `(make-instance 'button :fm-parent *parent* :text ,text - :command (tk-callback self 'cmd - (lambda () ,command)) + :command (c? (tk-callback self 'cmd + (lambda () ,command))) , at initargs)) ; --- checkbutton --------------------------------------------- @@ -196,9 +196,9 @@ (defobserver initial-value ((self spinbox)) (when new-value - (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) - - (setf (^md-value) new-value))) + (with-integrity (:change) + (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) + (setf (^md-value) new-value)))) ; --- scroll bars ---------------------------------------- @@ -223,7 +223,7 @@ (list-height :initarg :list-height :accessor list-height :initform nil)) (:default-initargs :list-height (c? (max 1 (length (^list-item-keys)))) - :kids-layout nil + :kids-packing nil :kids (c? (the-kids (mk-listbox :id :list-me :kids (c? (the-kids @@ -232,11 +232,11 @@ :font '(courier 9) :state (c? (if (enabled .parent) 'normal 'disabled)) :height (c? (list-height .parent)) - :layout (c? (format nil "pack ~a -side left -fill both -expand 1" (^path))) + :packing (c? (format nil "pack ~a -side left -fill both -expand 1" (^path))) :yscrollcommand (c? (when (enabled .parent) (format nil "~a set" (path (nsib)))))) (mk-scrollbar :id :vscroll - :layout (c? (format nil "pack ~a -side right -fill y" (^path))) + :packing (c?pack-self "-side right -fill y") :command (c? (format nil "~a yview" (path (psib))))))))) (defmethod tk-output-selection :after ((self scrolled-list) new-value old-value old-value-boundp) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 05:26:22 NONE +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 05:26:22 1.1 (in-package :celtk-user) #+test-ltktest (progn (cells-reset 'tk-user-queue-handler) (tk-test-class 'ltktest-cells-inside)) (defmodel ltktest-cells-inside (window) ((elapsed :initarg :elapsed :accessor elapsed :initform (c-in 0))) (:default-initargs :kids (c? (the-kids (ltk-test-menus) (mk-scroller :packing (c?pack-self "-side top -fill both -expand 1") :canvas (c? (make-kid 'ltk-test-canvas))) (mk-row (:packing (c?pack-self "-side bottom")) (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") (mk-button-ex ("Start" (setf (repeat (fm^ :moire-1)) t))) (mk-button-ex ("Stop" (progn (trc "killing running!!!!!!!!!!") (setf (repeat (fm^ :moire-1)) nil))))) (mk-button-ex ("Hallo" (format T "Hallo~%"))) (mk-button-ex ("Welt!" (format T "Welt~%"))) (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Test:") (mk-button-ex ("OK:" (progn ;; I do not like this (setf (repeat (fm^ :moire-1)) 0) (setf (repeat (fm^ :moire-1)) 20))))) (mk-entry :id :entry) (mk-button-ex ("get!" (format t "~&content of entry: ~A~%" (fm^v :entry)))) (mk-button-ex ("set!" (setf (fm^v :entry) "test of set")))))))) (defmodel ltk-test-canvas (canvas) () (:default-initargs :id :test-canvas :scroll-region '(0 0 500 400) :gridding "-row 0 -column 0 -sticky news" :xscrollcommand (c-in nil) ;; see initialize-instance of canvas for gory details :yscrollcommand (c-in nil) :bindings (c? (list (list "<1>" (lambda (event) (pop-up (car (^menus)) (event-root-x event) (event-root-y event)))))) :menus (c? (the-kids (mk-menu :kids (c? (the-kids (mapcar (lambda (spec) (destructuring-bind (lbl . out$) spec (mk-menu-entry-command :label lbl :command (c? (tk-callback .tkw (gentemp "MNU") (lambda () (format t "~&~a" out$))))))) (list (cons "Option 1" "Popup 1") (cons "Option 2" "Popup 2") (cons "Option 3" "Popup 3")))))))) :kids (c? (the-kids (mk-text-item :coords (list 10 10) :anchor "nw" :text "Ltk Demonstration") (make-kid 'moire :id :moire-1))))) (defmodel moire (line) ((rotx :initarg :rotx :accessor rotx :initform (c-in 0)) (repeat :initarg :repeat :accessor repeat :initform (c-in nil))) (:default-initargs :timers (c? (when (^repeat) (list (make-instance 'timer :tag :moire :delay 25 :repeat (let ((m self)) (c? (repeat m))) :action (lambda (timer) (declare (ignore timer)) (incf (^rotx))))))) :coords (c? (let* ((angle (* 0.1 (^rotx))) (angle2 (* 0.3 angle)) (wx (sin (* 0.1 angle)))) (loop for i below 100 for w = (+ angle (* i 2.8001)) for x = (+ (* 50 (sin angle2)) 250 (* 150 (sin w) (1+ wx))) for y = (+ (* 50 (cos angle2)) 200 (* 150 (cos w))) nconcing (list x y)))))) (defun ltk-test-menus () (mk-menubar :kids (c? (the-kids (mk-menu-entry-cascade-ex (:label "File") (mk-menu-entry-command :label "Load" :command (c? (tk-callback .tkw 'load (lambda () (format t "~&Load pressed~&"))))) (mk-menu-entry-command :label "Save" :command (c? (tk-callback .tkw 'save (lambda () (format t "Save pressed~&"))))) (mk-menu-entry-separator) (mk-menu-entry-cascade-ex (:id :export :label "Export...") (mk-menu-entry-command :label "jpeg" :command (c? (tk-callback .tkw 'jpeg (lambda () (format t "Jpeg pressed~&"))))) (mk-menu-entry-command :label "png" :command (c? (tk-callback .tkw 'png (lambda () (format t "Png pressed~&")))))) (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" :accelerator "Alt Q" :command "exit")))))) From ktilton at common-lisp.net Wed Mar 22 05:26:54 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 22 Mar 2006 00:26:54 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20060322052654.0826B63022@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv5902 Modified Files: load.lisp Log Message: --- /project/cells/cvsroot/cells/load.lisp 2006/03/22 04:08:34 1.3 +++ /project/cells/cvsroot/cells/load.lisp 2006/03/22 05:26:53 1.4 @@ -7,8 +7,18 @@ (push (make-pathname :device "c" :directory '(:absolute "0dev" "cells")) asdf:*central-registry*) +(push (make-pathname :device "c" :directory '(:absolute "0dev" "Celtk")) + asdf:*central-registry*) + #-runtestsuite -(ASDF:OOS 'ASDF:LOAD-OP :CELLS :force t) +(ASDF:OOS 'ASDF:LOAD-OP :CELLS) #+runtestsuite -(ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST :force t) \ No newline at end of file +(ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST) + +#+checkoutceltk +(ASDF:OOS 'ASDF:LOAD-OP :CELTK) + +#+testceltk +(ctk::tk-test) + From ktilton at common-lisp.net Wed Mar 22 18:48:14 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 22 Mar 2006 13:48:14 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20060322184814.1E9F032010@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv11734 Modified Files: propagate.lisp Log Message: defobserver now supports an :around option specified in usual place: (defobserver accelerator :around () etc......) Long overdue. --- /project/cells/cvsroot/cells/propagate.lisp 2006/03/18 00:15:40 1.10 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/03/22 18:48:13 1.11 @@ -112,37 +112,39 @@ ; --- slot change ----------------------------------------------------------- -(defmacro defobserver (slotname - (&optional (self-arg 'self) (new-varg 'new-value) - (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) - &body output-body) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',slotname :output-defined) t)) - ,(if (eql (last1 output-body) :test) - (let ((temp1 (gensym)) - (loc-self (gensym))) - `(defmethod slot-value-observe #-(or clisp cormanlisp) progn ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) - (let ((,temp1 (bump-output-count ,slotname)) - (,loc-self ,(if (listp self-arg) - (car self-arg) - self-arg))) - (when (and ,oldvargboundp ,oldvarg) - (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg)) - (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg)))) - `(defmethod slot-value-observe - #-(or clisp cormanlisp) progn ;;broke cells-gtk #+(or clisp cormanlisp) :around - ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) - (declare (ignorable - ,@(flet ((arg-name (arg-spec) - (etypecase arg-spec - (list (car arg-spec)) - (atom arg-spec)))) - (list (arg-name self-arg)(arg-name new-varg) - (arg-name oldvarg)(arg-name oldvargboundp))))) - , at output-body - ;;broke cells-gtk #+(or clisp cormanlisp) (call-next-method) - )))) +(defmacro defobserver (slotname &rest args &aux (aroundp (eq :around (first args)))) + (when aroundp (setf args (cdr args))) + (destructuring-bind ((&optional (self-arg 'self) (new-varg 'new-value) + (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) + &body output-body) args + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get ',slotname :output-defined) t)) + ,(if (eql (last1 output-body) :test) + (let ((temp1 (gensym)) + (loc-self (gensym))) + `(defmethod slot-value-observe #-(or clisp cormanlisp) ,(if aroundp :around 'progn) + ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) + (let ((,temp1 (bump-output-count ,slotname)) + (,loc-self ,(if (listp self-arg) + (car self-arg) + self-arg))) + (when (and ,oldvargboundp ,oldvarg) + (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg)) + (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg)))) + `(defmethod slot-value-observe + #-(or clisp cormanlisp) ,(if aroundp :around 'progn) + ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) + (declare (ignorable + ,@(flet ((arg-name (arg-spec) + (etypecase arg-spec + (list (car arg-spec)) + (atom arg-spec)))) + (list (arg-name self-arg)(arg-name new-varg) + (arg-name oldvarg)(arg-name oldvargboundp))))) + , at output-body + ;;broke cells-gtk #+(or clisp cormanlisp) (call-next-method) + ))))) (defmacro bump-output-count (slotname) ;; pure test func `(if (get ',slotname :outputs) From ktilton at common-lisp.net Wed Mar 22 18:50:08 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 22 Mar 2006 13:50:08 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060322185008.0532633016@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv11856 Modified Files: Celtk.lisp demos.lisp load.lisp ltk-kt.lisp ltktest-cells-inside.lisp menu.lisp tk-format.lisp Log Message: Finishing touches getting ltktest demo fully equivalent to original pure LTk version. Added auto-bind of menu accelerator, and improved the hack to get the OK button working sensibly. --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/22 18:50:08 1.3 @@ -45,7 +45,7 @@ #: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 #:timer)) + #:tk-user-queue-handler #:timer #:make-timer-steps)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -64,6 +64,8 @@ ;;; --- timers ---------------------------------------- +(defstruct timer-steps count) + (defmodel timer () ((id :initarg :id :accessor id :initform (c? (bwhen (spawn (^spawn)) @@ -87,6 +89,8 @@ (when (or (zerop (^executions)) (^completed)) (typecase repeat + (timer-steps (when (< (^executions)(timer-steps-count (^repeat))) + (spawn-delayed (^delay)))) (number (when (< (^executions)(^repeat)) (spawn-delayed (^delay)))) (cons (bwhen (delay (nth (^executions) (^repeat))) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/22 18:50:08 1.3 @@ -23,25 +23,23 @@ (in-package :celtk-user) -(defun ctk::tk-test () - (cells-reset 'tk-user-queue-handler) +(defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (tk-test-class 'ltktest-cells-inside)) -(defparameter *tktest* nil) - (defun tk-test-class (root-class) + (cells-reset 'tk-user-queue-handler) (with-ltk (:debug 0) (send-wish "proc trc2 {cb n1 n2 op} {puts \"(:callback \\\"$cb\\\" :name1 $n1 :name2 \\\"$n2\\\" :op $op)\"}") (setf ltk:*debug-tk* nil) (with-integrity () - (time (setf *tktest* (make-instance root-class)))) + (make-instance root-class)) (tk-format `(:fini) "wm deiconify ."))) -(defun tk-test-all ()(tk-test-class 'a-few)) +(defun tk-test-all ()(tk-test-class 'lotsa-widgets)) (defun mk-font-view () (make-instance 'font-view)) -(defmodel a-few (window) +(defmodel lotsa-widgets (window) () (:default-initargs :kids (c? (the-kids @@ -56,7 +54,7 @@ :width 300 :image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt))) - ;;(assorted-canvas-items) + (assorted-canvas-items) (mk-stack () (mk-text-widget @@ -67,7 +65,7 @@ (spin-package-with-symbols)) - #+nahh (mk-stack () + (mk-stack () (mk-row (:id :radio-ny :selection (c-in 'yes)) (mk-radiobutton-ex ("yes" 'yes)) (mk-radiobutton-ex ("no" 'no)) @@ -79,7 +77,7 @@ (mk-label :text (c? (if (fm^v :check-me) "checked" "unchecked")))) (mk-row () (mk-button-ex ("Time now?" (setf (fm!v :push-time) - (get-universal-time)))) + (get-universal-time)))) (mk-label :text (c? (time-of-day (^md-value))) :id :push-time :md-value (c-in (get-universal-time)))) @@ -93,7 +91,7 @@ :id :enter-me) (mk-label :text (c? (conc$ "echo " (fm^v :enter-me)))))) - #+nahh (duelling-scrolled-lists) + (duelling-scrolled-lists) ))))) (defun style-by-edit-menu () --- /project/cells/cvsroot/Celtk/load.lisp 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/load.lisp 2006/03/22 18:50:08 1.3 @@ -1,13 +1,15 @@ #+eval-this-if-you-do-not-autoload-asdf -(load (make-pathname :device "c" +(load (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "cells") :name "asdf" :type "lisp")) -(push (make-pathname :device "c" :directory '(:absolute "0dev" "cells")) +(push (make-pathname #+lispworks :host #-lispworks :device "c" + :directory '(:absolute "0dev" "cells")) asdf:*central-registry*) -(push (make-pathname :device "c" :directory '(:absolute "0dev" "Celtk")) +(push (make-pathname #+lispworks :host #-lispworks :device "c" + :directory '(:absolute "0dev" "Celtk")) asdf:*central-registry*) #-runtestsuite @@ -22,3 +24,5 @@ #+testceltk (ctk::tk-test) +#+ortestceltk +(celtk-user::tk-test-class 'celtk-user::lotsa-widgets) \ No newline at end of file --- /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/22 18:50:08 1.3 @@ -357,6 +357,7 @@ (defparameter *ewish* nil) (defun do-execute (program args &optional (wt nil)) + (declare (ignorable wt)) "execute program with args " #+:clisp (declare (ignore wt)) (let ((fullstring program)) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 05:26:22 1.1 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 18:50:08 1.2 @@ -17,18 +17,15 @@ (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") (mk-button-ex ("Start" (setf (repeat (fm^ :moire-1)) t))) - (mk-button-ex ("Stop" (progn (trc "killing running!!!!!!!!!!") - (setf (repeat (fm^ :moire-1)) nil))))) - (mk-button-ex ("Hallo" (format T "Hallo~%"))) - (mk-button-ex ("Welt!" (format T "Welt~%"))) + (mk-button-ex ("Stop" (setf (repeat (fm^ :moire-1)) nil)))) + (mk-button-ex ("Hallo" (format T "~&Hallo"))) + (mk-button-ex ("Welt!" (format T "~&Welt"))) (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Test:") - (mk-button-ex ("OK:" (progn ;; I do not like this - (setf (repeat (fm^ :moire-1)) 0) - (setf (repeat (fm^ :moire-1)) 20))))) + (mk-button-ex ("OK:" (setf (repeat (fm^ :moire-1)) (make-timer-steps :count 20))))) (mk-entry :id :entry) - (mk-button-ex ("get!" (format t "~&content of entry: ~A~%" (fm^v :entry)))) + (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :entry)))) (mk-button-ex ("set!" (setf (fm^v :entry) "test of set")))))))) (defmodel ltk-test-canvas (canvas) @@ -70,7 +67,7 @@ :timers (c? (when (^repeat) (list (make-instance 'timer :tag :moire - :delay 25 + :delay 1 :repeat (let ((m self)) (c? (repeat m))) :action (lambda (timer) @@ -92,23 +89,24 @@ (mk-menu-entry-cascade-ex (:label "File") (mk-menu-entry-command :label "Load" :command (c? (tk-callback .tkw 'load - (lambda () (format t "~&Load pressed~&"))))) + (lambda () (format t "~&Load pressed"))))) (mk-menu-entry-command :label "Save" :command (c? (tk-callback .tkw 'save - (lambda () (format t "Save pressed~&"))))) + (lambda () (format t "~&Save pressed"))))) (mk-menu-entry-separator) (mk-menu-entry-cascade-ex (:id :export :label "Export...") (mk-menu-entry-command :label "jpeg" :command (c? (tk-callback .tkw 'jpeg - (lambda () (format t "Jpeg pressed~&"))))) + (lambda () (format t "~&Jpeg pressed"))))) (mk-menu-entry-command :label "png" :command (c? (tk-callback .tkw 'png - (lambda () (format t "Png pressed~&")))))) + (lambda () (format t "~&Png pressed")))))) (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" - :accelerator "Alt Q" + :accelerator "" + :underline 1 :command "exit")))))) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 18:50:08 1.3 @@ -136,6 +136,13 @@ -compound -font -foreground -hidemargin -image -label -state -underline)) +(defobserver accelerator :around ((self menu-entry-usable)) + (call-next-method) + (with-integrity (:client '(:bind nil)) + (when new-value + (tk-format-now "bind . ~a {~a invoke ~a}" new-value (path (upper self menu)) (index self))))) + + (deftk menu-entry-cascade (selector family menu-entry-usable) () (:tk-spec cascade --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/22 18:50:08 1.3 @@ -60,12 +60,14 @@ ; ; --- pure debug stuff --- ; - (let ((yes '( "scroll")) ;; '("scroll" "pkg-sym")) + (let ((yes '( "bind" "invoke")) ;; '("scroll" "pkg-sym")) (no '())) (declare (ignorable yes no)) - (when nil #+not (and (find-if (lambda (s) (search s tk$)) yes) + (bwhen (st (search "\"Alt Q\"" tk$)) + (replace tk$ "{Alt Q}" :start1 st)) + (when (and (find-if (lambda (s) (search s tk$)) yes) (not (find-if (lambda (s) (search s tk$)) no))) - (format t "~&tk[~a] ~a> ~A~%" dbg #+nah cells::*data-pulse-id* defer-info tk$) + (format t "~&tk> ~A~%" #+nah cells::*data-pulse-id* tk$) #+nah (unless (find #\" tk$) (break "bad set ~a" tk$)))) (assert (wish-stream *wish*)) ;; when not?? @@ -108,4 +110,3 @@ (defmethod parent-path ((nada null)) "") (defmethod parent-path ((self t)) (^path)) - From ktilton at common-lisp.net Wed Mar 22 20:36:38 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 22 Mar 2006 15:36:38 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20060322203638.2645F7D004@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv26836/utils-kt Added Files: datetime.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2006/03/22 20:36:38 NONE +++ /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2006/03/22 20:36:38 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- ;;; ;;; ;;; Copyright ? 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :utils-kt) (eval-when (compile load eval) (export '(os-tickcount time-of-day now hour-min-of-day time-in-zone dd-mmm-yy mmm-dd-yyyy))) (defun os-tickcount () (cl:get-internal-real-time)) (defun now () (/ (get-internal-real-time) internal-time-units-per-second)) (defun time-of-day (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~A:~2,,,'0 at A:~2,,,'0 at A" hours minutes seconds))) (defun hour-min-of-day (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~2,,,'0 at A:~2,,,'0 at A" hours minutes))) (defun time-in-zone (inzone &optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylightsavingsp this-zone) (decode-universal-time i-time) (declare (ignorable this-zone day-of-week daylightsavingsp)) (encode-universal-time seconds minutes hours date month year (- inzone (if daylightsavingsp 1 0))))) (defun dd-mmm-yy (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~A-~A-~2,,,'0 at A" date (month-abbreviation month) (mod year 100)))) (defun mmm-dd-yyyy (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~A ~A, ~A" (month-abbreviation month) date year))) (eval-when (compile load eval) (export '(month-abbreviation weekday-abbreviation week-time mdyy-yymd u-time u-date))) (defun month-abbreviation (month) (elt '("Jan" "Feb" "Mar" "Apr" "May" "June" "July" "Aug" "Sept" "Oct" "Nov" "Dec") (1- month))) (defun weekday-abbreviation (day) (elt '("Mon" "Tue" "Wed" "Thur" "Fri" "Sat" "Sun") day)) (defun week-time (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~A ~A ~A, ~A ~a:~2,'0d ~a" (weekday-abbreviation day-of-week) (month-abbreviation month) date year (if (= 12 hours) hours (mod hours 12)) ; JP 010911 since (mod 12 12) = 0, treat 12 as a special case. minutes (if (>= hours 12) "PM" "AM")))) (defun mdyy-yymd (d) (assert (eql 8 (length d))) (conc$ (right$ d 4) (left$ d 4))) (defun u-time (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~2,d:~2,'0d ~a" ;; /// time-zone, really Naggum's stuff (mod hours 12) minutes (if (>= hours 12) "PM" "AM")))) (defun u-date (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~A-~A-~A" date (elt '("Jan" "Feb" "Mar" "Apr" "May" "June" "July" "Aug" "Sept" "Oct" "Nov" "Dec") (1- month)) year ))) (eval-when (compile load eval) (export '(u-day multiple-value-bind m/d/y mm/dd yyyy-mm-dd))) (defun u-day (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (elt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") day-of-week))) (defun u-day3 (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") day-of-week))) (defun m/d/y (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~2,,,'0 at A/~2,,,'0 at A/~2,,,'0 at A" month date (mod year 100)))) (defun mm/dd (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~2,,,'0 at A/~2,,,'0 at A" month date))) (defun yyyy-mm-dd (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~4,,,'0 at A~2,,,'0 at A~2,,,'0 at A" year month date))) (eval-when (compile load eval) (export '(ymdhmsh))) (defun ymdhmsh (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~4,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A" year month date hours minutes seconds (floor (now) 10)))) (defun hyphenated-time-string () (substitute #\- #\: (ymdhmsh))) From ktilton at common-lisp.net Wed Mar 22 20:41:38 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 22 Mar 2006 15:41:38 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060322204138.0F2E27C015@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27411 Modified Files: ltktest-cells-inside.lisp Log Message: --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 18:50:08 1.2 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 20:41:37 1.3 @@ -1,18 +1,73 @@ (in-package :celtk-user) +#| +The comments throughout this source file cover two broad topics: + + How is programming with Celtk different from LTk? + How is programming with Cells different from without Cells? + +Those questions are different because not everything different about Celtk +depends on Cells. + +The pattern will be to have explanatory comments appear after the explained code. + +|# #+test-ltktest (progn (cells-reset 'tk-user-queue-handler) + ; + ; Tk is fussy about the order in which things happen. It likes: + ; - create widgets .x and .y + ; - make .x the -textvariable of .y + ; - set .x to "Hi, Mom" + ; + ; Tk does not like Step 3 going before Step 2. Unfortunately, in a declarative paradigm + ; one does not specify in what order different things should happen, one just specifies + ; the things we want to have happen. That is a big win when it works. But when it did not + ; I created the concept of a so-called "client queue" where client-code could store + ; order-sensitive tasks, and then allowed the client also to specify the handler for + ; that queue. This handler gets called at just the right time in the larger scheme of + ; state propagation one needs for data integrity. Whassat? + ; + ; Data integrity: when the overall data model gets perturbed by a SETF by imperative code + ; (usually processing an event loop) of some datapoint X , we need: + ; + ; - all state computed off X (directly or indirectly through some intermediate state) must be recomputed; + ; - no recomputation can use datapoints not current with the new value of X; + ; - when invoking client observers to process a change in a datapoint, no observer can use + ; any datapoint not current with X; and a corrollary: + ; - should a client observer itself want to SETF a datapoint Y, all the above must + ; happen not just with values current with X, but also current with the value of Y /prior/ + ; to the intended change to Y. + ; + ; To achieve the above, Cells2 and now Cells3 have taken to using FIFO "unfinished business" queues + ; to defer things until The Right Time. Which brings us back to Tk. Inspect the source of + ; tk-user-queue-handler and search the Celtk source for "with-integrity (:client" to see how Celtk + ; manages to talk to Tk in the order Tk likes. But in short, we just add this requirement: + ; + ; - Client code must see only values current with X and not any values current with some + ; subsequent change to Y queued by an observer + ; (tk-test-class 'ltktest-cells-inside)) +; That is all the imperative code there is to Celtk application development, aside from widget commands. Tk handles some +; of the driving imperative logic, and Celtk internals handle the rest. The application works via rules reacting to change, +; computing new state for the application model, which operates on the outside world via observers (on-change callbacks) triggered +; automatically by the Cells engine. See DEFOBSERVER. + (defmodel ltktest-cells-inside (window) - ((elapsed :initarg :elapsed :accessor elapsed :initform (c-in 0))) + () (:default-initargs :kids (c? (the-kids - (ltk-test-menus) + ; + ; Cells GUIs get a lot of mileage out of the family class, which is perfect + ; for graphical hierarchies. + ; + (ltk-test-menus) ;; hiding some code. see below for deets (mk-scroller - :packing (c?pack-self "-side top -fill both -expand 1") - :canvas (c? (make-kid 'ltk-test-canvas))) + :packing (c?pack-self "-side top -fill both -expand 1") + :canvas (c? (make-kid 'ltk-test-canvas))) + (mk-row (:packing (c?pack-self "-side bottom")) (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") @@ -67,7 +122,7 @@ :timers (c? (when (^repeat) (list (make-instance 'timer :tag :moire - :delay 1 + :delay 25 :repeat (let ((m self)) (c? (repeat m))) :action (lambda (timer) From ktilton at common-lisp.net Thu Mar 23 04:22:08 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 22 Mar 2006 23:22:08 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060323042208.EE7D7650A1@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv23358 Modified Files: Celtk.lisp ltktest-cells-inside.lisp Log Message: Further documentation of Celtk in ltktest-cells-inside --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/22 18:50:08 1.3 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 04:22:08 1.4 @@ -45,7 +45,7 @@ #: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 #:timer #:make-timer-steps)) + #:tk-user-queue-handler #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -64,42 +64,55 @@ ;;; --- timers ---------------------------------------- -(defstruct timer-steps count) +(defun never-unchanged (new old) (declare (ignore new old))) + +;;; +;;; Now, not one but three incredibly hairy gyrations Cells-wise: +;;; +;;; - repeat cannot be ephemeral, but we want repeated (setf (^repeat) 20)'s each to fire, +;;; so we specify an unchanged-if value that always "no", lying to get propagation +;;; +;;; - the executions rule is true obfuscated code. It manages to reset the count to zero +;;; on repeated (setf ... 20)'s because on the second repetition we know we will hit the rule +;;; with repeat non-null (20, in fact) and the ephemeral executed will be nil (because it is +;;; only non-nil during propagation of (setf (executed...) t). +;;; +;;; - holy toledo. The /rule/ for after-factory sends the after command to Tk itself! I could just +;;; return a list of the delay and the callback and have an observer dispatch it, but it would +;;; have to so so exactly as the rule does, by dropping it in the deferred client queue. +;;; so do it in the rule, I decide. (defmodel timer () - ((id :initarg :id :accessor id - :initform (c? (bwhen (spawn (^spawn)) - (apply 'after spawn)))) + ((id :cell nil :initarg :id :accessor id :initform nil + :documentation "We use this as well as a flag that an AFTER is outstanding") (tag :cell nil :initarg :tag :accessor tag :initform :anon) + (state :initarg :state :accessor state :initform (c-in :on)) (action :initform nil :initarg :action :accessor action) (delay :initform 0 :initarg :delay :accessor delay) - (repeat :initform 1 :initarg :repeat :accessor repeat) - (completed :cell :ephemeral :initform (c-in nil) :initarg :completed :accessor completed) + (repeat :initform (c-in nil) :initarg :repeat :accessor repeat :unchanged-if 'never-unchanged) + (executed :cell :ephemeral :initarg :executed :accessor executed :initform (c-in nil)) (executions :initarg :executions :accessor executions - :initform (c? (+ (or .cache 0) - (if (^completed) 1 0)))) - (spawn :initarg :spawn :accessor spawn - :initform (c? (if (not (^action)) - (trc "Warning: timer with no associated action" self) - (flet ((spawn-delayed (n) - (list n (lambda () - (funcall (^action) self) - (setf (^completed) t))))) - (bwhen (repeat (^repeat)) - (when (or (zerop (^executions)) - (^completed)) - (typecase repeat - (timer-steps (when (< (^executions)(timer-steps-count (^repeat))) - (spawn-delayed (^delay)))) - (number (when (< (^executions)(^repeat)) - (spawn-delayed (^delay)))) - (cons (bwhen (delay (nth (^executions) (^repeat))) - (spawn-delayed delay))) - (otherwise (spawn-delayed (^delay)))))))))))) + :initform (c? (if (null (^repeat)) + 0 + (if (^executed) + (1+ .cache ) + 0)))) + (after-factory :initform (c? (when (and (eq (^state) :on) + (let ((execs (^executions))) ;; odd reference just to establish dependency when repeat is t + (bwhen (rpt (^repeat)) + (or (eql rpt t) + (< execs rpt)))) ;; it better be a number + (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters + (setf (id self) (after (^delay) (lambda () + (funcall (^action) self) + (setf (^executed) t))))))))))) + (defobserver timers ((self tk-object) new-value old-value) (dolist (k (set-difference old-value new-value)) - (after-cancel (id k)))) ;; causes tk error if not outstanding? + (setf (state k) :off) + (when (id self) + (after-cancel (id k))))) ;; Tk doc says OK if cancelling already executed ;;; --- widget ----------------------------------------- --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 20:41:37 1.3 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 04:22:08 1.4 @@ -58,55 +58,155 @@ (defmodel ltktest-cells-inside (window) () (:default-initargs - :kids (c? (the-kids + :kids (c? + ; c? has one hell of an expansion. In effect one gets: + ; - a first-class anonymous function with the expected body, which will have access to + ; - variables self and .cache (symbol macro, last I looked) for the instance and prior + ; computed value, if any + ; - guaranteed recomputation when the value of any other cell used in the computation changes + ; + ; The abbreviation-challenged use c-formula instead of c?, with different syntax I do not recall + ; + (the-kids ; ; Cells GUIs get a lot of mileage out of the family class, which is perfect - ; for graphical hierarchies. + ; for graphical hierarchies. The deets of the-kids are of negligible interest. ; - (ltk-test-menus) ;; hiding some code. see below for deets + (ltk-test-menus) ;; hiding some code. see defun below for deets (mk-scroller + ; + ; These "mk-" functions do nothing but expand into (make-instance 'scroller ). + ; Where you see, say, mk-button-ex (a) I am poking fun at Microsoft naming of second generation + ; library code that did not want to break existing code and (b) adding a little more value (just + ; inspect the macro source to see how). + ; :packing (c?pack-self "-side top -fill both -expand 1") - :canvas (c? (make-kid 'ltk-test-canvas))) + ; + ; Here is an example of how the Family class helps. The above is one of only two packing + ; statements need to recreate the ltktest demo. Other packing is handled via two + ; slots in an inline-mixin class for various family subclasses, kids-layout and + ; kids-packing. The latter pulls any packing parameters and all kids into one + ; big pack statement kicked off by an observer on that slot. See the inline-mixin + ; class to see how this works. + ; + ; See the scroller class to see some automation of grids (but this was my first experience + ; with grids so look for that to get enhanced over time -- and later automation + ; of the use of PLACE. + ; + :canvas (c? (make-kid 'ltk-test-canvas))) ;; hiding some code. see defmodel thereof below + ; + ; My bad. Scroller should not assume a canvas is the scrollee. To be refined. + ; + (mk-row (:packing (c?pack-self "-side bottom")) + ; + ; Just expand mk-row to see what is going on. It is pretty neat in one respect: if the + ; first row parameter is a string, it knows to make a labelframe instead of plain frame) + ; The other thing it does, by forcing row parameters into a sub-list as the first argument, + ; is let the programmer then just list other widgets (see next) which are understood to + ; be subwidgets contained (packed or gridded) within the frame. + ; (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") - (mk-button-ex ("Start" (setf (repeat (fm^ :moire-1)) t))) - (mk-button-ex ("Stop" (setf (repeat (fm^ :moire-1)) nil)))) + (mk-button-ex ("Start" (setf (moire-spin (fm^ :moire-1)) t))) + ; + ; You were warned about mk-button-ex and its ilk above. + ; + ; fm^ is a wicked abbreviation for (hey, this is open source, look it up or + ; macroexpand it). The long story is that the Family tree becomes effectively + ; a namespace, where the ID slot is the name of a widget. I have a suite of + ; routines that search the namespace by name so one widget can operate on or, + ; more commonly, ask for the value of a slot of some specific widget known to + ; be Out There somewhere. (Kids know their parents, so the search can reach + ; anywhere in the tree.) + ; + ; OK, now what is going on here? The above command starts the canvas display + ; spinning, by tweaking the "repeat" slot of a "moire" (new ad hoc class) object + ; I created to render the pretty design from + ; ltktest. How it accomplishes that will be explained below in the moire class + ; definition. + ; + (mk-button-ex ("Stop" (setf (moire-spin (fm^ :moire-1)) nil)))) + + (mk-button-ex ("Hallo" (format T "~&Hallo"))) (mk-button-ex ("Welt!" (format T "~&Welt"))) (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Test:") - (mk-button-ex ("OK:" (setf (repeat (fm^ :moire-1)) (make-timer-steps :count 20))))) + (mk-button-ex ("OK:" (setf (moire-spin (fm^ :moire-1)) 20)))) (mk-entry :id :entry) (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :entry)))) + ; + ; fm^v -> (md-value (fm^ .... + ; + ; The idea being that every Cells model object has an md-value slot bearing the value + ; of the thing being modeled. Here, the entry widget is modelling a place for users + ; to supply information to an application, and the md-value slot is a good place to + ; keep that information. + ; + ; Thus each class uses md-value to hold something different, but in all cases it is + ; the current value of whatever the instance of that class is understood to hold. + ; (mk-button-ex ("set!" (setf (fm^v :entry) "test of set")))))))) + + (defmodel ltk-test-canvas (canvas) () (:default-initargs :id :test-canvas :scroll-region '(0 0 500 400) :gridding "-row 0 -column 0 -sticky news" - :xscrollcommand (c-in nil) ;; see initialize-instance of canvas for gory details - :yscrollcommand (c-in nil) - :bindings (c? (list (list "<1>" (lambda (event) - (pop-up (car (^menus)) + ; + ; As with packing, Celtk tries to simplify life with Tk gridding. But that is achieved partly + ; by automating things as with the kids-packing and kids-layout slots, and partly by staying + ; out of the programmer's way and letting them specify actual Tk code to be passed unfiltered + ; to Tk. The design choice here is to acknowledge that LTk and Celtk users really are still + ; doing Tk programming; only some automation (and Lispification) is provided. + ; + ; This also simplifies Celtk since it just has to pass the Tk code along with "grid " + ; appended. + ; + :xscrollcommand (c-in nil) ;; see canvas class for the Tk limitation behind this nonsense + :yscrollcommand (c-in nil) ;; in brief, Tk needs the concept of "late binding" on widget names + + :bindings (c? (list (list "<1>" (lambda (event) + ; + ; Stolen from the original. It means "when the left button is + ; pressed on this widget, popup this menu where the button was pressed" + ; + (pop-up (car (^menus)) ;; (^menus) -> (menus self) (event-root-x event) (event-root-y event)))))) - :menus (c? (the-kids (mk-menu - :kids (c? (the-kids - (mapcar (lambda (spec) - (destructuring-bind (lbl . out$) spec - (mk-menu-entry-command - :label lbl - :command (c? (tk-callback .tkw (gentemp "MNU") - (lambda () - (format t "~&~a" out$))))))) - (list (cons "Option 1" "Popup 1") - (cons "Option 2" "Popup 2") - (cons "Option 3" "Popup 3")))))))) + ; + ; an observer on the bindings slot (a) registers a callback and (b) passes along + ; to Tk an appropriate BIND command + ; + :menus + ; + ; here is a limitation with the declarative paradigm. pop-up menus are free to float about + ; unpacked in any parent. One just needs to remember the name of the menu widget to + ; pass it to the pop-up function. So imperative code like ltktest original can just make the menus + ; saving their name in a local variable and then refer to them in a callback to pop them up. + ; + ; in the declarative paradigm we need a slot (defined for any widget or item class) in which + ; to build and store such menus: + ; + (c? (the-kids + (mk-menu + :kids (c? (the-kids + (mapcar (lambda (spec) + (destructuring-bind (lbl . out$) spec + (mk-menu-entry-command + :label lbl + :command (c? (tk-callback .tkw (gentemp "MNU") + (lambda () + (format t "~&~a" out$))))))) + (list (cons "Option 1" "Popup 1") + (cons "Option 2" "Popup 2") + (cons "Option 3" "Popup 3")))))))) :kids (c? (the-kids (mk-text-item @@ -116,17 +216,14 @@ (make-kid 'moire :id :moire-1))))) (defmodel moire (line) - ((rotx :initarg :rotx :accessor rotx :initform (c-in 0)) - (repeat :initarg :repeat :accessor repeat :initform (c-in nil))) + ((rotx :initarg :rotx :accessor rotx :initform (c-in 0))) (:default-initargs - :timers (c? (when (^repeat) - (list (make-instance 'timer - :tag :moire - :delay 25 - :repeat (let ((m self)) - (c? (repeat m))) - :action (lambda (timer) - (declare (ignore timer)) + :timers (c? (list (make-instance 'timer + :state (c-in :on) + :repeat (c-in nil) + :delay 25 ;; milliseconds since this gets passed to TK after + :action (lambda (timer) + (when (eq (state timer) :on) (incf (^rotx))))))) :coords (c? (let* ((angle (* 0.1 (^rotx))) (angle2 (* 0.3 angle)) @@ -137,6 +234,8 @@ for y = (+ (* 50 (cos angle2)) 200 (* 150 (cos w))) nconcing (list x y)))))) +(defun (setf moire-spin) (repeat self) + (setf (repeat (car (timers self))) repeat)) (defun ltk-test-menus () (mk-menubar From ktilton at common-lisp.net Thu Mar 23 04:22:56 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 22 Mar 2006 23:22:56 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20060323042256.04303650A3@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv23415/utils-kt Modified Files: utils-kt.lpr Log Message: --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/03/16 05:26:47 1.5 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/03/23 04:22:56 1.6 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Mar 19, 2006 10:49)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Thu Mar 23 18:25:24 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 23 Mar 2006 13:25:24 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060323182524.015E94E005@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv11130 Modified Files: Celtk.lisp ltktest-cells-inside.lisp menu.lisp textual.lisp Log Message: Final touches on Celtk, the ltktest-cells-inside demo, and the doc in ltktest-cells-inside.lisp. --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 04:22:08 1.4 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 18:25:24 1.5 @@ -75,37 +75,54 @@ ;;; - the executions rule is true obfuscated code. It manages to reset the count to zero ;;; on repeated (setf ... 20)'s because on the second repetition we know we will hit the rule ;;; with repeat non-null (20, in fact) and the ephemeral executed will be nil (because it is -;;; only non-nil during propagation of (setf (executed...) t). +;;; only non-nil during propagation of (setf (executed...) t). not for Cell noobs. ;;; ;;; - holy toledo. The /rule/ for after-factory sends the after command to Tk itself! I could just ;;; return a list of the delay and the callback and have an observer dispatch it, but it would ;;; have to so so exactly as the rule does, by dropping it in the deferred client queue. -;;; so do it in the rule, I decide. +;;; In a sense I am starting here to leverage Cells3 queues to simplify things. Mind you, if +;;; Timer evolves to where we let the client write its own after factory, we might want to +;;; factor out the actual dispatch into an observer to make it transparent (assuming that is +;;; not why they are supplying their own after-factory. +;;; +;;; Timer is totally a work-in-progress with much development ahead. +;;; (defmodel timer () ((id :cell nil :initarg :id :accessor id :initform nil - :documentation "We use this as well as a flag that an AFTER is outstanding") - (tag :cell nil :initarg :tag :accessor tag :initform :anon) - (state :initarg :state :accessor state :initform (c-in :on)) - (action :initform nil :initarg :action :accessor action) - (delay :initform 0 :initarg :delay :accessor delay) - (repeat :initform (c-in nil) :initarg :repeat :accessor repeat :unchanged-if 'never-unchanged) - (executed :cell :ephemeral :initarg :executed :accessor executed :initform (c-in nil)) + :documentation "Assigned by TCL after each AFTER issued. Use to cancel.") + (tag :cell nil :initarg :tag :accessor tag :initform :anon + :documentation "A debugging aid") + (state :initarg :state :accessor state :initform (c-in :on) + :documentation "Turn off to stop, regardless of REPEAT setting") + (action :initform nil :initarg :action :accessor action + :documentation "A function (to which the timer is passed) invoked by when the TCL AFTER executes") + (delay :initform 0 :initarg :delay :accessor delay + :documentation "Millisecond interval supplied as is to TCL AFTER") + (repeat :initform (c-in nil) :initarg :repeat :accessor repeat :unchanged-if 'never-unchanged + :documentation "t = run continuously, nil = pause, a number N = repeat N times") + (executed :cell :ephemeral :initarg :executed :accessor executed :initform (c-in nil) + :documentation "Internal: set after an execution") (executions :initarg :executions :accessor executions + :documentation "Number of times timer has had its action run since the last change to the repeat slot" :initform (c? (if (null (^repeat)) - 0 + 0 ;; ok, repeat is off, safe to reset the counter here (if (^executed) - (1+ .cache ) - 0)))) - (after-factory :initform (c? (when (and (eq (^state) :on) - (let ((execs (^executions))) ;; odd reference just to establish dependency when repeat is t - (bwhen (rpt (^repeat)) - (or (eql rpt t) - (< execs rpt)))) ;; it better be a number - (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters - (setf (id self) (after (^delay) (lambda () - (funcall (^action) self) - (setf (^executed) t))))))))))) + (1+ (or .cache 0)) ;; obviously (.cache is the prior value, and playing it safe in case unset) + 0)))) ;; hunh? executed is ephemeral. we are here only if repeat is changed, so reset + + (after-factory + :documentation "Pure implementation" + :initform (c? (bwhen (rpt (when (eq (^state) :on) + (^repeat))) + (when (or (zerop (^executions)) (^executed)) ;; dispatch initially or after an execution + (when (if (numberp rpt) + (< (^executions) rpt) + rpt) ;; a little redundant since bwhen checks that rpt is not nil + (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters + (setf (id self) (after (^delay) (lambda () + (funcall (^action) self) + (setf (^executed) t)))))))))))) (defobserver timers ((self tk-object) new-value old-value) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 04:22:08 1.4 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 18:25:24 1.5 @@ -4,6 +4,12 @@ The comments throughout this source file cover two broad topics: How is programming with Celtk different from LTk? + +Contrast the code below with the excellent ltktest "classic" in ltk.lisp to +see how Celtk programming is different. + +Second topic: + How is programming with Cells different from without Cells? Those questions are different because not everything different about Celtk @@ -11,6 +17,11 @@ The pattern will be to have explanatory comments appear after the explained code. +n.b. The paint is very fresh on Celtk, so if something like the Timer class looks +dumb, well, it may be. Example: the scroller class only scrolls a canvas (well, I have not tried +supplying a frame for the canvas slot, maybe it would work, but the slot name at least is +certainly wrong (or the class should be canvas-scroller). + |# #+test-ltktest (progn @@ -21,23 +32,25 @@ ; - make .x the -textvariable of .y ; - set .x to "Hi, Mom" ; - ; Tk does not like Step 3 going before Step 2. Unfortunately, in a declarative paradigm - ; one does not specify in what order different things should happen, one just specifies - ; the things we want to have happen. That is a big win when it works. But when it did not - ; I created the concept of a so-called "client queue" where client-code could store - ; order-sensitive tasks, and then allowed the client also to specify the handler for + ; Tk does not like Step 3 going before Step 2. That is, .y will not learn about "Hi, Mom.". + ; Unfortunately, in a declarative paradigm one does not specify in what order different + ; things should happen, one just specifies the things we want to have happen. That is + ; a big win when it works. But when it did not work for Tk I added to Cells the concept + ; of a "client queue" where client-code could store + ; order-sensitive tasks, also allowing the client to specify the handler for ; that queue. This handler gets called at just the right time in the larger scheme of - ; state propagation one needs for data integrity. Whassat? + ; state propagation one needs for data integrity. What is that? ; - ; Data integrity: when the overall data model gets perturbed by a SETF by imperative code - ; (usually processing an event loop) of some datapoint X , we need: + ; Data integrity: when the overall data model gets perturbed by imperative code + ; (such as code processing an event loop) executing a SETF of some datapoint X , we want + ; these requirements satisfied: ; - ; - all state computed off X (directly or indirectly through some intermediate state) must be recomputed; - ; - no recomputation can use datapoints not current with the new value of X; - ; - when invoking client observers to process a change in a datapoint, no observer can use - ; any datapoint not current with X; and a corrollary: - ; - should a client observer itself want to SETF a datapoint Y, all the above must - ; happen not just with values current with X, but also current with the value of Y /prior/ + ; - all state computed off X (directly or indirectly through some intermediate datapoint) must be recomputed; + ; - recomputations must see only datapoint values current with the new value of X. This must + ; work transparently, ie, datapoint accessors are responsible for returning only current values; + ; - similarly, client observers ("on change" callbacks) must see only values current with the new value of X + ; - a corrollary: should a client observer SETF a datapoint Y, all the above must + ; happen with values current not just with X, but also with the value of Y /prior/ ; to the intended change to Y. ; ; To achieve the above, Cells2 and now Cells3 have taken to using FIFO "unfinished business" queues @@ -56,8 +69,19 @@ ; automatically by the Cells engine. See DEFOBSERVER. (defmodel ltktest-cells-inside (window) - () + ((entry-warning :reader entry-warning + :initform (c? (bwhen (bad-chars (loop for c across (fm!v :entry) + when (digit-char-p c) + collect c)) + (format nil "Please! No digits! I see ~a!!" bad-chars))) + ; + ; By the time I decided to add this demo I already had a long discussion under the get! and set! buttons, so + ; check those out for details. + ; + :documentation "Demonstrate live tracking of entry edit")) + (:default-initargs + :id :ltk-test :kids (c? ; c? has one hell of an expansion. In effect one gets: ; - a first-class anonymous function with the expected body, which will have access to @@ -65,25 +89,25 @@ ; computed value, if any ; - guaranteed recomputation when the value of any other cell used in the computation changes ; - ; The abbreviation-challenged use c-formula instead of c?, with different syntax I do not recall + ; If the abbreviation bothers you, look up c-formula. ; (the-kids ; ; Cells GUIs get a lot of mileage out of the family class, which is perfect - ; for graphical hierarchies. The deets of the-kids are of negligible interest. + ; for graphical hierarchies. "the-kids" does not do much, btw. ; (ltk-test-menus) ;; hiding some code. see defun below for deets (mk-scroller ; ; These "mk-" functions do nothing but expand into (make-instance 'scroller ). - ; Where you see, say, mk-button-ex (a) I am poking fun at Microsoft naming of second generation + ; Where you see, say, mk-button-ex I am (a) poking fun at Microsoft naming of second generation ; library code that did not want to break existing code and (b) adding a little more value (just ; inspect the macro source to see how). ; :packing (c?pack-self "-side top -fill both -expand 1") ; ; Here is an example of how the Family class helps. The above is one of only two packing - ; statements need to recreate the ltktest demo. Other packing is handled via two + ; statements needed to recreate the ltktest demo. Other packing is handled via two ; slots in an inline-mixin class for various family subclasses, kids-layout and ; kids-packing. The latter pulls any packing parameters and all kids into one ; big pack statement kicked off by an observer on that slot. See the inline-mixin @@ -105,7 +129,7 @@ ; first row parameter is a string, it knows to make a labelframe instead of plain frame) ; The other thing it does, by forcing row parameters into a sub-list as the first argument, ; is let the programmer then just list other widgets (see next) which are understood to - ; be subwidgets contained (packed or gridded) within the frame. + ; be kids/subwidgets contained (packed or gridded) within the frame. ; (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") @@ -122,12 +146,15 @@ ; anywhere in the tree.) ; ; OK, now what is going on here? The above command starts the canvas display - ; spinning, by tweaking the "repeat" slot of a "moire" (new ad hoc class) object - ; I created to render the pretty design from + ; spinning, by tweaking (via the (setf moire-spin) defun below) the "repeat" slot of + ; an ad hoc "moire" class object created to render the pretty design from ; ltktest. How it accomplishes that will be explained below in the moire class ; definition. ; (mk-button-ex ("Stop" (setf (moire-spin (fm^ :moire-1)) nil)))) + ; + ; ditto + ; (mk-button-ex ("Hallo" (format T "~&Hallo"))) @@ -148,10 +175,49 @@ ; ; Thus each class uses md-value to hold something different, but in all cases it is ; the current value of whatever the instance of that class is understood to hold. + ; + ; The interesting question is, how does the md-value slot of the Lisp instance stay + ; current with the text being edited in the Tk entry widget? Here we have a fundamental + ; difference between Ltk and Celtk. Ltk lets Tk take care of everything, including + ; storing the data. eg, (text my-entry) is an accessor call that asks Tk the value of + ; the -text configuration for the Tk instance mirrored by my-entry. There is no text + ; slot in the Lisp entry instance. But Cells works + ; by having datapoints watching other datapoints, so we want data in the Lisp domain + ; changing automatically as it changes on the TK side (such as when the user is actually + ; typing in the entry widget). See the entry class to see how it uses the TCL "trace write" + ; mechanism to keep the Lisp md-value slot abreast of the Tk entry text configuration + ; keystroke by keystroke. + ; + ; I just added the entry-value slot above to demonstrate the mechanism in action. Click + ; on the entry widget and type "abc123", then delete the 3, 2, and 1, keeping an eye + ; on standard output. ; - (mk-button-ex ("set!" (setf (fm^v :entry) "test of set")))))))) + (mk-button-ex ("set!" (setf (fm^v :entry) "test of set"))) + ; + ; In Ltk one would SETF (text my-entry) and the + ; SETF method would communicate with Tk to make the change to the Tk widget -text + ; configuration. In Celtk, the md-value slot of the entry gets changed (possibly + ; triggering other slots to update, which is why we do not just talk to Tk) and + ; then that value gets propagated to Tk via "set ". Because + ; the textVariable for every entry is the entry itself, the text of the entry + ; then changes. If that sounds weird, what we are actually doing is tapping into + ; Tk to a large degree taking the same approach as Cells does with the md-value + ; slot: in Cells, we think of model instances as wrapping some model-specific + ; value, which is held in the md-value slot of the model instance. Tk simply + ; allows a widget path to be a global variable. Furthermore, as the company name + ; ActiveState suggests, Tk also provides automatic propagation: change the + ; variable, and anyone with that as its textVariable also changes. + ))))) - +(defobserver entry-warning () + ; + ; This demonstrates ones ability to track the text in a Tk entry while it is being + ; edited. As you type you should see the changing values in standard output + ; + (if new-value + (format t "~&User, we have a problem: ~a" new-value) + (when old-value + (format t "~&That looks better: ~a" (fm!v :entry))))) (defmodel ltk-test-canvas (canvas) () @@ -188,8 +254,8 @@ ; ; here is a limitation with the declarative paradigm. pop-up menus are free to float about ; unpacked in any parent. One just needs to remember the name of the menu widget to - ; pass it to the pop-up function. So imperative code like ltktest original can just make the menus - ; saving their name in a local variable and then refer to them in a callback to pop them up. + ; pass it to the pop-up function. So imperative code like ltktest "classic" can just make the menus + ; saving their name in a closed-over local variable and then refer to them in a callback to pop them up. ; ; in the declarative paradigm we need a slot (defined for any widget or item class) in which ; to build and store such menus: @@ -214,30 +280,48 @@ :anchor "nw" :text "Ltk Demonstration") (make-kid 'moire :id :moire-1))))) + ; + ; we give /this/ widget a specific ID so other rules can look it up, as + ; discussed above when explaining fm^. (defmodel moire (line) - ((rotx :initarg :rotx :accessor rotx :initform (c-in 0))) + ((angle-1 :initarg :angle-1 :accessor angle-1 :initform (c-in 0))) (:default-initargs :timers (c? (list (make-instance 'timer - :state (c-in :on) - :repeat (c-in nil) - :delay 25 ;; milliseconds since this gets passed to TK after - :action (lambda (timer) - (when (eq (state timer) :on) - (incf (^rotx))))))) - :coords (c? (let* ((angle (* 0.1 (^rotx))) - (angle2 (* 0.3 angle)) - (wx (sin (* 0.1 angle)))) + ; + ; it occurred to me that it might be useful to build a timer utility + ; around the TCL after command. See the class definition of timer + ; for the fireworks (in terms of Cells) that resulted + ; + :repeat (c-in nil) + :delay 25 ;; milliseconds since this gets passed unvarnished to TK after + :action (lambda (timer) + (when (eq (state timer) :on) + (incf (^angle-1) 0.1)))))) + :coords (c? (let* ((angle-2 (* 0.3 (^angle-1))) + (wx (sin (* 0.1 (^angle-1))))) (loop for i below 100 - for w = (+ angle (* i 2.8001)) - for x = (+ (* 50 (sin angle2)) 250 (* 150 (sin w) (1+ wx))) - for y = (+ (* 50 (cos angle2)) 200 (* 150 (cos w))) + for w = (+ (^angle-1) (* i 2.8001)) + for x = (+ (* 50 (sin angle-2)) 250 (* 150 (sin w) (1+ wx))) + for y = (+ (* 50 (cos angle-2)) 200 (* 150 (cos w))) nconcing (list x y)))))) (defun (setf moire-spin) (repeat self) - (setf (repeat (car (timers self))) repeat)) + (setf (repeat (car (timers self))) repeat)) ;; just hiding the implementation (defun ltk-test-menus () + ; + ; The only difference is that the menu structure as seen by the user + ; is apparent here, which might help some when reorganizing menus. + ; + ; Well, another thing which happens not to be visible here... hang on. + ; OK, I just made the Save menu item contingent upon there being no + ; entry-warning. As you add/remove all digits (considered invalid for + ; demonstration purposes) the menu item becomes available/unavailable + ; appropriately. + ; + ; This is the kind of thing that Cells is good for. + ; (mk-menubar :kids (c? (the-kids (mk-menu-entry-cascade-ex (:label "File") @@ -246,6 +330,8 @@ (lambda () (format t "~&Load pressed"))))) (mk-menu-entry-command :label "Save" + :state (c? (if (entry-warning (fm^ :ltk-test)) + :disabled :normal)) :command (c? (tk-callback .tkw 'save (lambda () (format t "~&Save pressed"))))) (mk-menu-entry-separator) @@ -260,7 +346,13 @@ (lambda () (format t "~&Png pressed")))))) (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" - :accelerator "" + :accelerator "Alt-q" + ; + ; check out the observer on the accelerator slot of the class menu-entry-usable + ; to see how Celtk fills in a gap in Tk: accelerators should work just by + ; declaring them to the menu widget, it seems to me. In Celtk, they do. + ; :underline 1 :command "exit")))))) + --- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 18:50:08 1.3 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/23 18:25:24 1.4 @@ -140,7 +140,7 @@ (call-next-method) (with-integrity (:client '(:bind nil)) (when new-value - (tk-format-now "bind . ~a {~a invoke ~a}" new-value (path (upper self menu)) (index self))))) + (tk-format-now "bind . <~a> {~a invoke ~a}" new-value (path (upper self menu)) (index self))))) (deftk menu-entry-cascade (selector family menu-entry-usable) --- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/23 18:25:24 1.3 @@ -68,7 +68,7 @@ (:default-initargs :id (gentemp "ENT") :textvariable (c? (^path)) - :md-value (c-in ""))) + :md-value (c-in ""))) (defmethod md-awaken :after ((self entry)) (tk-format `(:trace ,self) "trace add variable ~a write \"trc2 ~a\"" From ktilton at common-lisp.net Thu Mar 23 20:57:53 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 23 Mar 2006 15:57:53 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060323205753.0151278006@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv29683 Modified Files: Celtk.lisp ltktest-cells-inside.lisp Log Message: getting a little fancier on the entry widget in ltktest-cells-inside --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 18:25:24 1.5 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 20:57:53 1.6 @@ -274,8 +274,8 @@ into slot-defs when tk-option collecting `(defobserver ,slot-name ((self ,class)) - (when (and new-value old-value-boundp) - (tk-configure self ,(string tk-option) new-value))) + (when old-value-boundp + (tk-configure self ,(string tk-option) (or new-value "")))) into outputs finally (return (values slot-defs outputs))) `(progn --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 18:25:24 1.5 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 20:57:53 1.6 @@ -163,7 +163,20 @@ :relief 'sunken) (mk-label :text "Test:") (mk-button-ex ("OK:" (setf (moire-spin (fm^ :moire-1)) 20)))) - (mk-entry :id :entry) + (mk-entry :id :entry + :background (c? (if (entry-warning .tkw) + ; + ; ok, this is silly, the validation is entry-specific + ; and should be a rule applied to this entry widget, but I + ; will leave it silly to make clear that cells of an instance + ; can depend on cells of other instances + ; + ; so what is .tkw? A symbol macro for (nearest self window). + ; what is nearest? It searches up the Family tree from + ; self inclusive searching for something (typep 'window) + ; + "red" + 'SystemButtonFace))) (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :entry)))) ; ; fm^v -> (md-value (fm^ .... From ktilton at common-lisp.net Fri Mar 24 02:34:16 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 23 Mar 2006 21:34:16 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060324023416.7C0EE6000D@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv5257 Modified Files: ltk-kt.lisp Log Message: Modify ltk-kt.lisp copyright notice to indicate ltk-kt.lisp has been modified. --- /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/22 18:50:08 1.3 +++ /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/24 02:34:16 1.4 @@ -14,7 +14,20 @@ but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. - + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!! PROMINENT NOTICE !!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!! !!!!!!!!!!!!!!! +!!!!!!!!!!!! This file was modified by Kenny !!!!!!!!!!!!!!! +!!!!!!!!!!!! Tilton on March 22, 2006: !!!!!!!!!!!!!!! +!!!!!!!!!!!! !!!!!!!!!!!!!!! +!!!!!!!!!!!! better handling of TK errors !!!!!!!!!!!!!!! +!!!!!!!!!!!! commented out the demo !!!!!!!!!!!!!!! +!!!!!!!!!!!! !!!!!!!!!!!!!!! +!!!!!!!!!!!! !!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + |# #| From ktilton at common-lisp.net Fri Mar 24 03:46:26 2006 From: ktilton at common-lisp.net (ktilton) Date: Thu, 23 Mar 2006 22:46:26 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060324034626.1801C301C@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv13477 Modified Files: CELTK.lpr Celtk.asd Celtk.lisp canvas.lisp composites.lisp demos.lisp ltktest-cells-inside.lisp menu.lisp textual.lisp tk-format.lisp widgets.lisp Removed Files: ltk-kt.lisp Log Message: Remove ltk-kt.lisp, modify celtk.asd to depend on Ltk classic, modify licenses/copyright/attribution in all source. --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/24 03:46:25 1.3 @@ -5,7 +5,8 @@ (defpackage :CELTK) (define-project :name :celtk - :modules (list (make-instance 'module :name "ltk-kt.lisp") + :modules (list (make-instance 'module :name + "C:\\0devtools\\ltk\\ltk.lisp") (make-instance 'module :name "Celtk.lisp") (make-instance 'module :name "tk-format.lisp") (make-instance 'module :name "menu.lisp") --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/24 03:46:25 1.3 @@ -12,10 +12,9 @@ :licence "MIT Style" :description "Tk via LTk with Cells Inside(tm)" :long-description "A Cells-driven portable GUI built atop the LTk core, ultimately implmented by Tk" - :depends-on (:cells) + :depends-on (:ltk :cells) :serial t - :components ((:file "ltk-kt") - (:file "Celtk") + :components ((:file "Celtk") (:file "tk-format") (:file "menu") (:file "textual") --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 20:57:53 1.6 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/24 03:46:25 1.7 @@ -1,31 +1,32 @@ -#| - - Celtic / widget.lisp : Foundation classes - - Copyright (c) 2004 by Kenneth William Tilton - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - This program is distributed in the hope that it will be useful, - but 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. - -|# +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. (defpackage :celtk (:nicknames "CTK") (:use :common-lisp :utils-kt :cells) (:import-from #:ltk - #:wish-stream #:*wish* #:*ewish* - #:peek-char-no-hang #:read-data #:event-root-x #:event-root-y + #:wish-stream #:*wish* #:widget-path + #:read-data #:event-root-x #:event-root-y #:send-wish #:tkescape #:after #:after-cancel #:bind #:with-ltk #:do-execute #:add-callback) @@ -52,6 +53,7 @@ (in-package :Celtk) + (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) --- /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/24 03:46:25 1.2 @@ -1,23 +1,24 @@ -#| - - Celtic / frame.lisp - - Copyright (c) 2004 by Kenneth William Tilton - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - This program is distributed in the hope that it will be useful, - but 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. - -|# +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. (in-package :Celtk) --- /project/cells/cvsroot/Celtk/composites.lisp 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/03/24 03:46:25 1.3 @@ -1,23 +1,25 @@ -#| +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. - Celtic / widget.lisp : Foundation classes - - Copyright (c) 2004 by Kenneth William Tilton - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - This program is distributed in the hope that it will be useful, - but 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) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/22 18:50:08 1.3 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/24 03:46:25 1.4 @@ -1,24 +1,24 @@ -#| - - Celtic - - Copyright (c) 2004 by Kenneth William Tilton - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - This program is distributed in the hope that it will be useful, - but 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. - -|# - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. (in-package :celtk-user) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 20:57:53 1.6 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/24 03:46:25 1.7 @@ -1,3 +1,35 @@ +#| + + This software is Copyright (c) 2003, 2004, 2005, 2006 Peter Herth + Parts Copyright (c) 2005 Thomas F. Burdick + Parts Copyright (c) Cadence Design Systems, GmbH + + Peter Herth grants you the rights to distribute + and use this software as governed by the terms + of the Lisp Lesser GNU Public License + (http://opensource.franz.com/preamble.html), + known as the LLGPL. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!! PROMINENT NOTICE !!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!! !!!!!!!!!!!!!!! +!!!!!!!!!!!! This demo was translated to Cells !!!!!!!!!!!!!!! +!!!!!!!!!!!! by ken Tilton on March 22, 2006. !!!!!!!!!!!!!!! +!!!!!!!!!!!! !!!!!!!!!!!!!!! +!!!!!!!!!!!! Original (ltktest) can be found !!!!!!!!!!!!!!! +!!!!!!!!!!!! at the end of ltk.lisp !!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +|# + + (in-package :celtk-user) #| --- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/23 18:25:24 1.4 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/24 03:46:25 1.5 @@ -1,23 +1,25 @@ -#| - - Celtic - - Copyright (c) 2004 by Kenneth William Tilton - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. - (http://opensource.franz.com/preamble.html) - - This program is distributed in the hope that it will be useful, - but 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) --- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/23 18:25:24 1.3 +++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/24 03:46:25 1.4 @@ -1,23 +1,25 @@ -#| +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. - Celtic / textual.lisp - - Copyright (c) 2004 by Kenneth William Tilton - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - This program is distributed in the hope that it will be useful, - but 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) --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/22 18:50:08 1.3 +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/24 03:46:25 1.4 @@ -1,24 +1,24 @@ -#| - - Celtic / tk-format.lisp : Sending code to Tk - - Copyright (c) 2004 by Kenneth William Tilton - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - This program is distributed in the hope that it will be useful, - but 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. - -|# - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. (in-package :Celtk) --- /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/24 03:46:25 1.3 @@ -1,23 +1,25 @@ -#| +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. - Celtic / button.lisp - - Copyright (c) 2004 by Kenneth William Tilton - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - This program is distributed in the hope that it will be useful, - but 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) From ktilton at common-lisp.net Fri Mar 24 12:09:44 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 24 Mar 2006 07:09:44 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060324120944.6099770053@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv13791 Modified Files: Celtk.lisp ltktest-cells-inside.lisp tk-format.lisp Log Message: --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/24 03:46:25 1.7 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/24 12:09:44 1.8 @@ -123,8 +123,9 @@ rpt) ;; a little redundant since bwhen checks that rpt is not nil (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters (setf (id self) (after (^delay) (lambda () - (funcall (^action) self) - (setf (^executed) t)))))))))))) + (when (eq (^state) :on) + (funcall (^action) self) + (setf (^executed) t))))))))))))) (defobserver timers ((self tk-object) new-value old-value) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/24 03:46:25 1.7 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/24 12:09:44 1.8 @@ -341,9 +341,9 @@ :repeat (c-in nil) :delay 25 ;; milliseconds since this gets passed unvarnished to TK after :action (lambda (timer) - (when (eq (state timer) :on) - (incf (^angle-1) 0.1)))))) - :coords (c? (let* ((angle-2 (* 0.3 (^angle-1))) + (declare (ignore timer)) + (incf (^angle-1) 0.1))))) + :coords (c? (let ((angle-2 (* 0.3 (^angle-1))) (wx (sin (* 0.1 (^angle-1))))) (loop for i below 100 for w = (+ (^angle-1) (* i 2.8001)) --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/24 03:46:25 1.4 +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/24 12:09:44 1.5 @@ -56,6 +56,7 @@ (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info) (funcall task))) +#+debug (defun tk-format-now (fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args))) ; ; --- pure debug stuff --- @@ -77,6 +78,11 @@ (format (wish-stream *wish*) "~A~%" tk$) (force-output (wish-stream *wish*))) +(defun tk-format-now (fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args))) + ;;(format t "~&tk> ~A~%" tk$) + (format (wish-stream *wish*) "~A~%" tk$) + (force-output (wish-stream *wish*))) + (defun tk-format (defer-info fmt$ &rest fmt-args) "Format then send to wish (via user queue)" (assert (or (eq defer-info :grouped) From ktilton at common-lisp.net Sat Mar 25 11:32:44 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 25 Mar 2006 06:32:44 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060325113244.EC4431D00A@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv25467 Modified Files: CELTK.lpr Celtk.lisp demos.lisp ltktest-cells-inside.lisp tk-format.lisp Log Message: Punch up ltktest-cells-inside doc and functionality just a little --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/24 03:46:25 1.3 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/25 11:32:44 1.4 @@ -5,8 +5,7 @@ (defpackage :CELTK) (define-project :name :celtk - :modules (list (make-instance 'module :name - "C:\\0devtools\\ltk\\ltk.lisp") + :modules (list (make-instance 'module :name "ltk-kt.lisp") (make-instance 'module :name "Celtk.lisp") (make-instance 'module :name "tk-format.lisp") (make-instance 'module :name "menu.lisp") --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/24 12:09:44 1.8 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/25 11:32:44 1.9 @@ -250,7 +250,7 @@ (defobserver coords () (when (and (id-no self) new-value) - (tk-format `(:coords ,self) + (tk-format `(:configure ,self) "~a coords ~a ~{ ~a~}" (path .parent) (id-no self) new-value))) (defmethod not-to-be :after ((self item)) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/24 03:46:25 1.4 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/25 11:32:44 1.5 @@ -24,7 +24,9 @@ (in-package :celtk-user) (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package - (tk-test-class 'ltktest-cells-inside)) + (tk-test-class 'ltktest-cells-inside) + ;;(tk-test-class 'lotsa-widgets) + ) (defun tk-test-class (root-class) (cells-reset 'tk-user-queue-handler) @@ -197,7 +199,7 @@ (mk-popup-menubutton :id :font-face :initial-value (c? (second (^entry-values))) - :entry-values (c? (tk-eval-list self "font families"))) + :entry-values (c? (eko ("ff") (tk-eval-list self "font families")))) (mk-scale :id :font-size :md-value (c-in 14) @@ -301,7 +303,7 @@ :from 7 :to 24 :orient 'horizontal) (mk-label :id :txt - :text "Four score and seven years ago today" + :text "Four score seven years ago today" :wraplength 600 :font (c? (list ;; format nil "{{~{~a~^ ~}} ~a}" ;; eg, {{wp greek century} 24} (md-value (fm^ :font-face)) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/24 12:09:44 1.8 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/25 11:32:44 1.9 @@ -77,11 +77,11 @@ ; (such as code processing an event loop) executing a SETF of some datapoint X , we want ; these requirements satisfied: ; - ; - all state computed off X (directly or indirectly through some intermediate datapoint) must be recomputed; + ; - recompute all and only state computed off X (directly or indirectly through some intermediate datapoint); ; - recomputations must see only datapoint values current with the new value of X. This must ; work transparently, ie, datapoint accessors are responsible for returning only current values; ; - similarly, client observers ("on change" callbacks) must see only values current with the new value of X - ; - a corrollary: should a client observer SETF a datapoint Y, all the above must + ; - a corollary: should a client observer SETF a datapoint Y, all the above must ; happen with values current not just with X, but also with the value of Y /prior/ ; to the intended change to Y. ; @@ -102,15 +102,15 @@ (defmodel ltktest-cells-inside (window) ((entry-warning :reader entry-warning - :initform (c? (bwhen (bad-chars (loop for c across (fm!v :entry) - when (digit-char-p c) + :initform (c? (bwhen (bad-chars (loop for c across (fm!v :coord-ct) + unless (digit-char-p c) collect c)) - (format nil "Please! No digits! I see ~a!!" bad-chars))) + (format nil "Please! Only digits! I see ~a!!" bad-chars))) ; ; By the time I decided to add this demo I already had a long discussion under the get! and set! buttons, so - ; check those out for details. + ; check that out for details. ; - :documentation "Demonstrate live tracking of entry edit")) + :documentation "Demonstrate live tracking key by key of entry widget editing")) (:default-initargs :id :ltk-test @@ -119,7 +119,7 @@ ; - a first-class anonymous function with the expected body, which will have access to ; - variables self and .cache (symbol macro, last I looked) for the instance and prior ; computed value, if any - ; - guaranteed recomputation when the value of any other cell used in the computation changes + ; - guaranteed recomputation when the value of any other cell /used in the most recent computation/ changes ; ; If the abbreviation bothers you, look up c-formula. ; @@ -161,17 +161,22 @@ ; first row parameter is a string, it knows to make a labelframe instead of plain frame) ; The other thing it does, by forcing row parameters into a sub-list as the first argument, ; is let the programmer then just list other widgets (see next) which are understood to - ; be kids/subwidgets contained (packed or gridded) within the frame. + ; be kids/subwidgets contained by the frame. ; (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") + ; + ; As with Ltk Classic, the Tk widget configurations become Lisp widget initializers, so + ; the Tk doc documents Celtk. The advantage to the developer is that neither LTk nor + ; Celtk introduce a new API to be mastered, widget-wise. + ; (mk-button-ex ("Start" (setf (moire-spin (fm^ :moire-1)) t))) ; - ; You were warned about mk-button-ex and its ilk above. + ; You were warned about mk-button-ex and its ilk above. Just expand or inspect to + ; see what they do, which is pretty much just hide some boilerplate. ; - ; fm^ is a wicked abbreviation for (hey, this is open source, look it up or - ; macroexpand it). The long story is that the Family tree becomes effectively - ; a namespace, where the ID slot is the name of a widget. I have a suite of + ; fm^ is a wicked abbreviation for "search up the Family tree to find the widget + ; with this ID". ie, The Family tree effectively becomes a namespace of IDs. I have a suite of ; routines that search the namespace by name so one widget can operate on or, ; more commonly, ask for the value of a slot of some specific widget known to ; be Out There somewhere. (Kids know their parents, so the search can reach @@ -191,53 +196,73 @@ (mk-button-ex ("Hallo" (format T "~&Hallo"))) (mk-button-ex ("Welt!" (format T "~&Welt"))) - (mk-row (:borderwidth 2 - :relief 'sunken) + (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Test:") (mk-button-ex ("OK:" (setf (moire-spin (fm^ :moire-1)) 20)))) - (mk-entry :id :entry + ; + ; Cells initiata will be surprised to learn the above works twice even if the button is + ; clicked twice in a row; Cells is about managing state change, and the second time through + ; there is no change. See the Timer class for the solution to this riddle. + ; + (mk-entry :id :coord-ct + ; + ; to help motivate "why Cells?" a little more, we start having the widgets take more + ; interesting effect on each other. The boring entry field now determines the number + ; of coordinates to generate for the canvas line item, which originally was fixed at 100. + ; see the moire class for details. + ; + :md-value (c-in "40") :background (c? (if (entry-warning .tkw) ; ; ok, this is silly, the validation is entry-specific - ; and should be a rule applied to this entry widget, but I - ; will leave it silly to make clear that cells of an instance - ; can depend on cells of other instances + ; and should be a rule specified to this entry widget. Instead, + ; while casually hacking away I stuck it on the window (.tkw, explained + ; in the next paragraph. The Right Way (and coming soon) is an "errors" + ; slot on every tk-object, but I + ; will leave it silly to make clear that cells of one instance + ; can depend on cells of other instances. More discussion a few lines down. ; - ; so what is .tkw? A symbol macro for (nearest self window). + ; so what is .tkw? A symbol macro for "(nearest self window)". ; what is nearest? It searches up the Family tree from ; self inclusive searching for something (typep 'window) ; "red" - 'SystemButtonFace))) - (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :entry)))) + 'SystemButtonFace))) ;; TK won't allow "" as a way of saying "default color" ; - ; fm^v -> (md-value (fm^ .... + ; As you type in the field, if you key in an invalid (non-digit) character, the background + ; immediately turns red. Delete it and it reverts to the default. ; - ; The idea being that every Cells model object has an md-value slot bearing the value - ; of the thing being modeled. Here, the entry widget is modelling a place for users - ; to supply information to an application, and the md-value slot is a good place to - ; keep that information. - ; - ; Thus each class uses md-value to hold something different, but in all cases it is - ; the current value of whatever the instance of that class is understood to hold. - ; ; The interesting question is, how does the md-value slot of the Lisp instance stay ; current with the text being edited in the Tk entry widget? Here we have a fundamental ; difference between Ltk and Celtk. Ltk lets Tk take care of everything, including ; storing the data. eg, (text my-entry) is an accessor call that asks Tk the value of ; the -text configuration for the Tk instance mirrored by my-entry. There is no text - ; slot in the Lisp entry instance. But Cells works + ; slot in the Lisp entry instance. Makes for nice, lightweight Lisp instances. But Cells works ; by having datapoints watching other datapoints, so we want data in the Lisp domain ; changing automatically as it changes on the TK side (such as when the user is actually ; typing in the entry widget). See the entry class to see how it uses the TCL "trace write" ; mechanism to keep the Lisp md-value slot abreast of the Tk entry text configuration ; keystroke by keystroke. ; - ; I just added the entry-value slot above to demonstrate the mechanism in action. Click - ; on the entry widget and type "abc123", then delete the 3, 2, and 1, keeping an eye - ; on standard output. + ; I added the entry-warning slot above to demonstrate the mechanism in action. Click + ; on the entry widget and type "123abc", then delete the alpha characters. The background + ; color (as well as the File\Save menu item state) tracks the typing. (And an observer + ; chats away on standard output.) + ; + + (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :coord-ct)))) ; - (mk-button-ex ("set!" (setf (fm^v :entry) "test of set"))) + ; (fm^v :coord-ct) -> (md-value (fm^ :coord-ct)) + ; + ; The idea being that every Cells model object has an md-value slot bearing the value + ; of the thing being modeled. Here, the entry widget is modelling a place for users + ; to supply information to an application, and the md-value slot is a good place to + ; keep that information. + ; + ; Thus each class uses md-value to hold something different, but in all cases it is + ; the current value of whatever the instance of that class is understood to hold. + ; + (mk-button-ex ("set!" (setf (fm^v :coord-ct) "test of set"))) ; ; In Ltk one would SETF (text my-entry) and the ; SETF method would communicate with Tk to make the change to the Tk widget -text @@ -262,7 +287,7 @@ (if new-value (format t "~&User, we have a problem: ~a" new-value) (when old-value - (format t "~&That looks better: ~a" (fm!v :entry))))) + (format t "~&That looks better: ~a" (fm!v :coord-ct))))) (defmodel ltk-test-canvas (canvas) () @@ -330,7 +355,13 @@ ; discussed above when explaining fm^. (defmodel moire (line) - ((angle-1 :initarg :angle-1 :accessor angle-1 :initform (c-in 0))) + ((angle-1 :initarg :angle-1 :accessor angle-1 :initform (c-in 0)) + (coord-ct :initarg :coord-ct :accessor coord-ct + :initform (c? (or (unless (entry-warning .tkw) + (let ((ct (read-from-string (fm^v :coord-ct) nil))) + (when (and (numberp ct) (> ct 1)) + (max ct 2)))) + .cache)))) ;; ie, prior value (:default-initargs :timers (c? (list (make-instance 'timer ; @@ -344,12 +375,12 @@ (declare (ignore timer)) (incf (^angle-1) 0.1))))) :coords (c? (let ((angle-2 (* 0.3 (^angle-1))) - (wx (sin (* 0.1 (^angle-1))))) - (loop for i below 100 - for w = (+ (^angle-1) (* i 2.8001)) - for x = (+ (* 50 (sin angle-2)) 250 (* 150 (sin w) (1+ wx))) - for y = (+ (* 50 (cos angle-2)) 200 (* 150 (cos w))) - nconcing (list x y)))))) + (wx (sin (* 0.1 (^angle-1))))) + (loop for i below (^coord-ct) + for w = (+ (^angle-1) (* i 2.8001)) + for x = (+ (* 50 (sin angle-2)) 250 (* 150 (sin w) (1+ wx))) + for y = (+ (* 50 (cos angle-2)) 200 (* 150 (cos w))) + nconcing (list x y)))))) (defun (setf moire-spin) (repeat self) (setf (repeat (car (timers self))) repeat)) ;; just hiding the implementation --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/24 12:09:44 1.5 +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/25 11:32:44 1.6 @@ -56,12 +56,12 @@ (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info) (funcall task))) -#+debug +#+nahh (defun tk-format-now (fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args))) ; ; --- pure debug stuff --- ; - (let ((yes '( "bind" "invoke")) ;; '("scroll" "pkg-sym")) + (let ((yes '( "coords" )) ;; '("scroll" "pkg-sym")) (no '())) (declare (ignorable yes no)) (bwhen (st (search "\"Alt Q\"" tk$)) @@ -78,6 +78,7 @@ (format (wish-stream *wish*) "~A~%" tk$) (force-output (wish-stream *wish*))) + (defun tk-format-now (fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args))) ;;(format t "~&tk> ~A~%" tk$) (format (wish-stream *wish*) "~A~%" tk$) From ktilton at common-lisp.net Sun Mar 26 03:40:59 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 25 Mar 2006 22:40:59 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060326034059.5DC2B5080@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv6103 Modified Files: Celtk.lisp ltktest-cells-inside.lisp Log Message: Stop me before I refine the demo again! --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/25 11:32:44 1.9 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/26 03:40:59 1.10 @@ -35,18 +35,19 @@ #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:mk-panedwindow #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label #:selection #:selector - #:mk-checkbutton #:mk-button #:mk-button-ex #:mk-entry #:text + #:mk-checkbutton #: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 #:tk-callback #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar #:^entry-values #:tk-eval-list #:mk-scale #:mk-popup-menubutton - #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc #:text-tem #:mk-text-item + #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc #:text-item #:mk-text-item #: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 #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps)) + #:tk-user-queue-handler #:user-errors #:^user-errors + #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -57,7 +58,8 @@ (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 :initarg :timers :accessor timers :initform nil))) + (timers :initarg :timers :accessor timers :initform nil) + (user-errors :initarg :user-errors :accessor user-errors :initform nil))) (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/25 11:32:44 1.9 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/26 03:40:59 1.10 @@ -47,7 +47,7 @@ Those questions are different because not everything different about Celtk depends on Cells. -The pattern will be to have explanatory comments appear after the explained code. +Note: explanatory comments appear after the explained code. n.b. The paint is very fresh on Celtk, so if something like the Timer class looks dumb, well, it may be. Example: the scroller class only scrolls a canvas (well, I have not tried @@ -66,21 +66,24 @@ ; ; Tk does not like Step 3 going before Step 2. That is, .y will not learn about "Hi, Mom.". ; Unfortunately, in a declarative paradigm one does not specify in what order different - ; things should happen, one just specifies the things we want to have happen. That is - ; a big win when it works. But when it did not work for Tk I added to Cells the concept - ; of a "client queue" where client-code could store - ; order-sensitive tasks, also allowing the client to specify the handler for - ; that queue. This handler gets called at just the right time in the larger scheme of - ; state propagation one needs for data integrity. What is that? - ; - ; Data integrity: when the overall data model gets perturbed by imperative code - ; (such as code processing an event loop) executing a SETF of some datapoint X , we want - ; these requirements satisfied: + ; things should happen, one just specifies the things we want to have happen. An underlying + ; engine then runs around taking care of making that happen, without bothering the developer + ; about how to do that. Including in what order to make those things happen. That is + ; a big win when it works. When it did not work for Tk, and I could see the same thing + ; coming up again in other situations, I added to Cells the concept of a "client queue". + ; Here client-code can store order-sensitive tasks. The client also can specify the handler for + ; that queue. This handler (or the default FIFO handler) gets called at just the right time + ; in the larger scheme of state propagation one needs for data integrity. What is that? + ; + ; Data integrity: when the overall Cells data model gets perturbed by imperative code -- typically an + ; event loop -- executing a SETF of some datapoint X, we want these requirements satisfied: ; ; - recompute all and only state computed off X (directly or indirectly through some intermediate datapoint); - ; - recomputations must see only datapoint values current with the new value of X. This must - ; work transparently, ie, datapoint accessors are responsible for returning only current values; + ; + ; - recomputations must see only datapoint values current with the new value of X; + ; ; - similarly, client observers ("on change" callbacks) must see only values current with the new value of X + ; ; - a corollary: should a client observer SETF a datapoint Y, all the above must ; happen with values current not just with X, but also with the value of Y /prior/ ; to the intended change to Y. @@ -88,9 +91,14 @@ ; To achieve the above, Cells2 and now Cells3 have taken to using FIFO "unfinished business" queues ; to defer things until The Right Time. Which brings us back to Tk. Inspect the source of ; tk-user-queue-handler and search the Celtk source for "with-integrity (:client" to see how Celtk - ; manages to talk to Tk in the order Tk likes. But in short, we just add this requirement: + ; manages to talk to Tk in the order Tk likes. And hack the function tk-format-now to have + ; Celtk dump the TCL/Tk code being sent to wish during initialization, and notice how un-random it looks. You can + ; then comment out the above specification of a Tk-savvy handler to see (a) the order that would have happened + ; before Cells3 and (b) the demo collapse in a heap (or not work in vital ways). + ; + ; But in short, with Cells3 we just add this requirement: ; - ; - Client code must see only values current with X and not any values current with some + ; - Deferred "client" code must see only values current with X and not any values current with some ; subsequent change to Y queued by an observer ; (tk-test-class 'ltktest-cells-inside)) @@ -101,27 +109,17 @@ ; automatically by the Cells engine. See DEFOBSERVER. (defmodel ltktest-cells-inside (window) - ((entry-warning :reader entry-warning - :initform (c? (bwhen (bad-chars (loop for c across (fm!v :coord-ct) - unless (digit-char-p c) - collect c)) - (format nil "Please! Only digits! I see ~a!!" bad-chars))) - ; - ; By the time I decided to add this demo I already had a long discussion under the get! and set! buttons, so - ; check that out for details. - ; - :documentation "Demonstrate live tracking key by key of entry widget editing")) + () (:default-initargs :id :ltk-test :kids (c? - ; c? has one hell of an expansion. In effect one gets: - ; - a first-class anonymous function with the expected body, which will have access to - ; - variables self and .cache (symbol macro, last I looked) for the instance and prior - ; computed value, if any + ; c? has quite an expansion. Functionally, one gets: + ; - a first-class anonymous function with the expected body, which will have access to... + ; - lexical variables self and .cache for the instance and prior computed value, if any ; - guaranteed recomputation when the value of any other cell /used in the most recent computation/ changes ; - ; If the abbreviation bothers you, look up c-formula. + ; If the abbreviation c? alarms you, look up c-formula. ; (the-kids ; @@ -131,7 +129,9 @@ (ltk-test-menus) ;; hiding some code. see defun below for deets (mk-scroller ; - ; These "mk-" functions do nothing but expand into (make-instance 'scroller ). + ; These "mk-" functions do nothing but expand into (make-instance 'scroller ) + ; and supply the "parent" :initarg necessary in Family trees. + ; ; Where you see, say, mk-button-ex I am (a) poking fun at Microsoft naming of second generation ; library code that did not want to break existing code and (b) adding a little more value (just ; inspect the macro source to see how). @@ -193,7 +193,6 @@ ; ditto ; - (mk-button-ex ("Hallo" (format T "~&Hallo"))) (mk-button-ex ("Welt!" (format T "~&Welt"))) (mk-row (:borderwidth 2 :relief 'sunken) @@ -202,31 +201,44 @@ ; ; Cells initiata will be surprised to learn the above works twice even if the button is ; clicked twice in a row; Cells is about managing state change, and the second time through - ; there is no change. See the Timer class for the solution to this riddle. + ; there is no change. See the Timer class for the shocking solution to this riddle. ; - (mk-entry :id :coord-ct + (mk-entry-numeric :id :point-ct + :md-value (c-in "42") ; - ; to help motivate "why Cells?" a little more, we start having the widgets take more - ; interesting effect on each other. The boring entry field now determines the number - ; of coordinates to generate for the canvas line item, which originally was fixed at 100. + ; to help motivate "why Cells?" a little more, we deviate from ltktest 'classic" and + ; start having the widgets take more interesting effect: The entry field now determines the number + ; of points to generate for the canvas line item, which originally was fixed at 100. ; see the moire class for details. ; - :md-value (c-in "40") - :background (c? (if (entry-warning .tkw) - ; - ; ok, this is silly, the validation is entry-specific - ; and should be a rule specified to this entry widget. Instead, - ; while casually hacking away I stuck it on the window (.tkw, explained - ; in the next paragraph. The Right Way (and coming soon) is an "errors" - ; slot on every tk-object, but I - ; will leave it silly to make clear that cells of one instance - ; can depend on cells of other instances. More discussion a few lines down. - ; - ; so what is .tkw? A symbol macro for "(nearest self window)". - ; what is nearest? It searches up the Family tree from - ; self inclusive searching for something (typep 'window) - ; - "red" + :num-parse (c? (eko ("numparse") + ; + ; (EKO is a utils-kt debug hack that prints a value along with arbitrary + ; other info before returning the value to the inquirer) + ; + ; Here we supplement the standard entry-numeric parse rule with + ; our own more stringent rule that knows about the moire task ahead. + ; + ; A vital point with this entry-numeric class (invented just now for + ; this demo) is that Cells does not get in the way of CLOS. We are + ; subclassing, using initforms, default-initargs, and, what I suspect is + ; a big reason Cells are such a big win: different instances of the same + ; class do not need to have the same rules for the same slot. Or even + ; have rules at all; other instances can have a constant or be setffable + ; from outside the model. + ; + (handler-case + (let ((num (parse-integer (^md-value)))) + (cond + ((< num 2) + (list (format nil "Yo, Euclid, at least two, not: ~a!!" num))) + ((> num 200) + (list (format nil "Bzzt! ~a points will not look so hot." num))) + (t num))) + (parse-error (c) + (princ-to-string c))))) + :background (c? (if (user-errors (fm! :point-ct)) + "red" 'SystemButtonFace))) ;; TK won't allow "" as a way of saying "default color" ; ; As you type in the field, if you key in an invalid (non-digit) character, the background @@ -244,15 +256,15 @@ ; mechanism to keep the Lisp md-value slot abreast of the Tk entry text configuration ; keystroke by keystroke. ; - ; I added the entry-warning slot above to demonstrate the mechanism in action. Click + ; I added the :user-errors rule above to demonstrate the mechanism in action. Click ; on the entry widget and type "123abc", then delete the alpha characters. The background ; color (as well as the File\Save menu item state) tracks the typing. (And an observer ; chats away on standard output.) ; - (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :coord-ct)))) + (mk-button-ex ("Print" (format t "~&User wants to see ~A points" (fm^v :point-ct)))) ; - ; (fm^v :coord-ct) -> (md-value (fm^ :coord-ct)) + ; (fm^v :point-ct) -> (md-value (fm^ :point-ct)) ; ; The idea being that every Cells model object has an md-value slot bearing the value ; of the thing being modeled. Here, the entry widget is modelling a place for users @@ -262,7 +274,7 @@ ; Thus each class uses md-value to hold something different, but in all cases it is ; the current value of whatever the instance of that class is understood to hold. ; - (mk-button-ex ("set!" (setf (fm^v :coord-ct) "test of set"))) + (mk-button-ex ("Reset" (setf (fm^v :point-ct) "42"))) ; ; In Ltk one would SETF (text my-entry) and the ; SETF method would communicate with Tk to make the change to the Tk widget -text @@ -278,16 +290,6 @@ ; ActiveState suggests, Tk also provides automatic propagation: change the ; variable, and anyone with that as its textVariable also changes. ))))) - -(defobserver entry-warning () - ; - ; This demonstrates ones ability to track the text in a Tk entry while it is being - ; edited. As you type you should see the changing values in standard output - ; - (if new-value - (format t "~&User, we have a problem: ~a" new-value) - (when old-value - (format t "~&That looks better: ~a" (fm!v :coord-ct))))) (defmodel ltk-test-canvas (canvas) () @@ -306,43 +308,46 @@ ; appended. ; :xscrollcommand (c-in nil) ;; see canvas class for the Tk limitation behind this nonsense - :yscrollcommand (c-in nil) ;; in brief, Tk needs the concept of "late binding" on widget names + :yscrollcommand (c-in nil) ;; in brief, Tk lacks the concept of "late binding" on widget names :bindings (c? (list (list "<1>" (lambda (event) ; ; Stolen from the original. It means "when the left button is ; pressed on this widget, popup this menu where the button was pressed" + ; The only difference is that here we get to specify this along with + ; the rest of the configuration of this instance, whereas in the original + ; the enabling code was just "out there" in a long sequence of other + ; imperatives setting up this widget and that. ie, It is nice having + ; everything about X collected in one place. In case you are wondering, + ; an observer on the bindings slot passes the needed bindings to Tk + ; via the client queue. ; (pop-up (car (^menus)) ;; (^menus) -> (menus self) (event-root-x event) (event-root-y event)))))) - ; - ; an observer on the bindings slot (a) registers a callback and (b) passes along - ; to Tk an appropriate BIND command - ; - :menus - ; - ; here is a limitation with the declarative paradigm. pop-up menus are free to float about - ; unpacked in any parent. One just needs to remember the name of the menu widget to - ; pass it to the pop-up function. So imperative code like ltktest "classic" can just make the menus - ; saving their name in a closed-over local variable and then refer to them in a callback to pop them up. - ; - ; in the declarative paradigm we need a slot (defined for any widget or item class) in which - ; to build and store such menus: - ; - (c? (the-kids - (mk-menu - :kids (c? (the-kids - (mapcar (lambda (spec) - (destructuring-bind (lbl . out$) spec - (mk-menu-entry-command - :label lbl - :command (c? (tk-callback .tkw (gentemp "MNU") - (lambda () - (format t "~&~a" out$))))))) - (list (cons "Option 1" "Popup 1") - (cons "Option 2" "Popup 2") - (cons "Option 3" "Popup 3")))))))) + :menus (c? (the-kids + ; + ; here is a limitation with the declarative paradigm: pop-up menus are free to float about + ; unpacked in any parent. One just needs to remember the name of the menu widget to + ; pass it to the pop-up function. So imperative code like ltktest "classic" can just make the menus + ; saving their name in a closed-over local variable and then refer to them in a callback to pop them up. + ; + ; in the declarative paradigm we need a slot (defined for any widget or item class) in which + ; to build and store such menus. As with bindings, the nice thing again is that we find everything relative + ; to this widget specified in one place. + ; + (mk-menu + :kids (c? (the-kids + (mapcar (lambda (spec) + (destructuring-bind (lbl . out$) spec + (mk-menu-entry-command + :label lbl + :command (c? (tk-callback .tkw (gentemp "MNU") + (lambda () + (format t "~&~a" out$))))))) + (list (cons "Option 1" "Popup 1") + (cons "Option 2" "Popup 2") + (cons "Option 3" "Popup 3")))))))) :kids (c? (the-kids (mk-text-item @@ -351,17 +356,13 @@ :text "Ltk Demonstration") (make-kid 'moire :id :moire-1))))) ; - ; we give /this/ widget a specific ID so other rules can look it up, as + ; we give this widget a specific ID so other rules can look it up, as ; discussed above when explaining fm^. - + (defmodel moire (line) ((angle-1 :initarg :angle-1 :accessor angle-1 :initform (c-in 0)) - (coord-ct :initarg :coord-ct :accessor coord-ct - :initform (c? (or (unless (entry-warning .tkw) - (let ((ct (read-from-string (fm^v :coord-ct) nil))) - (when (and (numberp ct) (> ct 1)) - (max ct 2)))) - .cache)))) ;; ie, prior value + (point-ct :initarg :point-ct :accessor point-ct + :initform (c? (num-value (fm^ :point-ct))))) (:default-initargs :timers (c? (list (make-instance 'timer ; @@ -376,12 +377,13 @@ (incf (^angle-1) 0.1))))) :coords (c? (let ((angle-2 (* 0.3 (^angle-1))) (wx (sin (* 0.1 (^angle-1))))) - (loop for i below (^coord-ct) + (loop for i below (^point-ct) for w = (+ (^angle-1) (* i 2.8001)) for x = (+ (* 50 (sin angle-2)) 250 (* 150 (sin w) (1+ wx))) for y = (+ (* 50 (cos angle-2)) 200 (* 150 (cos w))) nconcing (list x y)))))) + (defun (setf moire-spin) (repeat self) (setf (repeat (car (timers self))) repeat)) ;; just hiding the implementation @@ -392,7 +394,7 @@ ; ; Well, another thing which happens not to be visible here... hang on. ; OK, I just made the Save menu item contingent upon there being no - ; entry-warning. As you add/remove all digits (considered invalid for + ; user-errors. As you add/remove all digits (considered invalid for ; demonstration purposes) the menu item becomes available/unavailable ; appropriately. ; @@ -406,7 +408,7 @@ (lambda () (format t "~&Load pressed"))))) (mk-menu-entry-command :label "Save" - :state (c? (if (entry-warning (fm^ :ltk-test)) + :state (c? (if (user-errors (fm^ :point-ct)) :disabled :normal)) :command (c? (tk-callback .tkw 'save (lambda () (format t "~&Save pressed"))))) @@ -432,3 +434,23 @@ :command "exit")))))) +(defmodel entry-numeric (entry) + ((num-parse :initarg :num-parse :accessor num-parse + :initform (c? (eko ("numparse") + (handler-case + (parse-integer (^md-value)) + (parse-error (c) + (princ-to-string c)))))) + (num-value :initarg :num-value :accessor num-value + :initform (c? (if (numberp (^num-parse)) + (^num-parse) + (or .cache 42))))) + (:default-initargs + :md-value "42" + :user-errors (c? (unless (numberp (^num-parse)) + (^num-parse))))) + + +(defun mk-entry-numeric (&rest iargs) + (apply 'make-instance 'entry-numeric :fm-parent *parent* iargs)) + From ktilton at common-lisp.net Sun Mar 26 14:05:50 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 26 Mar 2006 09:05:50 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20060326140550.0BF731C001@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv14755 Modified Files: fm-utilities.lisp Log Message: fm-find-one now will behave well with a list as the toplevel search object --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/03/16 05:28:28 1.4 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/03/26 14:05:49 1.5 @@ -127,15 +127,17 @@ (without-c-dependency (when family (labels ((tv-family (fm) - (when (and (typep fm 'model-object) - (not (eql fm skip-tree))) - (let ((outcome (and (not (eql skip-node fm)) ;; skipnode new 990310 kt - (funcall applied-fn fm)))) - (unless (and outcome opaque) - (dolist (kid (kids fm)) - (tv-family kid)) - ;(tv-family (mdValue fm)) - ))))) + (etypecase fm + (cons (loop for md in fm do (tv-family md))) + (model-object + (unless (eql fm skip-tree) + (let ((outcome (and (not (eql skip-node fm)) ;; skipnode new 990310 kt + (funcall applied-fn fm)))) + (unless (and outcome opaque) + (dolist (kid (kids fm)) + (tv-family kid)) + ;(tv-family (mdValue fm)) + ))))))) (tv-family family) (when global-search (fm-traverse (fm-parent family) applied-fn From ktilton at common-lisp.net Sun Mar 26 14:07:15 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 26 Mar 2006 09:07:15 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060326140715.0269D1F007@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv14804 Modified Files: Celtk.lisp ltktest-cells-inside.lisp Log Message: popup menu now sets canvas background color --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/26 03:40:59 1.10 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/26 14:07:15 1.11 @@ -39,7 +39,7 @@ #: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 #:tk-callback #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar + #:mk-menu-entry-command #:tk-callback #:menu #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar #:^entry-values #:tk-eval-list #:mk-scale #:mk-popup-menubutton #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc #:text-item #:mk-text-item #:rectangle #:mk-rectangle #:bitmap #:mk-bitmap #:canvas #:mk-canvas #:mk-frame-row @@ -47,7 +47,8 @@ #: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)) + #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps + #:^widget-menu #:widget-menu)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -149,13 +150,21 @@ (gridding :reader gridding :initarg :gridding :initform nil) (enabled :reader enabled :initarg :enabled :initform t) (bindings :reader bindings :initarg :bindings :initform nil) - (menus :reader menus :initarg :menus :initform nil) + (menus :reader menus :initarg :menus :initform nil + :documentation "An assoc of an arbitrary key and the associated CLOS menu instances (not their tk ids)") (image-files :reader image-files :initarg :image-files :initform nil) (selector :reader selector :initarg :selector :initform (c? (upper self selector)))) (:default-initargs :id (gentemp "W"))) +(defun widget-menu (self key) + (or (find key (^menus) :key 'md-name) + (break "The only menus I see are~{ ~a,~} not requested ~a" (mapcar 'md-name (^menus)) key))) + +(defmacro ^widget-menu (key) + `(widget-menu self ,key)) + (defmethod make-tk-instance ((self widget)) (setf (gethash (^path) (dictionary .tkw)) self) (when (tk-class self) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/26 03:40:59 1.10 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/26 14:07:15 1.11 @@ -38,7 +38,13 @@ How is programming with Celtk different from LTk? Contrast the code below with the excellent ltktest "classic" in ltk.lisp to -see how Celtk programming is different. +see how Celtk programming is different. I won't say better, because some people prefer an +imperative approach where they can have all the bricks laid out in front of them +and lay them out carefully one by one to get exactly what they want without thinking +very hard. The declarative approach makes one think a little harder but in the end +do less work. The trade-off becomes a big win for the declarative model as the +interface gets either bigger or more dynamic, such as widgets that come and go as the +user specifies different things in other widgets. Second topic: @@ -103,9 +109,13 @@ ; (tk-test-class 'ltktest-cells-inside)) -; That is all the imperative code there is to Celtk application development, aside from widget commands. Tk handles some -; of the driving imperative logic, and Celtk internals handle the rest. The application works via rules reacting to change, -; computing new state for the application model, which operates on the outside world via observers (on-change callbacks) triggered +; That is all the imperative code there is to Celtk application development, aside from widget commands, and those +; invariably (?) consist of a single setf. So where does the rest of the state change necessary to keep a GUI +; interface self-consistent get taken care of? + +; Tk handles some of the driving imperative logic -- they call the company ActiveState for a reason -- and Celtk internals +; handle the rest. The application works via Cells rules reacting to change by computing new state for the application model, +; which operates on the outside world via observers (on-change callbacks) triggered ; automatically by the Cells engine. See DEFOBSERVER. (defmodel ltktest-cells-inside (window) @@ -295,6 +305,18 @@ () (:default-initargs :id :test-canvas + :background (c? (or (selection (fm! :bkg (^menus))) + 'SystemButtonFace)) + ; + ; we are taking the demo a little further to make it a little more real world than just + ; printing to standard output. A point to make here is the decoupling of the menu from + ; its application role, namely allowing the user to specify the background color of + ; the spinning lines. The pop-up is now a radio-group menu that does not know how the + ; choice it is maintaining will be used. It simply takes care of its business of allowing + ; the user to choose exactly one color. Changes get propagated automatically by the Cells + ; engine to any slot whose rule happens to read the radio-group selection slot. And that + ; is all they have to do, read the value. No need to code "subscribe" or "notify" code. + ; :scroll-region '(0 0 500 400) :gridding "-row 0 -column 0 -sticky news" ; @@ -309,7 +331,7 @@ ; :xscrollcommand (c-in nil) ;; see canvas class for the Tk limitation behind this nonsense :yscrollcommand (c-in nil) ;; in brief, Tk lacks the concept of "late binding" on widget names - + :bindings (c? (list (list "<1>" (lambda (event) ; ; Stolen from the original. It means "when the left button is @@ -322,21 +344,33 @@ ; an observer on the bindings slot passes the needed bindings to Tk ; via the client queue. ; - (pop-up (car (^menus)) ;; (^menus) -> (menus self) + (pop-up (^widget-menu :bkg-pop) ;; (^menus) -> (menus self) (event-root-x event) (event-root-y event)))))) + :menus (c? (the-kids ; - ; here is a limitation with the declarative paradigm: pop-up menus are free to float about - ; unpacked in any parent. One just needs to remember the name of the menu widget to - ; pass it to the pop-up function. So imperative code like ltktest "classic" can just make the menus - ; saving their name in a closed-over local variable and then refer to them in a callback to pop them up. - ; - ; in the declarative paradigm we need a slot (defined for any widget or item class) in which - ; to build and store such menus. As with bindings, the nice thing again is that we find everything relative - ; to this widget specified in one place. + ; we could just build the menu in the rule above for bindings and then close over the variable + ; bearing the menu's Tk name in the binding callback in the call to pop-up, but I try to decompose + ; these things in the event that the bindings become dynamic over time (meaning the rule to generate + ; the binding list will run repeatedly) we are not forever regenerating the same pop-up menu. + ; premature optimization? well, it also makes the code clearer, and should the list of menus become + ; variable over time allows us to GC (via Tk "destroy") menus, so this is not so much about + ; optimization as it is about the Good Things that happen to well-organized code. ; + (mk-menu + :id :bkg-pop + :kids (c? (the-kids + (mk-menu-radio-group + :id :bkg + :selection (c-in nil) + :kids (c? (the-kids + (mk-menu-entry-radiobutton :label "Crimson Tide" :value "red") + (mk-menu-entry-radiobutton :label "Oak Tree Ribbon" :value "yellow") + (mk-menu-entry-radiobutton :label "Sky" :value "blue"))))))) + (mk-menu + :id :options :kids (c? (the-kids (mapcar (lambda (spec) (destructuring-bind (lbl . out$) spec From ktilton at common-lisp.net Tue Mar 28 04:02:08 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 27 Mar 2006 23:02:08 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20060328040208.794E2550CF@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv2995 Modified Files: Celtk.lisp canvas.lisp composites.lisp demos.lisp ltktest-cells-inside.lisp menu.lisp textual.lisp widgets.lisp Log Message: Wow, I changed all these? Only news is light editing of ltk-cells-inside. --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/26 14:07:15 1.11 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/28 04:02:08 1.12 @@ -23,32 +23,33 @@ (defpackage :celtk (:nicknames "CTK") (:use :common-lisp :utils-kt :cells) - + (:import-from #:ltk #:wish-stream #:*wish* #:widget-path #:read-data #:event-root-x #:event-root-y #:send-wish #:tkescape #:after #:after-cancel #:bind #:with-ltk #:do-execute #:add-callback) - + (:export - #:pop-up #:event-root-x #:event-root-y + #:pop-up #:event-root-x #:event-root-y #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget - #:mk-panedwindow + #:mk-panedwindow #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label #:selection #:selector - #:mk-checkbutton #: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 #:tk-callback #:menu #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar - #:^entry-values #:tk-eval-list #:mk-scale #:mk-popup-menubutton - #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc #:text-item #:mk-text-item - #: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 + #:mk-checkbutton #: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 #:tk-callback + #:menu #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar + #:^entry-values #:tk-eval-list #:mk-scale #:mk-popup-menubutton + #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc #:text-item #:mk-text-item + #: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)) + #:^widget-menu #:widget-menu #:tk-format-now)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -365,8 +366,7 @@ (tk-format :grouped "senddatastring [set ~a]" var) (read-data)) -(defun tk-eval-list (self form$) - (declare (ignore self)) +(defun tk-eval-list (form$) (tk-format :grouped "senddatastrings [~a]" form$) (read-data)) --- /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/24 03:46:25 1.2 +++ /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/28 04:02:08 1.3 @@ -33,7 +33,9 @@ -closeenough -confine -height (scroll-region -scrollregion) -width -xscrollincrement -yscrollincrement) (:default-initargs - :id (gentemp "CV"))) + :xscrollcommand (c-in nil) + :yscrollcommand (c-in nil) + :id (gentemp "CV"))) (deftk arc (item) () --- /project/cells/cvsroot/Celtk/composites.lisp 2006/03/24 03:46:25 1.3 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/03/28 04:02:08 1.4 @@ -75,7 +75,7 @@ (defmodel window (composite-widget) ((wish :initarg :wish :accessor wish :initform (wish-stream *wish*) - #+(or) (c? (do-execute "wish84 -name testwindow" + #+(or) (c? (do-execute "wish85 -name testwindow" nil #+not (list (format nil "-name ~s" (title$ self)))))) (ewish :initarg :ewish :accessor ewish :initform nil :cell nil) ;; vestigial? (title$ :initarg :title$ :accessor title$ --- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/25 11:32:44 1.5 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/28 04:02:08 1.6 @@ -32,6 +32,7 @@ (cells-reset 'tk-user-queue-handler) (with-ltk (:debug 0) (send-wish "proc trc2 {cb n1 n2 op} {puts \"(:callback \\\"$cb\\\" :name1 $n1 :name2 \\\"$n2\\\" :op $op)\"}") + #+notyet (send-wish "package require tile") (setf ltk:*debug-tk* nil) (with-integrity () (make-instance root-class)) @@ -199,7 +200,7 @@ (mk-popup-menubutton :id :font-face :initial-value (c? (second (^entry-values))) - :entry-values (c? (eko ("ff") (tk-eval-list self "font families")))) + :entry-values (c? (eko (nil "ff") (tk-eval-list "font families")))) (mk-scale :id :font-size :md-value (c-in 14) @@ -289,7 +290,7 @@ (defmodel font-view (frame-stack) () (:default-initargs - :md-value (c? (tk-eval-list self "font families")) + :md-value (c? (tk-eval-list "font families")) :pady 2 :padx 4 :packing-side 'left :layout-anchor 'nw --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/26 14:07:15 1.11 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/28 04:02:08 1.12 @@ -40,11 +40,10 @@ Contrast the code below with the excellent ltktest "classic" in ltk.lisp to see how Celtk programming is different. I won't say better, because some people prefer an imperative approach where they can have all the bricks laid out in front of them -and lay them out carefully one by one to get exactly what they want without thinking +and sequence them manually one by one to get exactly what they want without thinking very hard. The declarative approach makes one think a little harder but in the end -do less work. The trade-off becomes a big win for the declarative model as the -interface gets either bigger or more dynamic, such as widgets that come and go as the -user specifies different things in other widgets. +do less work as the responsibility for getting things to work falls on the engine behind +the declarative interface. Second topic: @@ -74,25 +73,27 @@ ; Unfortunately, in a declarative paradigm one does not specify in what order different ; things should happen, one just specifies the things we want to have happen. An underlying ; engine then runs around taking care of making that happen, without bothering the developer - ; about how to do that. Including in what order to make those things happen. That is - ; a big win when it works. When it did not work for Tk, and I could see the same thing - ; coming up again in other situations, I added to Cells the concept of a "client queue". + ; about how to do that. That includes deciding in what order to make those things happen. That is + ; a big win when it works. When it did not work for Tk, and I could imagine the same thing + ; coming up again in other situations (Tilton's Law: "The first time you run into something + ; is just the first time you will run into it"), I added to Cells the concept of a "client queue". ; Here client-code can store order-sensitive tasks. The client also can specify the handler for - ; that queue. This handler (or the default FIFO handler) gets called at just the right time - ; in the larger scheme of state propagation one needs for data integrity. What is that? + ; that queue, here 'tk-user-queue-handler. This handler (or the default FIFO handler) gets called + ; at just the right time in the larger scheme of state propagation one needs for + ; data integrity. What is that? ; ; Data integrity: when the overall Cells data model gets perturbed by imperative code -- typically an - ; event loop -- executing a SETF of some datapoint X, we want these requirements satisfied: + ; event loop -- executing a SETF of some datapoint X, we want these requirements met: ; ; - recompute all and only state computed off X (directly or indirectly through some intermediate datapoint); ; - ; - recomputations must see only datapoint values current with the new value of X; + ; - recomputations, when they read other datapoints, must see only values current with the new value of X; ; - ; - similarly, client observers ("on change" callbacks) must see only values current with the new value of X + ; - similarly, client observers ("on change" callbacks) must see only values current with the new value of X; and ; ; - a corollary: should a client observer SETF a datapoint Y, all the above must - ; happen with values current not just with X, but also with the value of Y /prior/ - ; to the intended change to Y. + ; happen with values current with not just X, but also with the value of Y /prior/ + ; to the change to Y. ; ; To achieve the above, Cells2 and now Cells3 have taken to using FIFO "unfinished business" queues ; to defer things until The Right Time. Which brings us back to Tk. Inspect the source of @@ -268,8 +269,7 @@ ; ; I added the :user-errors rule above to demonstrate the mechanism in action. Click ; on the entry widget and type "123abc", then delete the alpha characters. The background - ; color (as well as the File\Save menu item state) tracks the typing. (And an observer - ; chats away on standard output.) + ; color (as well as the File\Save menu item state) tracks the typing. ; (mk-button-ex ("Print" (format t "~&User wants to see ~A points" (fm^v :point-ct)))) @@ -282,19 +282,19 @@ ; keep that information. ; ; Thus each class uses md-value to hold something different, but in all cases it is - ; the current value of whatever the instance of that class is understood to hold. + ; the current value of whatever the instance of that class is understood to hold. ; (mk-button-ex ("Reset" (setf (fm^v :point-ct) "42"))) ; - ; In Ltk one would SETF (text my-entry) and the + ; Driving home this point again, in Ltk one would SETF (text my-entry) and the ; SETF method would communicate with Tk to make the change to the Tk widget -text ; configuration. In Celtk, the md-value slot of the entry gets changed (possibly ; triggering other slots to update, which is why we do not just talk to Tk) and ; then that value gets propagated to Tk via "set ". Because ; the textVariable for every entry is the entry itself, the text of the entry ; then changes. If that sounds weird, what we are actually doing is tapping into - ; Tk to a large degree taking the same approach as Cells does with the md-value - ; slot: in Cells, we think of model instances as wrapping some model-specific + ; the fact that Tk to a large degree takes the same approach as Cells does with md-value: + ; in Cells, we think of model instances as wrapping some model-specific ; value, which is held in the md-value slot of the model instance. Tk simply ; allows a widget path to be a global variable. Furthermore, as the company name ; ActiveState suggests, Tk also provides automatic propagation: change the @@ -314,8 +314,9 @@ ; the spinning lines. The pop-up is now a radio-group menu that does not know how the ; choice it is maintaining will be used. It simply takes care of its business of allowing ; the user to choose exactly one color. Changes get propagated automatically by the Cells - ; engine to any slot whose rule happens to read the radio-group selection slot. And that - ; is all they have to do, read the value. No need to code "subscribe" or "notify" code. + ; engine to any slot whose rule happens to read the radio-group selection slot. And the coding + ; is transparent: just read the value. No need to write explicit code to subscribe, notify, + ; or unsubscribe. ; :scroll-region '(0 0 500 400) :gridding "-row 0 -column 0 -sticky news" @@ -328,25 +329,23 @@ ; ; This also simplifies Celtk since it just has to pass the Tk code along with "grid " ; appended. - ; - :xscrollcommand (c-in nil) ;; see canvas class for the Tk limitation behind this nonsense - :yscrollcommand (c-in nil) ;; in brief, Tk lacks the concept of "late binding" on widget names - - :bindings (c? (list (list "<1>" (lambda (event) - ; - ; Stolen from the original. It means "when the left button is - ; pressed on this widget, popup this menu where the button was pressed" - ; The only difference is that here we get to specify this along with - ; the rest of the configuration of this instance, whereas in the original - ; the enabling code was just "out there" in a long sequence of other - ; imperatives setting up this widget and that. ie, It is nice having - ; everything about X collected in one place. In case you are wondering, - ; an observer on the bindings slot passes the needed bindings to Tk - ; via the client queue. - ; - (pop-up (^widget-menu :bkg-pop) ;; (^menus) -> (menus self) - (event-root-x event) - (event-root-y event)))))) + ; + :bindings (c? (list + (list "<1>" (lambda (event) + ; + ; Stolen from the original. It means "when the left button is + ; pressed on this widget, popup this menu where the button was pressed" + ; The only difference is that here we get to specify this along with + ; the rest of the configuration of this instance, whereas in the original + ; the enabling code was just "out there" in a long sequence of other + ; imperatives setting up this widget and that. ie, It is nice having + ; everything about X collected in one place. In case you are wondering, + ; an observer on the bindings slot passes the needed bindings to Tk + ; via the client queue. + ; + (pop-up (^widget-menu :bkg-pop) ;; (^menus) -> (menus self) + (event-root-x event) + (event-root-y event)))))) :menus (c? (the-kids ; @@ -356,32 +355,19 @@ ; the binding list will run repeatedly) we are not forever regenerating the same pop-up menu. ; premature optimization? well, it also makes the code clearer, and should the list of menus become ; variable over time allows us to GC (via Tk "destroy") menus, so this is not so much about - ; optimization as it is about the Good Things that happen to well-organized code. + ; optimization as it is about Good Things happening to well-organized code. ; (mk-menu :id :bkg-pop :kids (c? (the-kids (mk-menu-radio-group :id :bkg - :selection (c-in nil) + :selection (c-in nil) ;; this will start us off with the Tk default :kids (c? (the-kids (mk-menu-entry-radiobutton :label "Crimson Tide" :value "red") (mk-menu-entry-radiobutton :label "Oak Tree Ribbon" :value "yellow") - (mk-menu-entry-radiobutton :label "Sky" :value "blue"))))))) - - (mk-menu - :id :options - :kids (c? (the-kids - (mapcar (lambda (spec) - (destructuring-bind (lbl . out$) spec - (mk-menu-entry-command - :label lbl - :command (c? (tk-callback .tkw (gentemp "MNU") - (lambda () - (format t "~&~a" out$))))))) - (list (cons "Option 1" "Popup 1") - (cons "Option 2" "Popup 2") - (cons "Option 3" "Popup 3")))))))) + (mk-menu-entry-radiobutton :label "Sky" :value 'blue) + (mk-menu-entry-radiobutton :label "Factory" :value 'SystemButtonFace))))))))) :kids (c? (the-kids (mk-text-item @@ -437,25 +423,14 @@ (mk-menubar :kids (c? (the-kids (mk-menu-entry-cascade-ex (:label "File") - (mk-menu-entry-command :label "Load" - :command (c? (tk-callback .tkw 'load - (lambda () (format t "~&Load pressed"))))) - - (mk-menu-entry-command :label "Save" - :state (c? (if (user-errors (fm^ :point-ct)) - :disabled :normal)) - :command (c? (tk-callback .tkw 'save - (lambda () (format t "~&Save pressed"))))) + (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) + (mk-menu-entry-command-ex (:state (c? (if (user-errors (fm^ :point-ct)) + :disabled :normal))) + "Save" (format t "~&Save pressed")) (mk-menu-entry-separator) (mk-menu-entry-cascade-ex (:id :export :label "Export...") - (mk-menu-entry-command - :label "jpeg" - :command (c? (tk-callback .tkw 'jpeg - (lambda () (format t "~&Jpeg pressed"))))) - (mk-menu-entry-command - :label "png" - :command (c? (tk-callback .tkw 'png - (lambda () (format t "~&Png pressed")))))) + (mk-menu-entry-command-ex () "jpeg" (format t "~&Jpeg pressed")) + (mk-menu-entry-command-ex () "png" (format t "~&Png pressed"))) (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" :accelerator "Alt-q" --- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/24 03:46:25 1.5 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/28 04:02:08 1.6 @@ -171,6 +171,14 @@ () (:tk-spec command -command)) +(defmacro mk-menu-entry-command-ex ((&rest menu-command-initargs) lbl callback-body) + `(mk-menu-entry-command + , at menu-command-initargs + :label ,lbl + :command (c? (tk-callback .tkw (gentemp "MNU") + (lambda () + ,callback-body))))) + (deftk menu-entry-button (menu-entry-command) () (:tk-spec command --- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/24 03:46:25 1.4 +++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/28 04:02:08 1.5 @@ -69,6 +69,7 @@ -validate -validatecommand -width ) (:default-initargs :id (gentemp "ENT") + :xscrollcommand (c-in nil) :textvariable (c? (^path)) :md-value (c-in ""))) @@ -110,6 +111,8 @@ (:default-initargs :id (gentemp "TXT") :md-value (c-in "") + :xscrollcommand (c-in nil) + :yscrollcommand (c-in nil) :modified (c-in nil) :bindings (c? (list (list "<>" (format nil "{callback ~~a}" (^path)) --- /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/24 03:46:25 1.3 +++ /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/28 04:02:08 1.4 @@ -120,6 +120,8 @@ :id (gentemp "SCL") :md-value (c-in nil) :tk-variable nil ;;(c? (^path)) + :xscrollcommand (c-in nil) + :yscrollcommand (c-in nil) :command (c? (tk-callbackval self 'scale-set (lambda (&rest args) (declare (ignore id)) @@ -143,6 +145,8 @@ -takefocus -width -xscrollcommand -yscrollcommand) (:default-initargs :id (gentemp "LBX") + :xscrollcommand (c-in nil) + :yscrollcommand (c-in nil) :bindings (c? (when (selector self) ;; if not? Figure out how listbox tracks own selection (list (list "<>" (format nil "{callbackval ~~a [~a curselection]}" (^path)) @@ -186,6 +190,7 @@ :md-value (c-in nil) :id (gentemp "SPN") :textVariable (c? (^path)) + :xscrollcommand (c-in nil) :command (c? (tk-callbackstring-x self 'vmirror "%s" ;;;(tk-callback self 'vcmd (lambda (text)