cells-cvs

cells-cvs@common-lisp.net

721 discussions

[cells-cvs] CVS update: cell-cultures/cello/jans.lisp
by Kenny Tilton 15 Jul '04

15 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv12754/cello Removed Files: jans.lisp Log Message: Date: Thu Jul 15 03:28:35 2004 Author: ktilton

1 0

[cells-cvs] CVS update: cell-cultures/install-notes.txt
by Kenny Tilton 09 Jul '04

09 Jul '04

Update of /project/cells/cvsroot/cell-cultures In directory common-lisp.net:/tmp/cvs-serv14181 Modified Files: install-notes.txt Log Message: Date: Thu Jul 8 20:53:05 2004 Author: ktilton Index: cell-cultures/install-notes.txt diff -u cell-cultures/install-notes.txt:1.1 cell-cultures/install-notes.txt:1.2 --- cell-cultures/install-notes.txt:1.1 Sat Jun 26 11:38:32 2004 +++ cell-cultures/install-notes.txt Thu Jul 8 20:53:05 2004 @@ -1,137 +1,26 @@ -PortaCello4 (this release) was meant to be a maintenance release. Instead, here is what is new: +Kenny Tilton +July 6, 20004 -- destudlification: I wrote a program to assist in a semi-automatic conversion of all studlyCap occurrences to studly-cap. But it was also semi-manual, so do not fall over dead if something snuck through. It at least seems as if I did not introduce any bugs doing this. +This CVS release inaugurates the collection of all my Cells-related code under one CVS project (./cells/cell-cultures), in turn under one common-lisp.net project, Cells. From now on the Cello project under common-lisp.net is quiesced, tho the web page is still informative and fun screen shots can be found in the FTP area. -- OpenAL: Play back wav files in 3D. Not sure if other formats are accessible. The bindings are in cl-openal, and Cello has a very rough framework to make it easier to easily associate sounds with the action. But that is really awful, just enough to get the app to make sound. Sometimes. When it works. +This release also introduces two significant new code releases. First, a substantial reworking of Cell internals known informally as Cells II. Second, Celtic, a derived work of Peter Herth's LTk project marrying Common Lisp and TCl/Tk. Celtic adds Cells to the mix (and deviates wildly from LTk so cannot be combined with that. -- zoom zoom zoom: Cello now makes maximum use of OpenGL display list optimizations, and I am seeing roughly 400% higher frame rates as a result. Every node inthe visual framework gets its own display list. These get refreshed bottom up when any element needs to change how it gets drawn, so a parent, when it comes time to redraw itself, can simply call the display list of its children. Later on, if a child changes, that is the only display list which needs to be redefined to OpenGL; when the parent renders, the new definition of the child display list gets picked up. In the end, the most complex window can be redrawn with nothing more than one gl-call-list call, on the window's display list. +A third subproject (a directory, in fact), Clyde (derived from "CL IDE") currently just contains a GUI wrapper for the CL apropos-list function, but could soon see a port of ClouCell, currently a Cello-based graphical object inspector. -- FTGL problems: unfortunately, the display list stuff has created some problems. I would fix them but I have to drop Cello for a couple of weeks and I did not want to hold up the release. Various issues: +Several other subprojects offer utilities required by most Cell projects. ASDF-ACLPROJ is Thomas Burdick's creation, which teaches ASDF about AllegroCL project files (their home-brewed defsystem). I use AllegroCL and cannot be trusted to keep parallel ASDF definition files current with the ACL project files. UTILS-KT is just what it looks like, very low-level stuff I use everywhere. FFI-EXTENDER makes it easier for me to whip up FFI bindings using UFFI (which, btw, you will also need). ---- Select the shape called "Cello" in the light panel demo, which shows the word "Cello" in extruded type. Ahem. It actually shows "ello". +Pure binding subprojects are functional as far as they go, but are usually incomplete because I punt when they get hard, until I need the challenging bindings. These include: ---- Clicking on different shapes in the light panel demo, individual letters start disappearing from words in that list and the "Backdrops" list!! +cl-opengl -- OpenGL. +cl-openal -- bindings to OpenAL. Think "OpenGL for audio". +cl-ftgl -- FTGL, FreeType for OpenGL +cl-magick -- ImageMagick, for image files such as JPG, and vector or bitmapped graphics. ---- Select the ft-jpg test. It runs at like one frame per second. resize the window one pixel and it jumps to 40-50 fps. Go figure. +That just leaves Cello, the OpenGL/Freeglut-based CL GUI. Where LTk and Celtic offer simpler, higher-level (but still powerful), and native GUIs, Cello is Lisp all the way down and offers terrific graphical power thx to direct OpenGL capabilities accelerated by hardware GPUs. ---- Select the ftgl-test demo. Better yet, don't. It will take forever to open, and then be almost completely unresponsive. resize the window and frame rates climb at least to 8-10fps. +Installing +---------- +1. A rough first attempt has been made at making various pathnames used by the code easy to live with. CONFIG.LISP at the top level of the CELL-CULTURES hierarchy has a single *devel-root* global to be configured to your install location. The subdirectory CONFIG contains other *-config.lisp files you might need to visit, especially if you tackle a Cello install. Celtik is blessedly more simple in this as well as other regards. ---- resizing works because I force all display lists to be regenerated on a resize. This makes resizing a window pretty slow, since it causes a ton of work to be done every frame as the mouse is dragged around. So why resize? That does not change the way most things need to be drawn. Answer: OpenGL clipping does not play well with display lists, because unlike the rest of OpenGL clipping gets recorded in global coordinates. It's a long story. I have a fix in mind, tho. RSN. +2. Other than that, each subdirectory has its own AllegroCL project and ASD files. Go for it, and holler if something will not build. -;----------------------------------------------------------------- - -Portacello3 was a first, rough stab at a livable directory structure for Cello. -But it is rough, and will not get less so until a few people try to install -and report back to the cello-devel list with problems and/or suggestions. That said, I have had good luck relocating the project on my own system and rebuilding with no more than a change to "cello-devel-root* in configure.lisp. - -The objective I have is to separate configuration from the source tree, -so you could tweak them once to fit your environment and then forget them even -after grabbing a new distro. But I also wanted to keep application code inside -the source tree to simplify future revisions. - -It turned out a little weird: a root configuration.lisp file -sets the *cello-config-directory*. Application source such as cl-magick.lisp -uses *cello-config-directory* to load cl-magick-config.lisp once the cl-magick -package has been defined. A simpler approach was tried but seemed icky. We -will see. - -This release is a phat one to set the environment, but future releases will be -of just the Cello directory. I /think/ I built in enough flexibility so that you can -tweak once for a different directory structure and then not worry about redoing -that every time there is a new release. - -This release contains asdf.lisp as well as UFFI. You may already have those. If -so, they are fine, the ones here are vanilla. - ------------- ALERT ------------------------------------------------------------ -This distro contains the Cells source. Use this version, not anything you might -have from the Cells project. Not sure yet, but I am leaning towards merging the -two projects. If I do, it will still be possible to grab just Cells. -------------------------------------------------------------------------------- - ------------- THANKS ----------------------------------------------------------- -...to David Steuber for mandelbrot3.gif, which looks smashing when used as a -texture for just about anything. -------------------------------------------------------------------------------- - ------------- LINUX ------------------------------------------------------------ -I think I pulled in Frank's code for the Linux port, but I just featured it out -and went with the configuration.lisp-based stuff for ACL/win32. I have suggested -Frank's fine job of loading cooperating .SOs be contributed to UFFI so Cello code -can just say "load-library". Stay tuned. -------------------------------------------------------------------------------- - ------------- WARNING ---------------------------------------------------------- -ASDF files are suspect for anything other than a full build. In some places I -cured this by bogusly declaring each file dependent on its predecessor. In other -places you may find that modifying files at random, then exiting and coming back -in will cause compiler errors when ASDF tries recompiling just the changed files. -Unfortunately, at this point I do not use ASDF for day to day work, so they do -not get much attention, and when porting to Lispworks/win32 (where I do use ASDF) -I just set d-force to t to force full builds if I have any such problems. --------------------------------------------------------------------------------- - ------------ BIG PROBLEM -------------------------------------------------------- -Libraries. For win32, the PC4 release includes the DLLs I use (well, except those you should find in /windows/system32). Linux/Mac OS X really have their work cut out for them. Building Freeglut and ImageMagick (and FreeType) may just work for you as typical Linux installs, but FTGL as I have done it requires to build with the included FTGLFromC.cpp and a modified FTGLExtrdFont.h built into the library .SO. -------------------------------------------------------------------------------- - - -Step #1 -------- -Unzip into any directory. The distro includes win32 DLLs, -so Linux folk can skip those. - -Step #2 -------- -Edit configure.lisp, tweak as necessary - -Step #3 -------- -Open build.lisp. - -Get ASDF (if necessary) and build-sys-kt.lisp loaded. - -Work your way down the top-level forms evaluating them in turn. Comment out the line about -UFFI if you already have that. - -lesson-14 is optional, but will let you know if you have the Glut and -OpenGL working, including callbacks from C into Lisp. - -Step #4 -------- -Cello-test. Hope it works. If so, the FTGL test takes a long time to come up, -maybe six seconds on my 3ghz screamer, because it is loading every TTF font on -my system (150?) and building a widget for it. - -The light panel is the fun one. The cone is the best place to see photographic textures, -and the torus is a good one, too. Play with the lighting controls to see what they do. -And as you change from shape to shape, play with the options for each, such as -"slices" and "stacks". The torus is a lot of fun for that. To understand what -is going on, set "wireframe" on. - -The prettiest pictures come from "sphere","repeat", and one of the photographic textures. -The torus and "Cello" shapes are good here. - -If you see one you like, hit the "snapshot" button on the "just shoot me" widget. -It will write out a PNG in the "out" directory. I have no -idea where I left things on the "record" button. It will probably crash. - -If sound is working, you will hear a short riff when the window opens, a little bleep when you operate any of the color controls, and with luck a cool sound if you hit ESCAPE to close a window (worked under AllegroCL, not Lispworks). - -Crashing --------- -Lisp is hard to kill, and so can be the Glut. It seems to have gotten better under AllegroCL. The old nightmare is described next. Now I can click debug and/or abort, tho the Cello window will not go away until it I move the mouse over it. On Lispworks it does not go away. I can run again and get a second window, but the third or fourth time Lispworks gets upset. I spent exactly zero seconds trying to figure out how to fix this, so hopefully anyone wanting to use Lispworks in anger will be able to figure something out. - -Old nightmare: "Under AllegroCL on win32, when I get a -backtrace I can not always just click debug or abort. I have learned to click first on -any IDE window, and /then/ debug or abort. In the worst cases I have to get to the -listener and evaluate (c-stop t), then try again to abort, and sometimes it takes a few -aborts. In the very worst case I have to kill AllegroCL, but fortunately this does not -happen very often. On Lispworks I had worse luck keeping LW going in the face of -backtraces, but I imagine that with a little elbow grease (and LW expertise, which -I lack utterly) the problem could be resolved." - - Needless to say, I do view anything interfering with iterative Lisp developemtn as a show-stopper, so if anyone gets serious about Cello under a different implementation I'll help with what I know to get crashing under control. - -kenny -4/17/2004 \ No newline at end of file

1 0

[cells-cvs] CVS update: cell-cultures/clyde/visual-apropos/visual-apropos.lisp
by Kenny Tilton 09 Jul '04

09 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde/visual-apropos In directory common-lisp.net:/tmp/cvs-serv14181/clyde/visual-apropos Modified Files: visual-apropos.lisp Log Message: Date: Thu Jul 8 20:53:05 2004 Author: ktilton Index: cell-cultures/clyde/visual-apropos/visual-apropos.lisp diff -u cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.3 cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.4 --- cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.3 Tue Jul 6 18:25:41 2004 +++ cell-cultures/clyde/visual-apropos/visual-apropos.lisp Thu Jul 8 20:53:05 2004 @@ -41,13 +41,13 @@ :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") :kids (c? (list (search-for-symbol) - (frame-row + (mk-frame-row :padx 8 :layout (pack-layout? "-side left -fill x") :kids (c? (list - (frame-stack + (mk-frame-stack :kids (c? (list - (checkbutton :md-name :exported-only + (mk-checkbutton :md-name :exported-only :text "Exported Only" :underline 1 :md-value (c-in nil) @@ -58,7 +58,7 @@ (symbol-list))))) (defun search-for-symbol () - (frame-row + (mk-frame-row :relief 'ridge :padx 8 :layout (pack-layout? "-side left -fill x -anchor nw") @@ -67,12 +67,12 @@ (path (kid1 self)) (path (second (^kids))) (path (third (^kids))))) - :kids (c? (list (label :text "String:" + :kids (c? (list (mk-label :text "String:" :underline 4) - (entry :md-name :search-string + (mk-entry :md-name :search-string :text (c? (symbol-name (sub-symbol (upper self visual-apropos)))) :width 64) - (button :text "Search" + (mk-button :text "Search" :underline 0 :command (lambda (self) (setf (symbols (upper self visual-apropos)) @@ -81,17 +81,15 @@ ; --- symbol package filtering ------------------------------- (defun package-filtering () - (labelframe-row - :text " Package(s) to Search " + (mk-labelframe-row + :text "Package(s) to Search" :layout (pack-layout? "-side left -fill x -expand 1") :kids (c? (list - (checkbutton :md-name :all-pkgs + (mk-checkbutton :md-name :all-pkgs :text "All" :underline 1 - :md-value (c-in t) - :command (lambda (self) - (setf (^md-value) (not (^md-value))))) - (scrolled-list + :md-value (c-in t)) + (mk-scrolled-list :md-name :in-package :list-height 4 :layout (pack-layout? "-side left -fill x -expand 1") @@ -106,9 +104,9 @@ ; --- symbol binding filtering --------------------------------------- (defun show-which-symbols () - (labelframe-selector + (mk-labelframe-selector :md-name :which-symbols - :text " With bindings " + :text "With bindings to" :tk-variable 'which-symbols :layout (c? (format nil "pack ~a -side {left}~:{; grid ~a -column ~d -row ~d -sticky w~}" (path self) (mapcar (lambda (k) @@ -117,7 +115,7 @@ (^kids)))) :selection (c-in :any) :kids (c? (flet ((rb (n) - (radiobutton :md-name n + (mk-radiobutton :md-name n :text (string-capitalize (string n)) :tk-variable (tk-variable self) :value n @@ -126,12 +124,12 @@ (list (rb :any)(rb :functions)(rb :variables)(rb :classes)))))) (defun symbol-list () - (frame-stack :md-name :symbol-list + (mk-frame-stack :md-name :symbol-list :layout (pack-layout? "-side top -expand 1 -fill both") :width 64 :background 'red :kids (c? (list - (frame-row + (mk-frame-row :md-name :sym-sort :md-value (c-in nil) :relief 'groove @@ -151,7 +149,7 @@ (va-button :layout nil :text "Var" :padx 5) (va-button :layout nil :text "Class") (va-button :layout nil :text "Exp"))))) - (scrolled-list + (mk-scrolled-list :layout (pack-layout? "-side top -expand 1 -fill both") :width 64 :list-height nil

1 0

[cells-cvs] CVS update: cell-cultures/celtic/callback.lisp cell-cultures/celtic/demos.lisp cell-cultures/celtic/button.lisp cell-cultures/celtic/celtic.lisp cell-cultures/celtic/celtic.lpr cell-cultures/celtic/frame.lisp cell-cultures/celtic/menu.lisp cell-cultures/celtic/scrolling.lisp cell-cultures/celtic/textual.lisp cell-cultures/celtic/widget-item.lisp
by Kenny Tilton 09 Jul '04

09 Jul '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv14181/celtic Modified Files: button.lisp celtic.lisp celtic.lpr frame.lisp menu.lisp scrolling.lisp textual.lisp widget-item.lisp Added Files: callback.lisp demos.lisp Log Message: Date: Thu Jul 8 20:53:05 2004 Author: ktilton Index: cell-cultures/celtic/button.lisp diff -u cell-cultures/celtic/button.lisp:1.4 cell-cultures/celtic/button.lisp:1.5 --- cell-cultures/celtic/button.lisp:1.4 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/button.lisp Thu Jul 8 20:53:05 2004 @@ -21,8 +21,6 @@ (in-package :celtic) - - ;-------------------------------------------------------------------------- (def-widget button () @@ -35,16 +33,6 @@ (-command nil) -compound -default -height -overrelief -state -width)) -(defun test-button () - (make-be 'button :text (format nil "Time is ~a" (get-internal-real-time)) - :width 48 - :borderwidth 4 - :underline 2 - :font "Courier")) - -; --------------------------------------------------- -; http://tmml.sourceforge.net/doc/tk/checkbutton.html -; (def-widget checkbutton () () (-activebackground -activeforeground -anchor -background @@ -56,12 +44,15 @@ (-command nil) -height -indicatoron -offrelief -offvalue -onvalue -overrelief -selectcolor -selectimage -state -tristateimage - -tristatevalue (-tk-variable -variable) -width)) + -tristatevalue (-tk-variable -variable) -width) + (:default-initargs + :command (lambda (self) + (setf (^md-value) (not (^md-value)))))) (def-c-output .md-value ((self checkbutton)) - (tk-send (format nil "set ~a ~a" - (down$ (md-name self)) - (if new-value 1 0)))) + (tk-format "set ~a ~a" + (down$ (md-name self)) + (if new-value 1 0))) (def-widget radiobutton () () @@ -79,4 +70,53 @@ :command (lambda (self) (setf (selection (upper self selector)) (value self))))) + +(def-widget scale () + () + (-activebackground -background -borderwidth -cursor + -font -foreground -highlightbackground -highlightcolor + -highlightthickness -orient -relief -repeatdelay + -repeatinterval -takefocus -troughcolor + -bigincrement (-command nil) -digits -from + (-tk-label -label) (-tk-length -length) -resolution + -showvalue -sliderlength -sliderrelief + -state -tickinterval -to (-tk-variable -variable) -width) + (:default-initargs + :md-value (c-in nil) + :command (lambda (self) + (setf (^md-value) (tk-eval (format nil "~a get" (^path))))))) + +(def-c-output .md-value ((self scale)) + (when new-value + (if (listp new-value) + (tk-format "set ~a {~{~a~^ ~}}" (^path) new-value) + (tk-format "~a set ~a" (^path) new-value)))) + +(def-widget spinbox () + () + (-activebackground -background -borderwidth -cursor + -exportselection -font -foreground -highlightbackground + -highlightcolor -highlightthickness -insertbackground -insertborderwidth + -insertofftime -insertontime -insertwidth -justify + -relief -repeatdelay -repeatinterval -selectbackground + -selectborderwidth -selectforeground -takefocus -textvariable + -xscrollcommand + -buttonbackground -buttoncursor -buttondownrelief + -buttonuprelief + (-command nil) -disabledbackground -disabledforeground + (-spinbox-format -format) -from -invalidcommand -increment + -readonlybackground -state -to -validate + -validatecommand (-tk-values -values) -width -wrap) + (:default-initargs + :md-value (c-in nil) + :command (lambda (self) + (setf (^md-value) + (eko ("spinbox value now" self) + (tk-eval-list (format nil "~a get" (^path)))))))) + +(def-c-output .md-value ((self spinbox)) + (when new-value + (if (listp new-value) + (tk-format "set ~a {~{~a~^ ~}}" (^path) new-value) + (tk-format "~a set ~a" (^path) new-value)))) Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.4 cell-cultures/celtic/celtic.lisp:1.5 --- cell-cultures/celtic/celtic.lisp:1.4 Mon Jul 5 12:29:30 2004 +++ cell-cultures/celtic/celtic.lisp Thu Jul 8 20:53:05 2004 @@ -87,9 +87,12 @@ (defun tk-start () (setf *w* (do-execute "wish" '("-name" "Visual Apropos")))) +(defun tk-format (fmt$ &rest args) + (tk-send (apply 'format nil fmt$ args))) + (defun tk-send (text) "send a string to wish" - (when nil ;; (search "pack " text) ;; *debug-tk* + (when t ;(search "font-face" text) ;; *debug-tk* (format t "~&tk-send> ~A~%" text) (force-output)) (format *w* "~A~%" text) @@ -102,48 +105,9 @@ #+:lispworks (setf c (string-right-trim '(#\Newline #\Return #\Linefeed) c)) c)) - -;;; tcl -> lisp: puts "$x" mit \ und " escaped -;;; puts [regsub {"} [regsub {\\} $x {\\\\}] {\"}] - -;;; call to convert untility (defun convert(from to) (close (do-execute "convert" (list from to) t))) -;;; table used for callback every callback consists of a name of a widget and -;;; a function to call - -(defvar *callbacks* (make-hash-table :test #'equal)) - -(defun register-callback (self callback-id fun - &aux (id (widget-callback-id self callback-id))) - ;;(format t "~&object ~a registering callback ~a: ~A" self :id id) - (setf (gethash id *callbacks*) (cons fun self))) - -(defun widget-callback-id (self callback-id) - (conc$ (path self) "." (down$ callback-id))) - -(defun dispatch-callback(sym args) - (let ((func-self (gethash sym *callbacks*))) - ;(format t "sym:~S fun:~A~%" sym func-self) - (force-output) - (when (not func-self) - (format t "~&callback ~a, type ~a, pkg ~a, not found. known callbacks:" - sym (type-of sym) (when (typep sym 'symbol) (symbol-package sym))) - (maphash (lambda (key func-self) - (declare (ignore func-self)) - (format t "~&known callback key ~a, type ~a, pkg ~a" - key (type-of key)(when (typep key 'symbol) (symbol-package key)))) - *callbacks*)) - (when (car func-self) - (apply (car func-self) (cdr func-self) args)))) - -(defun after (self time func) - "Usage: (after self <time> <func>)) ...after <time> msec call function <func>" - (register-callback self "after" func) - (tk-send (format nil "after ~a {puts -nonewline {(\"~A\") };flush stdout}" - time (widget-callback-id self "after")))) - ;; tool functions used by the objects ;; incremental counter to create unique numbers @@ -167,19 +131,14 @@ (let ((*exit-mainloop* nil) (*read-eval* nil)) ;;safety against malicious clients (loop - (let ((msg (read-preserving-whitespace *w* nil nil) - #+not (progn - (trc "sitting on mainloop read") - (tk-read)))) + (let ((msg (read-preserving-whitespace *w* nil nil))) (when (null msg) (return)) - (when *debug-tk* - (format t "~&msg:~A<=~%" msg) - (force-output)) (if (consp msg) (progn - (trc nil "dispatching callback" msg) - (dispatch-callback (first msg) (rest msg))) + (assert (eql 'callback (first msg))) + (trc "mainloop dispatching callback" msg) + (dispatch-callback (rest msg))) (let ((emsg (read-line *w* nil nil))) (trc "error msg:" msg emsg))) @@ -196,19 +155,19 @@ (defgeneric grid-columnconfigure (w c o v)) (defmethod grid-columnconfigure (widget column option value) - (tk-send (format nil "grid columnconfigure ~a ~a -~a {~a}" (path widget) column option value))) + (tk-format "grid columnconfigure ~a ~a -~a {~a}" (path widget) column option value)) (defgeneric grid-rowconfigure (w r o v)) (defmethod grid-rowconfigure (widget row option value) - (tk-send (format nil "grid rowconfigure ~a ~a -~a {~a}" (path widget) row option value))) + (tk-format "grid rowconfigure ~a ~a -~a {~a}" (path widget) row option value)) (defgeneric grid-configure (w o v)) (defmethod grid-configure (widget option value) - (tk-send (format nil "grid configure ~a -~a {~a}" (path widget) option value))) + (tk-format "grid configure ~a -~a {~a}" (path widget) option value)) (defun tk-test (fn) (let ((*debug-tk* nil) - (*callbacks* (make-hash-table :test #'equal))) + (*callbacks* (make-hash-table))) (cell-reset) (tk-start) (let ((*tk-root* (funcall fn))) Index: cell-cultures/celtic/celtic.lpr diff -u cell-cultures/celtic/celtic.lpr:1.3 cell-cultures/celtic/celtic.lpr:1.4 --- cell-cultures/celtic/celtic.lpr:1.3 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/celtic.lpr Thu Jul 8 20:53:05 2004 @@ -13,7 +13,9 @@ (make-instance 'module :name "textual.lisp") (make-instance 'module :name "button.lisp") (make-instance 'module :name "menu.lisp") - (make-instance 'module :name "scrolling.lisp")) + (make-instance 'module :name "scrolling.lisp") + (make-instance 'module :name "demos.lisp") + (make-instance 'module :name "callback.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells")) :libraries nil Index: cell-cultures/celtic/frame.lisp diff -u cell-cultures/celtic/frame.lisp:1.4 cell-cultures/celtic/frame.lisp:1.5 --- cell-cultures/celtic/frame.lisp:1.4 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/frame.lisp Thu Jul 8 20:53:05 2004 @@ -67,9 +67,9 @@ (def-c-output selection () (when new-value - (tk-send (format nil "set ~a ~a" - (down$ (tk-variable self)) - (down$ (md-name new-value)))))) + (tk-format "set ~a ~a" + (down$ (tk-variable self)) + (down$ (md-name new-value))))) ;--- f r a m e -------------------------------------------------- @@ -81,15 +81,15 @@ -colormap -container -height -visual -width)) (defmodel frame-selector (selector frame)()) -(defun frame-selector (&rest init-args) +(defun mk-frame-selector (&rest init-args) (apply 'make-instance 'frame-selector init-args)) (defmodel frame-stack (stack-mixin frame-selector)()) -(defun frame-stack (&rest init-args) +(defun mk-frame-stack (&rest init-args) (apply 'make-instance 'frame-stack init-args)) (defmodel frame-row (row-mixin frame-selector)()) -(defun frame-row (&rest init-args) +(defun mk-frame-row (&rest init-args) (apply 'make-instance 'frame-row init-args)) @@ -103,13 +103,43 @@ -text -labelanchor -labelwidget)) (defmodel labelframe-selector (selector labelframe)()) -(defun labelframe-selector (&rest init-args) +(defun mk-labelframe-selector (&rest init-args) (apply 'make-instance 'labelframe-selector init-args)) (defmodel labelframe-stack (stack-mixin labelframe-selector)()) -(defun labelframe-stack (&rest init-args) +(defun mk-labelframe-stack (&rest init-args) (apply 'make-instance 'labelframe-stack init-args)) (defmodel labelframe-row (row-mixin labelframe-selector)()) -(defun labelframe-row (&rest init-args) +(defun mk-labelframe-row (&rest init-args) (apply 'make-instance 'labelframe-row init-args)) + +;---- panedwindow ----------------------------------- + +(def-widget panedwindow (:std-factory nil) + () + (-background -borderwidth -cursor -height + -orient -relief -width + -handlepad + -handlesize + -opaqueresize + -sashcursor + -sashpad + -sashrelief + -sashwidth + -showhandle) + (:default-initargs + :layout nil)) + +(defmethod make-tk-instance ((self panedwindow)) + (tk-format "panedwindow ~a -orient ~(~a~)" + (^path) (or (orient self) "vertical")) + (tk-format "pack ~a -expand yes -fill both" (^path))) + +(defmethod parent-path ((self panedwindow)) (^path)) + +(defmethod md-awaken :after ((self panedwindow)) + (with-integrity (:panedwindow :finalize self) + (loop for k in (^kids) + do (tk-format "~a add ~a" (^path) (path k))))) + Index: cell-cultures/celtic/menu.lisp diff -u cell-cultures/celtic/menu.lisp:1.2 cell-cultures/celtic/menu.lisp:1.3 --- cell-cultures/celtic/menu.lisp:1.2 Tue Jul 6 18:25:41 2004 +++ cell-cultures/celtic/menu.lisp Thu Jul 8 20:53:05 2004 @@ -63,29 +63,21 @@ :initform (c? (format nil "~a" (^md-value)))))) (defmethod make-tk-instance ((self listbox-item)) - (tk-send (format nil "~A insert end ~s" - (path .parent) - (^item-text)))) + (tk-format "~A insert end ~s" + (path .parent) + (^item-text))) (def-c-output .kids ((self listbox)) (when old-value - (tk-send (format nil "~A delete ~a ~a" - (^path) - 0 (1- (length old-value)))))) + (tk-format "~A delete ~a ~a" + (^path) + 0 (1- (length old-value))))) (defmethod listbox-get-selection ((l listbox)) (tk-send (format nil "puts -nonewline {(};puts -nonewline [~a curselection];puts {)};flush stdout" (path l))) (read *w*)) - -(defmethod tk-eval (form$) - (tk-send - (format nil "puts -nonewline {(};puts -nonewline [~a];puts {)};flush stdout" - form$)) - (loop for value = (read *w* nil :eof) - While (not (eq value :eof)) - collecting value)) Index: cell-cultures/celtic/scrolling.lisp diff -u cell-cultures/celtic/scrolling.lisp:1.2 cell-cultures/celtic/scrolling.lisp:1.3 --- cell-cultures/celtic/scrolling.lisp:1.2 Tue Jul 6 18:25:41 2004 +++ cell-cultures/celtic/scrolling.lisp Thu Jul 8 20:53:05 2004 @@ -36,19 +36,19 @@ (:default-initargs :list-height (c? (max 1 (length (^list-item-keys)))) :kids (c? (the-kids - (listbox :md-name :list + (mk-listbox :md-name :list :kids (c? (mapcar (list-item-factory .parent) (list-item-keys .parent))) - :font "courier 9" + :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))) :yscrollcommand (c? (when (enabled .parent) (format nil "~a set" (path (nsib)))))) - (scrollbar :md-name :vscroll + (mk-scrollbar :md-name :vscroll :layout (c? (format nil "pack ~a -side right -fill y" (^path))) :command (c? (format nil "~a yview" (path (psib)))) :command-is-callback nil))))) -(defun scrolled-list (&rest inits) +(defun mk-scrolled-list (&rest inits) (apply 'make-instance 'scrolled-list inits)) Index: cell-cultures/celtic/textual.lisp diff -u cell-cultures/celtic/textual.lisp:1.2 cell-cultures/celtic/textual.lisp:1.3 --- cell-cultures/celtic/textual.lisp:1.2 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/textual.lisp Thu Jul 8 20:53:05 2004 @@ -31,12 +31,6 @@ -textvariable -underline -wraplength -compound -height -state -width)) -(defun test-label () - (make-be 'label :text (format nil "Time is ~a" (get-internal-real-time)) - :borderwidth 4 - :relief "ridge" - :font "Courier")) - ;-------------------------------------------------------------------------- (def-widget message () @@ -47,16 +41,6 @@ -takefocus -text -textvariable -width -aspect -justify)) -(defun test-message () - (make-be 'message - :text "four score and seven years ago our fathers brought forth on this continent -a new nation, conceived in liberty, and dedicated to the proposition that all men -are created equal." - :borderwidth 4 - :underline 2 - :justify :center - :font "Times")) - ;---------------------------------------------------------------------------- (def-widget entry () @@ -75,7 +59,6 @@ (def-c-output text ((self entry)) (when new-value - (tk-send (eko ("entry sets text var" self new-value) - (format nil "set ~a ~s" - (down$ (textvariable self)) - new-value))))) + (tk-format "set ~a ~s" + (down$ (textvariable self)) + new-value))) Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.5 cell-cultures/celtic/widget-item.lisp:1.6 --- cell-cultures/celtic/widget-item.lisp:1.5 Tue Jul 6 18:25:41 2004 +++ cell-cultures/celtic/widget-item.lisp Thu Jul 8 20:53:05 2004 @@ -26,14 +26,17 @@ (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) + + ;;; --- widget ----------------------------------------- + (defmodel widget (family tk-object) ((name :initarg :name :accessor name :initform (c? (down$ (md-name self)))) (path :accessor path :initarg :path :initform (c? (format nil "~a.~a" - (if (fm-parent self) (path .parent) "") + (parent-path (fm-parent self)) (name self)))) (layout :reader layout :initarg :layout :initform (c? (format nil "pack ~a" (path self)))) @@ -48,42 +51,43 @@ (defmethod not-to-be :after ((self widget)) (trc "not-to-be tk-forgetting true widget" self) - (tk-send (format nil "pack forget ~a" (^path))) - (tk-send (format nil "destroy ~a" (^path)))) + (tk-format "pack forget ~a" (^path)) + (tk-format "destroy ~a" (^path))) -(def-c-output command ((self widget)) - (when (^command-is-callback) - (register-callback self "command" new-value) - (configure self "command" - (format nil "puts -nonewline {(~s)};flush stdout" - (widget-callback-id self "command"))))) - -(def-c-output bindings () ;;; (w widget) event fun) - (loop for binding in new-value - for name = (create-name) - do (destructuring-bind (event . fn) binding - (declare (ignorable event)) - (register-callback self name fn) - (tk-send (format nil "bind ~a ~a {puts -nonewline {(\"~A\")};flush stdout}" - (^path) event (widget-callback-id self name)))))) +(defmethod parent-path ((nada null)) "") +(defmethod parent-path ((self t)) (^path)) (defmethod configure ((self widget) option value) - (tk-send (format nil "~A configure -~A {~A}" (path self) option value))) + (tk-format "~A configure ~(~a~) ~a" (path self) option (tk-format-value value))) + +(defmethod tk-format-value ((s string)) + (format nil "{~a}" s)) + +(defmethod tk-format-value (other) + (format nil "~a" other)) + +(defmethod tk-format-value ((s symbol)) + (down$ s)) + +(defmethod tk-format-value ((values list)) + (format nil "{~{~a~^ ~}}" (mapcar 'tk-format-value values))) (def-c-output layout ((self widget)) - (when new-value + (when (and new-value (not (typep .parent 'panedwindow))) (tk-send new-value))) +(defun de- (sym) + (remove #\- (symbol-name sym) :end 1)) + ;;; --- widget -------------------- (defmacro def-widget (class (&key (std-factory t)) (&rest std-slots) (&rest tk-options) &rest defclass-options) - (flet ((de- (sym) (intern (remove #\- (symbol-name sym) :end 1)))) - (multiple-value-bind (slots outputs) + (multiple-value-bind (slots outputs) (loop for tk-option-def in tk-options - for slot-name = (de- (if (atom tk-option-def) - tk-option-def (car tk-option-def))) + for slot-name = (intern (de- (if (atom tk-option-def) + tk-option-def (car tk-option-def)))) collecting `(,slot-name :initform nil :initarg ,(intern (string slot-name) :keyword) :accessor ,slot-name) @@ -92,28 +96,37 @@ (cadr tk-option-def)) collecting `(def-c-output ,slot-name ((self ,class)) (when new-value - (configure self ,(down$ (de- (if (atom tk-option-def) - tk-option-def (cadr tk-option-def)))) - (if (stringp new-value) - new-value (down$ new-value))))) + (configure self ,(string (if (atom tk-option-def) + tk-option-def (cadr tk-option-def))) + new-value))) + into outputs finally (return (values slot-defs outputs))) `(progn (defmodel ,class (widget) (,@(append std-slots slots)) ,@defclass-options) - (defun ,class (&rest inits) + (defun ,(intern (format nil "MK-~a" class)) (&rest inits) (apply 'make-instance ',class inits)) ,(when std-factory `(defmethod make-tk-instance ((self ,class)) (trc nil "!!! tk-creating" self) - (tk-send (format nil ,(concatenate 'string - (down$ class) " ~A") (path self))))) - ,@outputs)))) + (tk-format ,(format nil "~(~a~) ~~a" class) (path self)))) + ,@outputs))) + (defmacro pack-layout? (fmt$ &rest args) `(c? (format nil "pack ~a ~?" (^path) ,fmt$ (list ,@args)))) +(defmethod tk-down$ (other) (down$ other)) +(defmethod tk-down$ ((s string)) s) +(defmethod tk-down$ ((list list)) + (conc$ + (apply 'conc$ "{" (tk-down$ (car list)) + (mapcar (lambda (v) + (conc$ " " (tk-down$ v))) + (cdr list))) "}")) + ;;; --- items ----------------------------------------------------------------------- (defmodel item (tk-object) @@ -126,7 +139,7 @@ (defmethod not-to-be :after ((self item)) (trc nil "whacking item" self) - (tk-send (format nil "~a delete ~a" (path (upper self widget)) (id-no self)))) + (tk-format "~a delete ~a" (path (upper self widget)) (id-no self))) (defmethod make-tk-instance :after ((self item)) (setf (id-no self) (let ((msg (tk-read))) @@ -135,39 +148,38 @@ (defmethod configure ((self item) option value) (assert (id-no self) () "cannot configure item until instantiated and id obtained") - (tk-send (format nil "~A itemconfigure ~a -~A {~A}" (path .parent) (id-no self) option value))) + (tk-format "~A itemconfigure ~a ~a {~a}" (path .parent) (id-no self) option value)) (defmacro def-item (class (&rest tk-options)) - (flet ((de- (sym) (intern (remove #\- (symbol-name sym) :end 1)))) - (multiple-value-bind (slots outputs) - (loop for tk-option-def in tk-options - for tk-option = (if (atom tk-option-def) - tk-option-def (cadr tk-option-def)) - for slot-name = (de- (if (atom tk-option-def) - tk-option-def (car tk-option-def))) - collecting `(,slot-name :initform nil - :initarg ,(intern (string slot-name) :keyword) - :accessor ,slot-name) - into slot-defs - collecting `(def-c-output ,slot-name ((self ,class)) - (when (and (id-no self) new-value) - (configure self - ,(down$ (de- tk-option)) - (down$ new-value)))) - into outputs - finally (return (values slot-defs outputs))) - `(progn - (defmodel ,class (item) - (,@slots)) - (defun ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) - (apply 'make-instance ',class inits)) - (defmethod make-tk-instance ((self ,class)) - (tk-send (format nil "puts [~a create ~a ~{ ~a~}]" - (path .parent) ,(down$ class) (coords self)))) - ,@outputs)))) + (multiple-value-bind (slots outputs) + (loop for tk-option-def in tk-options + for tk-option = (if (atom tk-option-def) + tk-option-def (cadr tk-option-def)) + for slot-name = (intern (de- (if (atom tk-option-def) + tk-option-def (car tk-option-def)))) + collecting `(,slot-name :initform nil + :initarg ,(intern (string slot-name) :keyword) + :accessor ,slot-name) + into slot-defs + collecting `(def-c-output ,slot-name ((self ,class)) + (when (and (id-no self) new-value) + (configure self + ,(string tk-option) + (down$ new-value)))) + into outputs + finally (return (values slot-defs outputs))) + `(progn + (defmodel ,class (item) + (,@slots)) + (defun ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) + (apply 'make-instance ',class inits)) + (defmethod make-tk-instance ((self ,class)) + (tk-format "puts [~a create ~a ~{ ~a~}]" + (path .parent) ,(down$ class) (coords self))) + ,@outputs))) (def-c-output coords () (when (and (id-no self) new-value) - (tk-send (format nil "~a coords ~a ~{ ~a~}" - (path .parent) (id-no self) new-value)))) + (tk-format "~a coords ~a ~{ ~a~}" + (path .parent) (id-no self) new-value)))

1 0

[cells-cvs] CVS update: cell-cultures/cells/integrity.lisp cell-cultures/cells/model-object.lisp
by Kenny Tilton 09 Jul '04

09 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv14181/cells Modified Files: integrity.lisp model-object.lisp Log Message: Date: Thu Jul 8 20:53:04 2004 Author: ktilton Index: cell-cultures/cells/integrity.lisp diff -u cell-cultures/cells/integrity.lisp:1.3 cell-cultures/cells/integrity.lisp:1.4 --- cell-cultures/cells/integrity.lisp:1.3 Tue Jul 6 18:25:40 2004 +++ cell-cultures/cells/integrity.lisp Thu Jul 8 20:53:04 2004 @@ -51,8 +51,8 @@ `(let ((*deference-acknowledged* t)) ,@body)) -(defmacro with-integrity ((key &rest defer-info) &rest body) - `(call-with-integrity ,key (list ,@defer-info) +(defmacro with-integrity ((debug-key &rest defer-info) &rest body) + `(call-with-integrity ,debug-key (list ,@defer-info) (lambda () ,@body))) (defun ufb-queue (opcode) @@ -61,7 +61,7 @@ (defun ufb-add (opcode continuation) (fifo-add (ufb-queue opcode) continuation)) -(defconstant-once *ufb-opcodes* '(:user-notify :output :setf :makunbound)) +(defconstant-once *ufb-opcodes* '(:user-notify :output :setf :makunbound :finalize)) (define-condition c-opcode-deferred (c-enabling) ((defer-info :initarg :defer-info :reader defer-info)) @@ -72,8 +72,8 @@ (defparameter *ufb-needed* nil) -(defun call-with-integrity (key defer-info action &aux (opcode (car defer-info))) - (declare (ignorable key)) +(defun call-with-integrity (debug-key defer-info action &aux (opcode (car defer-info))) + (declare (ignorable debug-key)) (assert (or (null opcode) (member opcode *ufb-opcodes*))) (trc nil "call-with-integrity entry *unfinished-business*" *unfinished-business*) (if *unfinished-business* @@ -91,7 +91,7 @@ (mapcar (lambda (opcode) (cons opcode (make-fifo-queue))) *ufb-opcodes*))) - (trc nil "!!!!!!!!!! started new *unfinished-business*" key defer-info) + (trc nil "!!!!!!!!!! started new *unfinished-business*" debug-key defer-info) (when (or (zerop *data-pulse-id*) (member opcode '(:setf :makunbound))) (data-pulse-next (cons opcode defer-info)) @@ -145,4 +145,12 @@ (push c setfs) (data-pulse-next (list :finbiz c new-value)) (funcall task-fn)))) + (go notify-users)) + + ; --- do finalizations ------------------------ + (setf task (fifo-pop (ufb-queue :finalize))) + (when task + (destructuring-bind ((self) . task-fn) task + (trc "finbiz: deferred finalize!!!!" self) + (funcall task-fn)) (go notify-users)))) Index: cell-cultures/cells/model-object.lisp diff -u cell-cultures/cells/model-object.lisp:1.2 cell-cultures/cells/model-object.lisp:1.3 --- cell-cultures/cells/model-object.lisp:1.2 Sun Jul 4 11:59:41 2004 +++ cell-cultures/cells/model-object.lisp Thu Jul 8 20:53:04 2004 @@ -154,7 +154,7 @@ (progn ;; next bit revised to avoid double-output of optimized cells (when (eql '.kids slot-name) (bwhen (sv (slot-value self '.kids)) - (trc nil "soon will output initial kids of" self) + (trc "soon will output initial kids of" self) (md-kids-change self sv nil :md-awaken-slot))) (c-output-initially self slot-name)))))))

1 0

[cells-cvs] CVS update: Test/TEST.BMP Test/TEST.GIF Test/TEST.JPG Test/cells.asd Test/cells.fasl Test/cells.lisp Test/cells.lpr
by Kenny Tilton 09 Jul '04

09 Jul '04

Update of /project/cells/cvsroot/Test In directory common-lisp.net:/tmp/cvs-serv5713 Removed Files: TEST.BMP TEST.GIF TEST.JPG cells.asd cells.fasl cells.lisp cells.lpr Log Message: Date: Thu Jul 8 20:50:42 2004 Author: ktilton

1 0

[cells-cvs] CVS update: cell-cultures/asdf-aclproj/asdf-aclproj.lisp
by Thomas F. Burdick 07 Jul '04

07 Jul '04

Update of /project/cells/cvsroot/cell-cultures/asdf-aclproj In directory common-lisp.net:/tmp/cvs-serv4580/asdf-aclproj Modified Files: asdf-aclproj.lisp Log Message: Something I did recently caused asdf-aclproj to load the source files, instead of the fasls it had just compiled. This isn't such a big deal on SBCL, which is a compile-only implementation, but it'd be pretty aweful on anything with and interpreter. This is a quick, ugly hack that fixes this for the time being, until I have a chance to do a real fix. Date: Tue Jul 6 21:17:14 2004 Author: tburdick Index: cell-cultures/asdf-aclproj/asdf-aclproj.lisp diff -u cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.4 cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.5 --- cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.4 Mon Jul 5 12:26:00 2004 +++ cell-cultures/asdf-aclproj/asdf-aclproj.lisp Tue Jul 6 21:17:14 2004 @@ -181,4 +181,10 @@ (defmethod asdf::component-self-dependencies ((o asdf:operation) (c lpr-component)) (let ((all-deps (asdf:component-depends-on o c))) (remove-if-not (lambda (x) (member c (cdr x))) - all-deps))) \ No newline at end of file + all-deps))) + +;; FIXME: asdf is compiling the source, then loading the source, not +;; FIXME: the fasl. This is gross, but it at least causes asdf to load +;; FIXME: the fasl, until I track down why it's getting the wrong pathname. +(defmethod asdf::input-files ((op asdf:load-op) (c module)) + (list (compile-file-pathname (asdf:component-pathname c))))

1 0

[cells-cvs] CVS update: cell-cultures/cellodemo/install-notes.txt
by Kenny Tilton 07 Jul '04

07 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv10144/cellodemo Added Files: install-notes.txt Log Message: Date: Tue Jul 6 18:37:12 2004 Author: ktilton

1 0

[cells-cvs] CVS update: cell-cultures/utils-kt/defpackage.lisp
by Kenny Tilton 07 Jul '04

07 Jul '04

Update of /project/cells/cvsroot/cell-cultures/utils-kt In directory common-lisp.net:/tmp/cvs-serv4446/utils-kt Modified Files: defpackage.lisp Log Message: Date: Tue Jul 6 18:25:41 2004 Author: ktilton Index: cell-cultures/utils-kt/defpackage.lisp diff -u cell-cultures/utils-kt/defpackage.lisp:1.4 cell-cultures/utils-kt/defpackage.lisp:1.5 --- cell-cultures/utils-kt/defpackage.lisp:1.4 Sun Jul 4 11:59:46 2004 +++ cell-cultures/utils-kt/defpackage.lisp Tue Jul 6 18:25:41 2004 @@ -28,8 +28,9 @@ #-(or cormanlisp cmu sbcl) #:clos #+sbcl #:sb-mop #+mcl #:ccl) - (:export - #:eko #:count-it #:count-of #:trc #:maptimes #:bwhen #:bif #:xor + (:export #:utils-kt-reset + #:eko #:count-it #:count-of #:trc #:trcp + #:wdbg #:maptimes #:bwhen #:bif #:xor "WITH-DYNAMIC-FN" #:last1 #:packed-flat! #:with-metrics "TRUE" "SHORTC" #:intern$ #:defconstant-once "*COUNT*" "*STOP*" "*DBG*" "*TRCDEPTH*"

1 0

[cells-cvs] CVS update: cell-cultures/clyde/visual-apropos/visual-apropos.lisp
by Kenny Tilton 07 Jul '04

07 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde/visual-apropos In directory common-lisp.net:/tmp/cvs-serv4446/clyde/visual-apropos Modified Files: visual-apropos.lisp Log Message: Date: Tue Jul 6 18:25:41 2004 Author: ktilton Index: cell-cultures/clyde/visual-apropos/visual-apropos.lisp diff -u cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.2 cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.3 --- cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.2 Sun Jul 4 11:59:45 2004 +++ cell-cultures/clyde/visual-apropos/visual-apropos.lisp Tue Jul 6 18:25:41 2004 @@ -19,15 +19,9 @@ |# -#| do list - -at least show search in entry - -|# - (in-package :celtic) -;; +;; ------------------- ;; to run, enter following in repl: ;; ;; (tk-test 'vis-apropos) @@ -35,13 +29,13 @@ (defun vis-apropos () (make-be 'visual-apropos - :sub-symbol 'padding)) + :sub-symbol (c-in 'padding))) (defmodel visual-apropos (frame-stack) ((symbols :initarg :symbols :initform nil :accessor symbols) (sub-symbol :initarg :sub-symbol :initform nil :accessor sub-symbol)) (:default-initargs - :symbols (c? (apropos-list (^sub-symbol))) + :symbols (c-in nil) :pady 2 :padx 4 :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") @@ -61,9 +55,6 @@ (setf (^md-value) (not (^md-value))))) (show-which-symbols)))) (package-filtering)))) - (label :text (c? (format nil "Symbols containing ~a" - (sub-symbol .parent))) - :underline 4) (symbol-list))))) (defun search-for-symbol () @@ -84,8 +75,8 @@ (button :text "Search" :underline 0 :command (lambda (self) - (setf (md-value (upper self visual-apropos)) - (md-value (fm^ :search-string))))))))) + (setf (symbols (upper self visual-apropos)) + (apropos-list (text (fm^ :search-string)))))))))) ; --- symbol package filtering ------------------------------- @@ -104,11 +95,13 @@ :md-name :in-package :list-height 4 :layout (pack-layout? "-side left -fill x -expand 1") - :enabled (c? (not (md-value (psib)))) - :list-items (c? (loop for p in (list-all-packages) - collecting (make-instance 'listbox-item - :md-value p - :item-text (down$ (package-name p)))))))))) + :enabled (c? (when (not (md-value (psib))) + (setf *dbg* t))) + :list-item-keys (list-all-packages) + :list-item-factory (lambda (pkg) + (make-instance 'listbox-item + :md-value pkg + :item-text (down$ (package-name pkg))))))))) ; --- symbol binding filtering --------------------------------------- @@ -124,13 +117,13 @@ (^kids)))) :selection (c-in :any) :kids (c? (flet ((rb (n) - (radiobutton :md-name n - :text (string-capitalize (string n)) - :tk-variable (tk-variable self) - :value n - :layout nil - :underline 0))) - (list (rb :any)(rb :functions)(rb :variables)(rb :classes)))))) + (radiobutton :md-name n + :text (string-capitalize (string n)) + :tk-variable (tk-variable self) + :value n + :layout nil + :underline 0))) + (list (rb :any)(rb :functions)(rb :variables)(rb :classes)))))) (defun symbol-list () (frame-stack :md-name :symbol-list @@ -183,21 +176,37 @@ (if (constantp s) "con" "var")) (find-class s nil) (exported-p s))))) - :list-items (c? (let ((sorter (let ((ss (fm^ :sym-sort))) - (or (md-value (fm^ :sym-sort)) - (kid1 ss))))) - (sort (loop for si in (^md-value) - collect (make-instance 'va-symbol-info - :md-value si)) - (sort-button-predicate sorter) - :key (sort-button-key sorter))))))))) + :list-item-keys (c? (let ((sorter (let ((ss (fm^ :sym-sort))) + (or (md-value (fm^ :sym-sort)) + (kid1 ss))))) + (sort (copy-list (^md-value)) + (sort-button-predicate sorter) + :key (sort-button-key sorter)))) + :list-item-factory (lambda (symbol-info) + (make-instance 'va-symbol-info + :md-value symbol-info))))))) (defmodel sort-button (button) ((sort-button-predicate :initarg :sort-button-predicate :accessor sort-button-predicate - :initform #'string<) + :initform #'va-string<) (sort-button-key :initarg :sort-button-key :accessor sort-button-key :initform #'identity))) +(defun va-string< (v1 v2) + (flet ((blank (v) (or (null v)(equal v "")))) + (unless (equal v1 v2) + (unless (blank v1) ;; arrange for blanks to appear last + (or (blank v2) + (string< v1 v2)))))) + +(defun va-string> (v1 v2) + (flet ((blank (v) (or (null v)(equal v "")))) + (unless (equal v1 v2) + (if (blank v1) ;; arrange for blanks to appear last + (not (blank v2)) + (and (not (blank v2)) + (string> v1 v2)))))) + (defmodel va-sorter (sort-button) ((sort-string-fn :initform 'string :initarg :sort-string-fn :accessor sort-string-fn)) (:default-initargs @@ -205,13 +214,13 @@ (let* ((ss (fm^ :sym-sort))) (if (eq self (or (md-value ss) (kid1 ss))) (setf (sort-button-predicate self) - (if (eq (sort-button-predicate self) 'string<) - 'string> 'string<)) + (if (eq (sort-button-predicate self) 'va-string<) + 'va-string> 'va-string<)) (setf (md-value ss) self)))) - :sort-button-predicate (c-in 'string<) + :sort-button-predicate (c-in 'va-string<) :sort-button-key (c? (lambda (si) (funcall (^sort-string-fn) - (elt (md-value si) (kid-no self))))))) + (elt si (kid-no self))))))) (defmodel va-symbol-info (listbox-item) () @@ -249,7 +258,7 @@ (unless (or (md-value (fm^ :all-pkgs)) (bIf (sel (selection (fm^ :in-package))) (eq (symbol-package symbol) - (md-value (elt (list-items (fm^ :in-package)) sel))) + (elt (list-item-keys (fm^ :in-package)) sel)) t)) (return-from va-show-symbol-p nil))

1 0

← Newer
1
...
60
61
62
63
64
65
66
...
73
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs