From pdenno at common-lisp.net  Thu Jun  1 14:14:21 2006
From: pdenno at common-lisp.net (pdenno)
Date: Thu,  1 Jun 2006 10:14:21 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS public_html
Message-ID: <20060601141421.8E8294508E@common-lisp.net>

Update of /project/cells-gtk/cvsroot/public_html
In directory clnet:/tmp/cvs-serv605/public_html

Modified Files:
	index.html 
Log Message:
News about Marco's update.

--- /project/cells-gtk/cvsroot/public_html/index.html	2006/03/17 05:18:23	1.26
+++ /project/cells-gtk/cvsroot/public_html/index.html	2006/06/01 14:14:21	1.27
@@ -74,6 +74,11 @@
 <h1 id='news'>News</h1>
 
 <ul>
+  <li> <strong>2006-06-01</strong> Patches from Marco Gidde make Cells-GTK work better under SBCL. 
+        These patches were applied to the CVS repository, but are not in any snapshot yet. See the repository 
+        versions of gtk-ffi/gtk-utilities.lisp pod-utils/utils.lisp and gtk-ffi/gtk-ffi.lisp for
+        the fixes, or read the <a href='http://common-lisp.net/pipermail/cells-gtk-devel/2006-May/000171.html'>
+        mail</a> from Marco. It includes the patches.
   <li> <strong>2006-02-16</strong> Native CFFI now used in most of the code. There is a 
        <a href="ftp://common-lisp.net/pub/project/cells-gtk/cells-gtk-2006-02-16.tgz">snapshot release</a>.
   <li> <strong>2006-01-03</strong> BIG NEWS! cells-gtk now runs under <a href="http://clisp.cons.org">CLISP</a>
@@ -111,8 +116,6 @@
        capabilities otherwise not available through the FFI.</li>
 </ul>
 
-
-
   <!-- ###### Download ###### -->
 <h1 id='download'>Download</h1>
 
@@ -166,8 +169,6 @@
        Follow instructions in the include INSTALL.TXT.</li>
 </ul>
 
-
-
   <!-- ###### Mailing List ###### -->
 <h1 id='mailinglist'>Mailing List</h1>
 
@@ -175,10 +176,8 @@
 mailing list</a> where questions are always welcome.
 
 <hr/>
-    <address><a href="mailto:peter.denno at nist.gov">Peter Denno</a></address>
-<!-- Created: Thu Mar  3 18:45:35 EST 2005 -->
-<!-- hhmts start -->
-Last modified: 2006-01-04
+<address><a href="mailto:peter.denno at nist.gov">Peter Denno</a></address>
+Last modified: 2006-06-01
 <!-- hhmts end -->
    <a href="http://validator.w3.org/check?uri=referer"><img
     src="http://www.w3.org/Icons/valid-xhtml10"



From pdenno at common-lisp.net  Thu Jun  1 14:16:28 2006
From: pdenno at common-lisp.net (pdenno)
Date: Thu,  1 Jun 2006 10:16:28 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/gtk-ffi
Message-ID: <20060601141628.89E2246111@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/gtk-ffi
In directory clnet:/tmp/cvs-serv2145/root/gtk-ffi

Modified Files:
	gtk-ffi.lisp 
Log Message:
Marco's patch http://common-lisp.net/pipermail/cells-gtk-devel/2006-May/000171.html

--- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp	2006/02/19 20:17:41	1.19
+++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp	2006/06/01 14:16:28	1.20
@@ -16,7 +16,10 @@
  
 |#
 
-(defpackage :gtk-ffi (:use :common-lisp :pod))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package :gtk-ffi)
+      (defpackage :gtk-ffi
+	(:use :common-lisp :pod))))
 
 (in-package :gtk-ffi)
 
@@ -138,7 +141,7 @@
 				 #+macosx "libcellsgtk.dylib")))
 ) ; eval
 
-(eval-when (:compile-toplevel :execute)
+(eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(+c-null+ int-slot-indexed load-gtk-libs))
   (defun gtk-function-name (lisp-name)
     (substitute #\_ #\- lisp-name))



From pdenno at common-lisp.net  Thu Jun  1 14:18:22 2006
From: pdenno at common-lisp.net (pdenno)
Date: Thu,  1 Jun 2006 10:18:22 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/gtk-ffi
Message-ID: <20060601141822.5665546111@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/gtk-ffi
In directory clnet:/tmp/cvs-serv2195/root/gtk-ffi

Modified Files:
	gtk-utilities.lisp 
Log Message:
Marco's patch http://common-lisp.net/pipermail/cells-gtk-devel/2006-May/000171.html

--- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-utilities.lisp	2006/02/19 20:18:27	1.19
+++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-utilities.lisp	2006/06/01 14:18:22	1.20
@@ -88,7 +88,7 @@
     (when (or (eql (event-type event) :button_press)
               (eql (event-type event) :button_release))
       (when (= (gdk-event-button-button signal) 3)
-        (gtk-menu-popup widget nil nil nil nil 3
+        (gtk-menu-popup widget +c-null+ +c-null+ +c-null+ +c-null+ 3
 			(gdk-event-button-time signal)))))
   0)
 
@@ -264,7 +264,7 @@
 (defun gtk-file-chooser-get-filenames-strs (file-chooser)
   (let ((glist (gtk-file-chooser-get-filenames file-chooser)))
     (loop for lst-address = glist then (cffi:foreign-slot-value lst-address 'gslist 'next)
-        while (and lst-address (not (zerop lst-address)))
+        while (and lst-address (not (cffi:null-pointer-p lst-address)))
         collect (cffi:foreign-slot-value lst-address 'gslist 'data)
         finally (g-slist-free glist))))
 



From pdenno at common-lisp.net  Thu Jun  1 14:20:56 2006
From: pdenno at common-lisp.net (pdenno)
Date: Thu,  1 Jun 2006 10:20:56 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/pod-utils
Message-ID: <20060601142056.3A57F4614F@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/pod-utils
In directory clnet:/tmp/cvs-serv2330/root/pod-utils

Modified Files:
	pod-utils.asd 
Log Message:
Added kt-trace to what is loaded.

--- /project/cells-gtk/cvsroot/root/pod-utils/pod-utils.asd	2006/02/19 20:09:12	1.1
+++ /project/cells-gtk/cvsroot/root/pod-utils/pod-utils.asd	2006/06/01 14:20:56	1.2
@@ -2,4 +2,5 @@
 (asdf:defsystem :pod-utils
   :name "pod-utils"
   :components
-  ((:file "utils")))
+  ((:file "utils")
+   (:file "kt-trace")))



From pdenno at common-lisp.net  Thu Jun  1 14:22:45 2006
From: pdenno at common-lisp.net (pdenno)
Date: Thu,  1 Jun 2006 10:22:45 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/pod-utils
Message-ID: <20060601142245.6363F46111@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/pod-utils
In directory clnet:/tmp/cvs-serv2368/root/pod-utils

Added Files:
	kt-trace.lisp 
Log Message:
New file. Kenny Tilton's trace routines.


--- /project/cells-gtk/cvsroot/root/pod-utils/kt-trace.lisp	2006/06/01 14:22:45	NONE
+++ /project/cells-gtk/cvsroot/root/pod-utils/kt-trace.lisp	2006/06/01 14:22:45	1.1

;;; Copyright (c) 2004 Kenny 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.
;;;-----------------------------------------------------------------------

;;;
;;; Kenny Tilton trace stuff.
;;;
(in-package :pod-utils)

(defparameter *trcdepth* 0)
(defvar *count* nil)
(defvar *counting* nil)
(defvar *dbg*)
(defvar *stop* nil)

(defun utils-kt-reset ()
  (setf *count* nil
    *stop* nil
    *dbg* nil
    *trcdepth* 0))

;----------- trc -------------------------------------------

(defparameter *trcdepth* 0)
(defvar *counting* nil)

(defmacro count-it (&rest keys)
  `(when *counting*
     (call-count-it , at keys)))

(defmacro trc (tgt-form &rest os
                &aux (wrapper (if (macro-function 'without-c-dependency)
                                  'without-c-dependency 'progn)))
  (if (eql tgt-form 'nil)
      '(progn)
    (if (stringp tgt-form)
        `(,wrapper
          (call-trc t ,tgt-form , at os))
      (let ((tgt (gensym)))
        `(,wrapper
          (bif (,tgt ,tgt-form)
            (if (trcp ,tgt)
                (progn
                  (assert (stringp ,(car os)))
                  (call-trc t , at os)) ;;,(car os) ,tgt ,@(cdr os)))
              (progn
                ;;(break "trcfailed")
                (count-it :trcfailed)))
            (count-it :tgtnileval)))))))

(defun call-trc (stream s &rest os)
  (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
          *trcdepth*)
        (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
      (format stream "~&"))
    (format stream "~a" s)
    (let (pkwp)
      (dolist (o os)
        (format stream (if pkwp " ~s" " | ~s") o)
        (setf pkwp (keywordp o))))
    (values))

(defun call-count-it (&rest keys)
    (declare (ignorable keys))
  ;;; (when (eql :TGTNILEVAL (car keys))(break))
  (let ((entry (assoc keys *count* :test #'equal)))
      (if entry
          (setf (cdr entry) (1+ (cdr entry)))
        (push (cons keys 1) *count*))))


(export '(trc))


From pdenno at common-lisp.net  Thu Jun  1 14:24:40 2006
From: pdenno at common-lisp.net (pdenno)
Date: Thu,  1 Jun 2006 10:24:40 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/pod-utils
Message-ID: <20060601142440.262C246111@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/pod-utils
In directory clnet:/tmp/cvs-serv2395/root/pod-utils

Modified Files:
	utils.lisp 
Log Message:
Marco's patch http://common-lisp.net/pipermail/cells-gtk-devel/2006-May/000171.html and also moved trc routines to kt-trace.lisp

--- /project/cells-gtk/cvsroot/root/pod-utils/utils.lisp	2006/02/19 20:09:12	1.1
+++ /project/cells-gtk/cvsroot/root/pod-utils/utils.lisp	2006/06/01 14:24:40	1.2
@@ -469,7 +469,7 @@
     (format nil "~D.~2,'0D.~2,'0D  ~2,'0D:~2,'0D:~2,'0D" y month d h m s)))
 
 ;;; Norvig's search routines
-(defun tree-search (states goal-p successors combiner)
+(defun tree-search (states goal-p successors combiner &optional do-fn)
   "Find a state that satisfies GOAL-P. Start with STATES, 
    and search according to successors and combiners."
   (cond ((null states) :fail)
@@ -705,65 +705,3 @@
           (and (funcall fn x) (funcall chain x))))))
 
 
-;;; Kenny Tilton trace stuff ---------------
-
-(defparameter *trcdepth* 0)
-(defvar *count* nil)
-(defvar *counting* nil)
-(defvar *dbg*)
-(defvar *stop* nil)
-
-(defun utils-kt-reset ()
-  (setf *count* nil
-    *stop* nil
-    *dbg* nil
-    *trcdepth* 0))
-
-;----------- trc -------------------------------------------
-
-(defparameter *trcdepth* 0)
-(defvar *counting* nil)
-
-(defmacro count-it (&rest keys)
-  `(when *counting*
-     (call-count-it , at keys)))
-
-(defmacro trc (tgt-form &rest os
-                &aux (wrapper (if (macro-function 'without-c-dependency)
-                                  'without-c-dependency 'progn)))
-  (if (eql tgt-form 'nil)
-      '(progn)
-    (if (stringp tgt-form)
-        `(,wrapper
-          (call-trc t ,tgt-form , at os))
-      (let ((tgt (gensym)))
-        `(,wrapper
-          (bif (,tgt ,tgt-form)
-            (if (trcp ,tgt)
-                (progn
-                  (assert (stringp ,(car os)))
-                  (call-trc t , at os)) ;;,(car os) ,tgt ,@(cdr os)))
-              (progn
-                ;;(break "trcfailed")
-                (count-it :trcfailed)))
-            (count-it :tgtnileval)))))))
-
-(defun call-trc (stream s &rest os)
-  (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
-          *trcdepth*)
-        (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
-      (format stream "~&"))
-    (format stream "~a" s)
-    (let (pkwp)
-      (dolist (o os)
-        (format stream (if pkwp " ~s" " | ~s") o)
-        (setf pkwp (keywordp o))))
-    (values))
-
-(defun call-count-it (&rest keys)
-    (declare (ignorable keys))
-  ;;; (when (eql :TGTNILEVAL (car keys))(break))
-  (let ((entry (assoc keys *count* :test #'equal)))
-      (if entry
-          (setf (cdr entry) (1+ (cdr entry)))
-        (push (cons keys 1) *count*))))



From pdenno at common-lisp.net  Wed Jun  7 16:19:55 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:19:55 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS cells
Message-ID: <20060607161955.1AA4F1F003@common-lisp.net>

Update of /project/cells-gtk/cvsroot/cells
In directory clnet:/tmp/cvs-serv31928/cells

Log Message:
Directory /project/cells-gtk/cvsroot/cells added to the repository





From pdenno at common-lisp.net  Wed Jun  7 16:23:32 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:23:32 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS cells
Message-ID: <20060607162332.2F2D420013@common-lisp.net>

Update of /project/cells-gtk/cvsroot/cells
In directory clnet:/tmp/cvs-serv32090

Added Files:
	cell-types.lisp cells-test.asd cells.asd cells.lisp 
	constructors.lisp defmodel.lisp defpackage.lisp 
	family-values.lisp family.lisp fm-utilities.lisp 
	initialize.lisp integrity.lisp link.lisp md-slot-value.lisp 
	md-utilities.lisp model-object.lisp optimization.lisp 
	propagate.lisp slot-utilities.lisp synapse-types.lisp 
	synapse.lisp test.lisp 
Log Message:
new files


--- /project/cells-gtk/cvsroot/cells/cell-types.lisp	2006/06/07 16:23:31	NONE
+++ /project/cells-gtk/cvsroot/cells/cell-types.lisp	2006/06/07 16:23:31	1.1
;; -*- 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.
;;;
;;; 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 :cells)

(defstruct (cell (:conc-name c-))
  model
  slot-name
  value
  
  inputp ;; t for old c-variable class
  cyclicp ;; t if OK for setf to cycle back (ending cycle)
  synaptic
  changed
  (users nil :type list)
  
  (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away
  (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :valid}
  (pulse 0 :type fixnum)
  debug
  md-info)

(defun c-unboundp (c)
  (eql :unbound (c-value-state c)))

; -----------------------------------------------------

(defun c-validate (self c)
  (when (not (and (c-slot-name c) (c-model c)))
    (format t "~&unadopted cell: ~s md:~s" c self)
    (c-break "unadopted cell ~a ~a" self c)
    (error 'c-unadopted :cell c)))

(defstruct (c-ruled
            (:include cell)
            (:conc-name cr-))
  lazy
  (code nil :type list) ;; /// feature this out on production build
  rule)

(defun c-optimized-away-p (c)
  (eql :optimized-away (c-state c)))

(defmethod c-lazy ((c c-ruled)) (cr-lazy c))
(defmethod c-lazy (c) (declare (ignore c)) nil)

;----------------------------

(defmethod trcp-slot (self slot-name)
  (declare (ignore self slot-name)))

(define-constant *cd-usagect* 64)

(defstruct (c-dependent
            (:include c-ruled)
            (:conc-name cd-))
  (synapses nil :type list)
  (useds nil :type list)
  (usage (make-array *cd-usagect* :element-type 'bit
                        :initial-element 0) :type vector))

(defstruct (c-stream
            (:include c-dependent)
            (:conc-name cs-))
  values)

(defstruct streamer from stepper donep to)

#+notyet
(defmacro c~~~ (&key (from 0)
                 stepper
                 (donep (c-lambda (> .cache (streamer-to slot-c))))
                 to)
   `(make-c-stream
     :rule (c-lambda (make-streamer
                      :from ,from
                      :stepper ,stepper
                      :to ,to :donep ,donep))))

(defmethod md-slot-value-assume :around ((c c-stream) (s streamer))
  (bif (to (streamer-to s))
    (loop for slot-value = (streamer-from s)
          then (bIf (stepper (streamer-stepper s))
                 (funcall stepper c)
                 (incf slot-value))
          until (bIf (to (streamer-to s))
                  (> slot-value to)
                  (bwhen (donep-test (streamer-donep s))
                    (funcall donep-test c)))
          do (progn
               (print `(assume doing ,slot-value))
               (call-next-method c slot-value))))
  (c-optimize-away?! c))

#+test
(progn
  (defmodel streamertest ()
    ((val :accessor val :initform (c~~~ :from 0 :to (^oval)))
     (oval :initarg :oval :accessor oval :initform (c-in 0))))
  
  (def-c-output val ((self streamertest))
    (print `(streamertest old ,old-value new ,new-value)))
  
  (cell-reset)
  (let ((it (make-be 'streamertest :oval 5)))
    ;;(setf (oval it) 5)
    it))

(defstruct (c-drifter
            (:include c-dependent)))

(defstruct (c-drifter-absolute
            (:include c-drifter)))

;_____________________ accessors __________________________________

(defmethod c-useds (other) (declare (ignore other)))
(defmethod c-useds ((c c-dependent)) (cd-useds c))



(defun c-validp (c)
  (eql (c-value-state c) :valid))

;_____________________ print __________________________________

(defmethod print-object :before ((c cell) stream)
 (declare (ignorable c))
  (format stream "[~a~a:" (if (c-inputp c) "i" "?")
    (cond
     ((null (c-model c)) #\0)
     ((eq :eternal-rest (md-state (c-model c))) #\_)
     ((not (c-currentp c)) #\#)
     (t #\space))))

(defmethod print-object ((c cell) stream)
  (c-print-value c stream)
  (format stream "=[~d]~a/~a]"
    (c-pulse c)
    (symbol-name (or (c-slot-name c) :anoncell))
    (or (c-model c) :anonmd)))

;__________________

(defmethod c-print-value ((c c-ruled) stream)
  (format stream "~a" (cond ((c-validp c) "<vld>")
                            ((c-unboundp c) "<unb>")
                            ((not (c-currentp c)) "<obs>")
                            (t "<err>"))))

(defmethod c-print-value (c stream)
  (declare (ignore c stream)))
--- /project/cells-gtk/cvsroot/cells/cells-test.asd	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test.asd	2006/06/07 16:23:32	1.1
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-

#+(or allegro lispworks cmu mcl clisp cormanlispx sbcl scl)
(progn

(asdf:defsystem :cells-test
  :name "cells-test"
  :author "Kenny Tilton <ktilton at nyc.rr.com>"
  :version "05-Nov-2003"
  :maintainer "Kenny Tilton <ktilton at nyc.rr.com>"
  :licence "MIT Style"
  :description "Cells Regression Test/Documentation"
  :long-description "Informatively-commented regression tests for Cells"
  :serial t
  :depends-on (:cells)
  :components ((:module "cells-test"
			:components ((:file "test")
				     (:file "hello-world")
				     (:file "internal-combustion")
				     (:file "boiler-examples")
				     (:file "person")
				     (:file "df-interference")
				     (:file "test-family")
				     (:file "test-kid-slotting")
				     (:file "lazy-propagation")
				     (:file "output-setf")
				     (:file "test-lazy")
				     (:file "synapse-testing")))))

(defmethod perform :after ((op load-op) (system (eql (find-system :cells-test))))
  (cells::cv-test))

)--- /project/cells-gtk/cvsroot/cells/cells.asd	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/cells.asd	2006/06/07 16:23:32	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 :cells
    :name "cells"
  :author "Kenny Tilton <ktilton at nyc.rr.com>"
  :version "18-Oct-2004"
  :maintainer "Kenny Tilton <ktilton at nyc.rr.com>"
  :licence "MIT Style"
  :description "Cells"
  :long-description "The Cells dataflow extension to CLOS."
  :components ((:module "utils-kt"
			:components ((:file "defpackage")
				     (:file "debug")
				     (:file "detritus")
				     (:file "flow-control")
				     (:file "strings")))
               (:file "defpackage" :depends-on ("utils-kt"))
               (:file "cells" :depends-on ("defpackage"))
               (:file "cell-types" :depends-on ("defpackage"))
               (:file "integrity" :depends-on ("cell-types" "cells"))
               (:file "constructors" :depends-on ("integrity" "cells"))
               (:file "initialize" :depends-on ("cells" "cell-types"))
               (:file "md-slot-value" :depends-on ("integrity" "cell-types"))
               (:file "slot-utilities" :depends-on ("cells"))
               (:file "optimization" :depends-on ("cells"))
               (:file "link" :depends-on ("cells"))
               (:file "propagate" :depends-on ("cells" "integrity"))
               (:file "synapse" :depends-on ("cells"))
               (:file "synapse-types" :depends-on ("cells"))
               (:file "model-object" :depends-on ("defpackage"))
               (:file "defmodel" :depends-on ("model-object" "propagate" "constructors"))
               (:file "md-utilities" :depends-on ("cells"))
               (:file "family" :depends-on ("defmodel"))
               (:file "fm-utilities" :depends-on ("cells"))
               (:file "family-values" :depends-on ("family" "propagate" "defmodel" ))
               (:file "test" :depends-on ("family"))
               ))

(defmethod perform ((o load-op) (c (eql (find-system :cells))))
  (pushnew :cells *features*))

(defmethod perform ((o test-op) (c (eql (find-system :cells))))
  (oos 'load-op :cells-test))

(defmethod perform ((o test-op) (c (eql :cells)))
  (oos 'load-op :cells-test))

)--- /project/cells-gtk/cvsroot/cells/cells.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/cells.lisp	2006/06/07 16:23:32	1.1
;; -*- 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.
;;;
;;; 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.

;;;(eval-when (compile load)
;;;  (proclaim '(optimize (speed 1) (safety 1) (space 1) (debug 2))))

(eval-when (compile load)
  (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))))

(in-package :cells)

(define-constant *c-optimizep* t)
(defparameter *c-prop-depth* 0)
(defparameter *causation* nil)

(defparameter *data-pulse-id* 0)
(defparameter *data-pulses* nil)
(defparameter *unfinished-business* nil)
(defparameter *c-debug* nil)

(defun cell-reset ()
  (utils-kt-reset)
  (setf 
   *c-debug* nil
   *c-prop-depth* 0
   *data-pulse-id* 0
   *data-pulses* nil
   *unfinished-business* nil)
  (trc nil "------ cell reset ----------------------------"))

(defun c-stop (&optional why)
  (format t "~&C-STOP> stopping because ~a" why)
  (setf *stop* t))

(define-symbol-macro .stop
    (c-stop :user))

(defun c-stopped ()
  *stop*)

(defmacro c-assert (assertion &optional places fmt$ &rest fmt-args)
  (declare (ignore places))
  `(unless *stop*
     (unless ,assertion
       ,(if fmt$
            `(c-break ,fmt$ , at fmt-args)
          `(c-break "failed assertion: ~a" ',assertion)))))

(defvar *c-calculators* nil)

(defmacro s-sib-no () `(position self (kids .parent)))

(defmacro gpar ()
  `(fm-grandparent self))

(defmacro nearest (self-form type)
   (let ((self (gensym)))
   `(bwhen (,self ,self-form)
       (if (typep ,self ',type) ,self (upper ,self ,type)))))

(defmacro def-c-trace (model-type &optional slot cell-type)
  `(defmethod trcp ((self ,(case cell-type
                             (:c? 'c-dependent)
                             (otherwise 'cell))))
     (and (typep (c-model self) ',model-type)
       ,(if slot
            `(eq (c-slot-name self) ',slot)
          `t))))

(defmacro without-c-dependency (&body body)
  `(let (*c-calculators*) , at body))

(define-symbol-macro .cause
    (car *causation*))

(define-condition unbound-cell (unbound-slot) ())

(defgeneric c-output-slot-name (slotname self new old old-boundp)
  #-(or cormanlisp clisp)
  (:method-combination progn))

#-cells-testing
(defmethod c-output-slot-name #-(or cormanlisp clisp) progn
  (slot-name self new old old-boundp)
  (declare (ignorable slot-name self new old old-boundp)))


; -------- cell conditions (not much used) ---------------------------------------------

(define-condition xcell () ;; new 2k0227
  ((cell :initarg :cell :reader cell :initform nil)
   (app-func :initarg :app-func :reader app-func :initform 'bad-cell)
   (error-text :initarg :error-text :reader error-text :initform "<???>")
   (other-data :initarg :other-data :reader other-data :initform "<nootherdata>"))
  (:report (lambda (c s)
             (format s "~& trouble with cell ~a in function ~s,~s: ~s"
               (cell c) (app-func c) (error-text c) (other-data c)))))

(define-condition c-enabling ()
   ((name :initarg :name :reader name)
    (model :initarg :model :reader model)
    (cell :initarg :cell :reader cell))
   (:report (lambda (condition stream)
                 (format stream "~&unhandled <c-enabling>: ~s" condition)
                 (break "~&i say, unhandled <c-enabling>: ~s" condition))))

(define-condition c-fatal (xcell)
   ((name :initarg :name :reader name)
    (model :initarg :model :reader model)
    (cell :initarg :cell :reader cell))
   (:report (lambda (condition stream)
              (format stream "~&fatal cell programming error: ~s" condition)
              (format stream "~&  : ~s" (name condition))
              (format stream "~&  : ~s" (model condition))
              (format stream "~&  : ~s" (cell condition)))))

(define-condition c-unadopted (c-fatal)
   ()
   (:report
    (lambda (condition stream)
      (format stream "~&unadopted cell >: ~s" (cell condition))
      (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error"))))


(defun c-break (&rest args)

[8 lines skipped]
--- /project/cells-gtk/cvsroot/cells/constructors.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/constructors.lisp	2006/06/07 16:23:32	1.1

[145 lines skipped]
--- /project/cells-gtk/cvsroot/cells/defmodel.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/defmodel.lisp	2006/06/07 16:23:32	1.1

[270 lines skipped]
--- /project/cells-gtk/cvsroot/cells/defpackage.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/defpackage.lisp	2006/06/07 16:23:32	1.1

[333 lines skipped]
--- /project/cells-gtk/cvsroot/cells/family-values.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/family-values.lisp	2006/06/07 16:23:32	1.1

[434 lines skipped]
--- /project/cells-gtk/cvsroot/cells/family.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/family.lisp	2006/06/07 16:23:32	1.1

[677 lines skipped]
--- /project/cells-gtk/cvsroot/cells/fm-utilities.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/fm-utilities.lisp	2006/06/07 16:23:32	1.1

[1234 lines skipped]
--- /project/cells-gtk/cvsroot/cells/initialize.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/initialize.lisp	2006/06/07 16:23:32	1.1

[1331 lines skipped]
--- /project/cells-gtk/cvsroot/cells/integrity.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/integrity.lisp	2006/06/07 16:23:32	1.1

[1493 lines skipped]
--- /project/cells-gtk/cvsroot/cells/link.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/link.lisp	2006/06/07 16:23:32	1.1

[1646 lines skipped]
--- /project/cells-gtk/cvsroot/cells/md-slot-value.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/md-slot-value.lisp	2006/06/07 16:23:32	1.1

[1858 lines skipped]
--- /project/cells-gtk/cvsroot/cells/md-utilities.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/md-utilities.lisp	2006/06/07 16:23:32	1.1

[1964 lines skipped]
--- /project/cells-gtk/cvsroot/cells/model-object.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/model-object.lisp	2006/06/07 16:23:32	1.1

[2126 lines skipped]
--- /project/cells-gtk/cvsroot/cells/optimization.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/optimization.lisp	2006/06/07 16:23:32	1.1

[2191 lines skipped]
--- /project/cells-gtk/cvsroot/cells/propagate.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/propagate.lisp	2006/06/07 16:23:32	1.1

[2372 lines skipped]
--- /project/cells-gtk/cvsroot/cells/slot-utilities.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/slot-utilities.lisp	2006/06/07 16:23:32	1.1

[2469 lines skipped]
--- /project/cells-gtk/cvsroot/cells/synapse-types.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/synapse-types.lisp	2006/06/07 16:23:32	1.1

[2617 lines skipped]
--- /project/cells-gtk/cvsroot/cells/synapse.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/synapse.lisp	2006/06/07 16:23:32	1.1

[2718 lines skipped]
--- /project/cells-gtk/cvsroot/cells/test.lisp	2006/06/07 16:23:32	NONE
+++ /project/cells-gtk/cvsroot/cells/test.lisp	2006/06/07 16:23:32	1.1

[2885 lines skipped]


From pdenno at common-lisp.net  Wed Jun  7 16:25:59 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:25:59 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS cells/cells-test
Message-ID: <20060607162559.C108B20013@common-lisp.net>

Update of /project/cells-gtk/cvsroot/cells/cells-test
In directory clnet:/tmp/cvs-serv32257/cells-test

Log Message:
Directory /project/cells-gtk/cvsroot/cells/cells-test added to the repository





From pdenno at common-lisp.net  Wed Jun  7 16:25:59 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:25:59 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS cells/doc
Message-ID: <20060607162559.EFE8420028@common-lisp.net>

Update of /project/cells-gtk/cvsroot/cells/doc
In directory clnet:/tmp/cvs-serv32257/doc

Log Message:
Directory /project/cells-gtk/cvsroot/cells/doc added to the repository





From pdenno at common-lisp.net  Wed Jun  7 16:26:00 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:26:00 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS cells/utils-kt
Message-ID: <20060607162600.31FE722004@common-lisp.net>

Update of /project/cells-gtk/cvsroot/cells/utils-kt
In directory clnet:/tmp/cvs-serv32257/utils-kt

Log Message:
Directory /project/cells-gtk/cvsroot/cells/utils-kt added to the repository





From pdenno at common-lisp.net  Wed Jun  7 16:28:57 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:28:57 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS cells/cells-test
Message-ID: <20060607162857.D41F022004@common-lisp.net>

Update of /project/cells-gtk/cvsroot/cells/cells-test
In directory clnet:/tmp/cvs-serv32368/cells-test

Added Files:
	boiler-examples.lisp build-sys.lisp df-interference.lisp 
	echo-setf.lisp hello-world-q.lisp hello-world.lisp 
	internal-combustion.lisp lazy-propagation.lisp 
	output-setf.lisp person.lisp synapse-testing.lisp 
	test-cyclicity.lisp test-family.lisp test-kid-slotting.lisp 
	test-lazy.lisp test.lisp 
Log Message:
new files


--- /project/cells-gtk/cvsroot/cells/cells-test/boiler-examples.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/boiler-examples.lisp	2006/06/07 16:28:57	1.1
;; -*- 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.
;;;
;;; 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 :cells)

;;
;; OK, nothing new here, just some old example code I found lying around. FWIW...
;;

(defmodel boiler1 ()
  ((id :cell nil :initarg :id :accessor id :initform (random 1000000))
   (status :initarg :status :accessor status :initform nil) ;; vanilla cell
   (temp :initarg :temp :accessor temp :initform nil)
   (vent :initarg :vent :accessor vent :initform nil)
   ))

(defun boiler-1 ()

  ;; resets debugging/testing specials
  (cell-reset)   

  (let ((b (make-instance 'boiler1
             :temp  (c-in 20)
             :status (c? (if (< (temp self) 100)
                              :on
                            :off))
             :vent (c? (ecase (^status) ;; expands to (status self) and also makes coding synapses convenient
                          (:on :open)
                          (:off :closed))))))

    (cv-assert (eql 20 (temp b)))
    (cv-assert (eql :on (status b)))
    (cv-assert (eql :open (vent b)))

    (setf (temp b) 100) ;; triggers the recalculation of status and then of vent

    (cv-assert (eql 100 (temp b)))
    (cv-assert (eql :off (status b)))
    (cv-assert (eql :closed (vent b)))
    ))

#+test
(boiler-1)

;
; now let's see how output functions can be used...
; and let's also demonstrate inter-object dependency by 
; separating out the thermometer
;

;;; note that thermometer is just a regular slot, it is
;;; not cellular.

(defmodel boiler2 ()
  ((status :initarg :status :accessor status :initform nil)
   (vent :initarg :vent :accessor vent :initform nil)
   (thermometer :cell nil :initarg :thermometer :accessor thermometer :initform nil)
   ))

;;; def-c-output ((slot-name) (&optional method-args) &body body

;;; the def-c-output macro defines a method with
;;; three arguments -- by default, these arguments are named
;;;   self -- bound to the instance being operated on
;;;   old-value -- bound to the previous value of the cellular slot
;;;     named slot-name, of the instance being operated on.
;;;   new-value -- bound to the new value of said cellular slot

;;; (this is why the variables self, old-value, and new-value can exist
;;; below in the body, when it appears they are not defined in any
;;; lexical scope)

;;; the body of the macro defines code which is executed
;;; when the the slot-name slot is initialized or changed.

(def-c-output status ((self boiler2))
  (trc "output> boiler status" self :oldstatus= old-value :newstatus= new-value)
  ;
  ; << in real life call boiler api here to actually turn it on or off >>
  ;
  )

(def-c-output vent ((self boiler2))
  (trc "output> boiler vent changing from" old-value :to new-value)
  ;
  ; << in real life call boiler api here to actually open or close it >>
  ;
  )


(defmodel quiet-thermometer ()
  ((temp :initarg :temp :accessor temp :initform nil)
   ))

(defmodel thermometer (quiet-thermometer)())

;;; notice instead of oldvalue and newvalue, here the
;;; old and new values are bound to parameters called oldtemp
;;; and newtemp

(def-c-output temp ((self thermometer) newtemp oldtemp)
  (trc "output> thermometer temp changing from" oldtemp :to newtemp))

;--------------------------


;;; here we introduce the to-be-primary construct, which causes
;;; immediate initialization of cellular slots.

;;; notice how the status cell of a boiler2 can depend
;;; on the temp slot of a thermometer, illustrating how
;;; dependencies can be made between the cellular slots of
;;; instances of different classes.


(defun boiler-2 ()
  (cell-reset)    
  (let ((b (make-instance 'boiler2 
                    :status (c? (eko ("boiler2 status c?")
                                     (if (< (temp (thermometer self)) 100)
                                         :on :off)))
                    :vent (c? (ecase (^status)
                                 (:on :open)
                                 (:off :closed)))
                    :thermometer (make-instance 'thermometer
                                   :temp (c-in 20)))))
                   
    (cv-assert (eql 20 (temp (thermometer b))))
    (cv-assert (eql :on (status b)))
    (cv-assert (eql :open (vent b)))
    
    (setf (temp (thermometer b)) 100)
    
    (cv-assert (eql 100 (temp (thermometer b))))
    (cv-assert (eql :off (status b)))
    (cv-assert (eql :closed (vent b)))
    ))

#+test
(boiler-2)

;;; ***********************************************
;;; ***********************************************
;;; ***********************************************

#|          intro to cells, example 3        |# 

;;; ***********************************************
;;; ***********************************************
;;; ***********************************************


;;; note:  we use boiler2 and thermometer from example 2 in example 3,
;;; along with their def-output methods defined in example 2.
;;;
;;; also: these do not use cv-assert to perform automatic testing, but
;;; they do illustrate a possible real-world application of synapses. to
;;; observe the difference made by synapses, one must look at the trace output
;
; now let's look at synapses, which mediate a dependency between two cells.
; the example here has an input argument (sensitivity-enabled) which when
; enables gives the temp cell an (fsensitivity 0.05) clause.

; the example simulates a thermometer perhaps
; malfunctioning which is sending streams of values randomly plus or minus
; two-hundredths of a degree. does not sound serious, except...
;
; if you run the example as is, when the temperature gets to our on/off threshhold
; of 100, chances are you will see the boiler toggle itself on and off several times
; before the temperature moves away from 100.
;
; building maintenance personel will report this odd behavior, probably hearing the
; vent open and shut and open again several times in quick succession.

; the problem is traced to the cell rule which reacts too slavishly to the stream
; of temperature values. a work order is cut to replace the thermometer, and to reprogram
; the controller not to be so slavish. there are lots of ways to solve this; here if
; you enable sensitivity by running example 4 you can effectively place a synapse between the
; temperature cell of the thermometer and the status cell of the boiler which
; does not even trigger the status cell unless the received value differs by the
; specified amount from the last value which was actually relayed.

; now the boiler simply cuts off as the temperature passes 100, and stays off even if
; the thermometer temperature goes to 99.98. the trace output shows that although the temperature
; of the thermometer is changing, only occasionally does the rule to decide the boiler
; status get kicked off.
;



(defun boiler-3 (&key (sensitivity-enabled t))
  (declare (ignorable sensitivity-enabled))
  (cell-reset) 
  #+soon
  (let ((b (make-instance 'boiler2 
              :status (c? (let ((temp (if sensitivity-enabled
                                          (temp (thermometer self) (f-sensitivity 0.05))
                                        (temp (thermometer self)))))
                            ;;(trc "status c? sees temp" temp)
                            (if (<  temp 100) :on :off)
                            ))
              :vent (c? (ecase (^status) (:on :open) (:off :closed)))
              :thermometer (make-instance 'quiet-thermometer :temp (c-in 20))
              )))
    ;
    ; let's simulate a thermometer which, when the temperature is actually
    ; any given value t will indicate randomly anything in the range
    ; t plus/minus 0.02. no big deal unless the actual is exactly our
    ; threshold point of 100...
    ;
    (dotimes (x 4)
      ;;(trc "top> ----------- set base to" (+ 98 x))
      (dotimes (y 10)
        (let ((newtemp (+ 98 x (random 0.04) -.02))) ;; force random variation around (+ 98 x)
          ;;(trc "top> ----------- set temp to" newtemp)
          (setf (temp (thermometer b)) newtemp))))))


(defun boiler-4 () (boiler-3 :sensitivity-enabled t))

;;
;; de-comment 'trc statements above to see what is happening
;;
#+test
(boiler-3)

#+test
(boiler-4)

(defun boiler-5 ()

  (cell-reset) 
  #+soon
  (let ((b (make-instance 'boiler2 
              :status (c-in :off)
              :vent (c? (trc "caculating vent" (^status))
                      (if (eq (^status) :on)
                          (if (> (temp (thermometer self) (f-debug 3)) 100)
                              :open :closed)
                        :whatever-off))
              :thermometer (make-instance 'quiet-thermometer
                             :temp (c-in 20)))))

    (dotimes (x 4)
      (dotimes (n 4)
        (incf (temp (thermometer b))))
      (setf (status b) (case (status b) (:on :off)(:off :on))))))

#+test

(boiler-5)

(defun f-debug (sensitivity &optional subtypename)
  (declare (ignore sensitivity subtypename))
  #+soon
  (mk-synapse (prior-fire-value)
    :fire-p (lambda (syn new-value)
              (declare (ignorable syn))
              (eko ("fire-p decides" prior-fire-value sensitivity)
                (delta-greater-or-equal
                 (delta-abs (delta-diff new-value prior-fire-value subtypename) subtypename)
                 (delta-abs sensitivity subtypename) 
                 subtypename)))
    
    :fire-value (lambda (syn new-value)
                   (declare (ignorable syn))
                   (eko ("f-sensitivity relays")
                     (setf prior-fire-value new-value)) ;; no modulation of value, but do record for next time
                   )))--- /project/cells-gtk/cvsroot/cells/cells-test/build-sys.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/build-sys.lisp	2006/06/07 16:28:57	1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*-
;;;
;;; 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.

(defpackage #:cells-build-package
  (:use #:cl))

(in-package #:cells-build-package)

(defun build-sys (system$ &key source-directory force)
  (let (
        ;;; --------------------------------------
        ;;; Step 2: Implementation-specific issues
        ;;; 
        ;;; Let's assume this is fixed in CMUCL 19a, and fix it later if need be.
        #+cmu18
        (ext:*derive-function-types* nil)
        
        #+lispworks
        (hcl::*handle-existing-defpackage* (list :add))
	)

    ;;----------------------------------------
    ;; source-directory validation...
    ;;
    (assert (pathnamep source-directory)
	    (source-directory)
	    "source-directory not supplied, please edit build.lisp to specify the location of the source.")
  (let ((project-asd (merge-pathnames (format nil "~a.asd" system$)
                         source-directory)))
      (unless (probe-file project-asd)
        (error "~a not found. revise build.lisp if asd file is somewhere else." project-asd)))
    
    ;;;----------------------------------
    ;;; ok. build...
    ;;;
    (push source-directory asdf:*central-registry*)
    (asdf:operate 'asdf:load-op (intern system$ :keyword) :force force)))--- /project/cells-gtk/cvsroot/cells/cells-test/df-interference.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/df-interference.lisp	2006/06/07 16:28:57	1.1
;; -*- 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.
;;;
;;; 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 :cells)

(defvar *eex* 0)

(defmodel xx3 ()
  ((aa :initform (c-in 0) :initarg :aa :accessor aa)
   (dd :initform (c? (min 0 (+ (^cc) (^bb)))) :initarg :dd :accessor dd)
   (ddx :initform (c? (+ (^cc) (^bb))) :initarg :ddx :accessor ddx)
   (cc :initform (c? (+ (^aa) (^bb))) :initarg :cc :reader cc)
   (bb :initform (c? (* 2 (^aa))) :initarg :bb :accessor bb)
   (ee :initform (c? (+ (^aa) (^dd))) :initarg :ee :reader ee)
   (eex :initform (c?  (trc "in rule of eex, *eex* now" *eex*)
                    (+ (^aa) (^ddx))) :initarg :eex :reader eex)
   ))

(def-c-output aa ((self xx3))
    (trc nil "output aa:" new-value))

(def-c-output bb ((self xx3))
   (trc nil "output bb:" new-value))

(def-c-output cc ((self xx3))
    (trc nil "output cc:" new-value))

(def-c-output dd ((self xx3))
    (trc nil "output dd:" new-value))

(def-c-output ee ((self xx3))
   (trc nil "output ee:" new-value))


[66 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/echo-setf.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/echo-setf.lisp	2006/06/07 16:28:57	1.1

[113 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/hello-world-q.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/hello-world-q.lisp	2006/06/07 16:28:57	1.1

[194 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/hello-world.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/hello-world.lisp	2006/06/07 16:28:57	1.1

[272 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/internal-combustion.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/internal-combustion.lisp	2006/06/07 16:28:57	1.1

[632 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/lazy-propagation.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/lazy-propagation.lisp	2006/06/07 16:28:57	1.1

[714 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/output-setf.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/output-setf.lisp	2006/06/07 16:28:57	1.1

[771 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/person.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/person.lisp	2006/06/07 16:28:57	1.1

[1077 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/synapse-testing.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/synapse-testing.lisp	2006/06/07 16:28:57	1.1

[1154 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/test-cyclicity.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/test-cyclicity.lisp	2006/06/07 16:28:57	1.1

[1248 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/test-family.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/test-family.lisp	2006/06/07 16:28:57	1.1

[1406 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/test-kid-slotting.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/test-kid-slotting.lisp	2006/06/07 16:28:57	1.1

[1495 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/test-lazy.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/test-lazy.lisp	2006/06/07 16:28:57	1.1

[1614 lines skipped]
--- /project/cells-gtk/cvsroot/cells/cells-test/test.lisp	2006/06/07 16:28:57	NONE
+++ /project/cells-gtk/cvsroot/cells/cells-test/test.lisp	2006/06/07 16:28:57	1.1

[1754 lines skipped]


From pdenno at common-lisp.net  Wed Jun  7 16:28:58 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:28:58 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS cells/doc
Message-ID: <20060607162858.1951322007@common-lisp.net>

Update of /project/cells-gtk/cvsroot/cells/doc
In directory clnet:/tmp/cvs-serv32368/doc

Added Files:
	01-Cell-basics.lisp cell-doc.lisp hw.lisp 
Log Message:
new files


--- /project/cells-gtk/cvsroot/cells/doc/01-Cell-basics.lisp	2006/06/07 16:28:58	NONE
+++ /project/cells-gtk/cvsroot/cells/doc/01-Cell-basics.lisp	2006/06/07 16:28:58	1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cellsS -*-
;;;
;;; 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.
;;;
;;; 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 :cells)

#|

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.


cells
-----
think of a clos slot as a cell in a paper spreadsheet, a financial
modeling tool popular enough to make visi-calc the first business
killer app for microcomputers.

as a child i watched my father toil at home for hours over paper 
spreadsheets with pencil and slide rule. after he changed one value, 
he had to propagate that change to other cells by first remembering 
which other ones included the changed cell in their computation. 
then he had to do the calculations for those, erase, enter...
and then repeating that process to propagate those changes in a 
cascade across the paper.

visi-calc let my father take the formula he had in mind and 
put it in (declare it to) the electronic spreadsheet. then visi-calc 
could do the tedious work: recalculating, knowing what to recalculate, 
and knowing in what order to recalculate.

cells do for programmers what electronic spreadsheets did for my father.
without cells, clos slots are like cells of a paper spreadsheet. 
a single key-down event can cause a cascade of change throughout an 
application. the programmer has to arrange for it all to happen,
all in the right order: delete any selected text, insert 
the new character, re-wrap the text, update the undo mechanism, revisit
the menu statuses ("cut" is no longer enabled), update the scroll bars,
possibly scroll the window, flag the file as unsaved...

with cells, the programmer looks at program state differently. one
asks, "how could i compute, at any point of runtime, a value for 
a given slot of an arbitrary instance, based only on other runtime state 
(other slots of other instances)." great fun, by the way, as well as
enforcing good programming practices like encapsulation.

an example will help. consider indeed the state of the "cut" menu item. 
in some applications, programmers have a dozen places in their code
where they tend to the status of the cut menu item. one might be:

(defun do-clear (edit-structure)
  (when (selected-range edit-structure)
    <set up undo>
    <toss selected text>
    <etc><etc>
    (menu-item-enable *edit-cut* nil)
    (menu-item-enable *edit-copy* nil)
    (menu-item-enable *edit-clear* nil)))

other programmers wait until the user clicks on the edit menu, 
then decide just-in-time from program state whether the cut item 
should be enabled:

(defmethod prep-for-display ((m edit-menu))
  <lotsa other stuff>
  (when (typep (focus *app*) 'text-edit-widget)
    (menu-item-enable (find :cut (items m) :key #'item-name)
      (not (null (selected-range (focus *app*)))))))

this latter programmer is ready for cells, because they
have already shifted from imperative to declarative thinking;
they have learned to write code that works based not on what 
has happened lately, but instead only on the current program 
state (however it got that way). 

the cell programmer writes:

(make-instance 'menu-item
  :name :cut
  :label "cut"
  :cmd-key +control-x+
  :actor #'do-cut
  :enabled (c? (when (typep (focus *app*) 'text-edit-widget)
                 (not (null (selected-range (focus *app*)))))))

...and now they can forget the menu item exists as they work
on the rest of the application. the menu-item enabled status
will stay current (correct) as the selected-range changes
and as the focus itself changes as the user moves from field
to field.

that covers the spirit of cells. now let's look at the syntax
and mechanics, with examples you can execute once you have 
loaded the cells package. see the read-me.txt file in the
root directory into which the cello software was unzipped.

we'll model a falling stone, where the distance fallen is half
the product of the acceleration (due to gravity) and the
square of the time falling.

|#

(in-package :cells)

(defmodel stone ()
  ((accel :cell t :initarg :accel :initform 0 :accessor accel)
   (time-elapsed :cell t :initarg :time-elapsed
     :initform (c-in 0)
     :accessor time-elapsed)
   (distance :cell t :initarg :distance :initform 0 :accessor distance))
  (:default-initargs
      :distance (c? (/ (* (accel self)
                         (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

(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))

(def-c-output distance ((self stone))
  (format t "~&echo distance fallen: ~d feet" new-value))


#|
let's look at non-standard syntax found in the forms above,
in the order in which they appear:

    (defmodel ...

defmodel is just a defclass wrapper which also sets up plumbing for cells.

   ... :cell t ...

without this option, a model instance slot cannot be powered
by a cell (and cell slot access overhead is avoided). 

with this option, one can specify what kind of cell
is to be defined: ephemeral, delta or t (normal). we'll leave 
those esoteric cell slot types for another tutorial and just 
specify t to get normal cells (the ones used 99% of the time). 

   time-elapsed ... :initform (c-in 0)...

(c-in <value>) allows the cellular slot (or "cell", for short) 
to be setf'ed. these are inputs to the dataflow,
which usually flows from c? to c? but has to start somewhere. 
since modern interactve applications are event-driven, in
real-world cello apps most cv dataflow inputs are slots closely
corresponding to some system value, such as the position slots
of a cell-powered mouse class. moving on...

a naked value such as the 32 supplied for accel cannot be changed; a 
runtime error results from any such attempt. this makes cells faster,
because some plumbing can be skipped: no dependency gets recorded between
the distance traveled and the acceleration. on the other hand, a more
elaborate model might have the acceleration varying according to the distance
between the stone and earth (in which case we get into an advance
topic for another day, namely how to handle circularity.)

next: (:default-initargs
         :distance (c? (/ (* (accel self)
                             (expt (time-elapsed self) 2))
                          2)

c? associates a rule with a cellular slot (or "cell", for short). any
read operation on another cell (directly or during a function call)
establishes a dependency of distance on that cell -- unless that cell
can never change. why would a cell not be able to change?

cell internals enforce a rule that a cell with a naked value (ie, not wrapped 
in cv or c?) cannot be changed by client code (ok, (setf slot-value) is a backdoor).
cell internals enforce this, simply to make possible the optimization
of leaving off the overhead of recording a pointless dependency.

next: (def-c-output...

here is the signature for the def-c-output macro:

   (defmacro def-c-output (slotname (&optional (self-arg 'self)
                                    (new-varg 'new-value)
                                    (oldvarg 'old-value)
                                    (oldvargboundp 'old-value-boundp))
                      &body echo-body) ....)

def-c-output defines a generic method one can specialize on any of the four
parameters. the method gets called when the slot value changes, and during 
initial processing by:

    (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.

now evaluate the following:

|#

(defparameter *s2* (make-instance 'stone
                     :accel 32 ;; (constant) feet per second per second
                     :time-elapsed (c-in 0)))

#|

...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


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 
evaluating every rule so the dependencies get established, and 
propagating cell values outside the model (by calling the echo
methods) to make sure the model and outside world (if only the
system display) are consistent.

;-----------------------------------------------------------
now let's get moving:

|#

(setf (time-elapsed *s2*) 1)

#|
...and observe:
0> echo time-elapsed :new 1 :old 0 :oldp t
echo distance fallen: 16 feet

behind the scenes:
- the slot value time-elapsed got changed from 0 to 1
- the time-elapsed echo was called
- dependents on time-elapsed (here just distance) were recalculated
- go to the first step, this time for the distance slot

;-----------------------------------------------------------
to see some optimizations at work, set the cell time-elapsed to
the same value it already has:
|# 

(setf (time-elapsed *s2*) 1) 

#| observe:
nothing, since the slot-value did not in fact change.

;-----------------------------------------------------------
to test the enforcement of the cell stricture against
modifying cells holding naked values:
|#

(handler-case
    (setf (accel *s2*) 10)
  (t (error) (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 #<simple-error @ #x210925f2>

;-----------------------------------------------------------
nor may ruled cells be modified arbitrarily:
|#

(handler-case
    (setf (distance *s2*) 42)
  (t (error) (trc "error is" error)
    error))

#| observe:
c-setting-debug > ruled  distance in stone may not be setf'ed
0> error is #<simple-error @ #x2123e392>

;-----------------------------------------------------------
aside from c?, cv, and def-c-output, 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
form simple trees navigable up and down.

model-objects also have slots for md-name and md-value (don't
worry camelcase-haters, that is a declining feature of my code).
md-name lets the family trees we build be treated as namespaces.
md-value just turns out to be very handy for a lot of things. for
example, a check-box instance needs some place to indicate its 
boolean state. 

now let's see family in action, using code from the handbook of
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.

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 
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.

evaluate:
|#

(defmodel summer (family)
  ()
  (:default-initargs
      :kids (c-in nil) ;; or we cannot add any addend kids later
    :md-value (c? (reduce #'+ (kids self)
                   :initial-value 0
                   :key #'md-value))))

(def-c-output .md-value ((self summer))
  (trc "the sum of the values of the kids is" new-value))

(def-c-output .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
;
(defparameter *f1* (make-instance 'summer))

#|
observe:
0> the sum of the values of the kids is 0
0> the values of the kids are nil

;----------------------------------------------------------|#

(push (make-instance 'model :md-value 1) (kids *f1*))

#| observe:
0> the values of the kids are (1)
0> the sum of the values of the kids is 1

;----------------------------------------------------------|#

(push (make-instance 'model :md-value 2) (kids *f1*))

#| observe:
0> the values of the kids are (2 1)
0> the sum of the values of the kids is 3

;----------------------------------------------------------|#

(setf (kids *f1*) nil)

#| observe:
0> the values of the kids are nil
0> the sum of the values of the kids is 0

now before closing, it occurs to me you'll need a little

[33 lines skipped]
--- /project/cells-gtk/cvsroot/cells/doc/cell-doc.lisp	2006/06/07 16:28:58	NONE
+++ /project/cells-gtk/cvsroot/cells/doc/cell-doc.lisp	2006/06/07 16:28:58	1.1

[215 lines skipped]
--- /project/cells-gtk/cvsroot/cells/doc/hw.lisp	2006/06/07 16:28:58	NONE
+++ /project/cells-gtk/cvsroot/cells/doc/hw.lisp	2006/06/07 16:28:58	1.1

[287 lines skipped]


From pdenno at common-lisp.net  Wed Jun  7 16:28:58 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:28:58 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS cells/utils-kt
Message-ID: <20060607162858.5FA02232B8@common-lisp.net>

Update of /project/cells-gtk/cvsroot/cells/utils-kt
In directory clnet:/tmp/cvs-serv32368/utils-kt

Added Files:
	debug.lisp defpackage.lisp detritus.lisp flow-control.lisp 
	quad.lisp strings.lisp utils-kt.asd 
Log Message:
new files


--- /project/cells-gtk/cvsroot/cells/utils-kt/debug.lisp	2006/06/07 16:28:58	NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/debug.lisp	2006/06/07 16:28:58	1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
;;;
;;; Copyright (c) 1995,2004 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)

(defparameter *trcdepth* 0)
(defvar *count* nil)
(defvar *counting* nil)
(defvar *dbg*)
(defvar *stop* nil)

(defun utils-kt-reset ()
  (setf *count* nil
    *stop* nil
    *dbg* nil
    *trcdepth* 0))

;----------- trc -------------------------------------------

(defun trcdepth-reset ()
  (setf *trcdepth* 0))

(defmacro trc (tgt-form &rest os
                &aux (wrapper (if (macro-function 'without-c-dependency)
                                  'without-c-dependency 'progn)))
  (if (eql tgt-form 'nil)
      '(progn)
    (if (stringp tgt-form)
        `(,wrapper
          (call-trc t ,tgt-form , at os))
      (let ((tgt (gensym)))
        `(,wrapper
          (bif (,tgt ,tgt-form)
            (if (trcp ,tgt)
                (progn
                  (assert (stringp ,(car os)))
                  (call-trc t , at os)) ;;,(car os) ,tgt ,@(cdr os)))
              (progn
                ;;(break "trcfailed")
                (count-it :trcfailed)))
            (count-it :tgtnileval)))))))

(defun call-trc (stream s &rest os)
  (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
          *trcdepth*)
        (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
      (format stream "~&"))
    
    (format stream "~a" s)
    (let (pkwp)
      (dolist (o os)
        (format stream (if pkwp " ~s" " | ~s") o)
        (setf pkwp (keywordp o))))
    (values))

(defun call-trc-to-string (fmt$ &rest fmt-args)
  (let ((o$ (make-array '(0) :element-type 'base-char
              :fill-pointer 0 :adjustable t)))
    (with-output-to-string (os-stream o$)
      (apply 'call-trc os-stream fmt$ fmt-args))
    o$))

#+findtrcevalnils
(defmethod trcp :around (other)
  (unless (call-next-method other)(break)))

(defmethod trcp (other)
  (eq other t))
  
(defmethod trcp (($ string))
  t)
  
(defun trcdepth-incf ()
  (incf *trcdepth*))
  
(defun trcdepth-decf ()
  (format t "decrementing trc depth ~d" *trcdepth*)
  (decf *trcdepth*))
  
(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body )
  `(let ((*trcdepth* (if *trcdepth*
                         (1+ *trcdepth*)
                       0)))
     ,(when banner `(when (>= *trcdepth* ,min)
                      (if (< *trcdepth* ,max)
                          (trc , at banner)
                        (progn
                          (break "excess trace notttt!!! ~d" *trcdepth*) ;; , at banner)
                          nil))))
     (when (< *trcdepth* ,max)
       , at body)))

(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body )
  (declare (ignore min max banner))
  `(progn , at body))
  
;------ eko --------------------------------------


(defmacro eko ((&rest trcargs) &rest body)
  (let ((result (gensym)))
     `(let ((,result , at body))
         (trc ,(car trcargs) :=> ,result ,@(cdr trcargs))
         ,result)))

(defmacro eko-if ((test &rest trcargs) &rest body)
  (let ((result (gensym)))
     `(let ((,result , at body))
         (when ,test
           (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)))
         ,result)))

(defmacro ek (label &rest body)
  (let ((result (gensym)))
     `(let ((,result (, at body)))
         (when ,label
           (trc ,label ,result))
         ,result)))

;------------- counting ---------------------------


(defmacro with-counts ((onp &rest msg) &body body)
  `(if ,onp
       (let ((*counting* (cons t *counting*)))
         (prog2
           (count-clear , at msg)
             (progn , at body)
           (show-count t , at msg)))
     (progn , at body)))

(defun count-of (key)
  (cdr (assoc key *count* :key 'car)))
  
(defun count-clear (&rest msg)
  (declare (ignorable msg))
  (format t "~&count-clear > ~a" msg)
  (setf *count* nil))

(defmacro count-it (&rest keys)
  `(when *counting*
     (call-count-it , at keys)))

(defun call-count-it (&rest keys)
    (declare (ignorable keys))
  ;;; (when (eql :TGTNILEVAL (car keys))(break))
  (let ((entry (assoc keys *count* :test #'equal)))
      (if entry
          (setf (cdr entry) (1+ (cdr entry)))
        (push (cons keys 1) *count*))))

(defun show-count (clearp &rest msg)
  (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg)
  (let ((res (sort (copy-list *count*) (lambda (v1 v2)
                                           (let ((v1$ (symbol-name (caar v1)))
                                                 (v2$ (symbol-name (caar v2))))
                                             (if (string= v1$ v2$)
                                                 (< (cdr v1) (cdr v2))
                                               (string< v1$ v2$))))))
        )
     (loop for entry in res
         for occs = (cdr entry)
         when (plusp occs)
           sum occs into running
           and do (format t "~&~4d ... ~2d ... ~s" running occs (car entry))))
  (when clearp (count-clear "show-count")))
  

;-------------------- timex ---------------------------------

(eval-when (compile eval load)
  (export '(timex)))

(defmacro timex ((onp &rest trcargs) &body body)
  `(if ,onp
       (prog1
           (time (progn , at body))
         (trc "timing was of" , at trcargs))
     (progn , at body)))

#+save
(defun dbg-time-report (cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes)
  (trc "cpu-gc-user" cpu-gc-user)
  (trc "cpu-gc-sys" cpu-gc-sys)
  (trc "cpu-tot-user" cpu-tot-user)
  (trc "cpu-tot-sys" cpu-tot-sys)
  (trc "<non-gc user cpu>" (- cpu-tot-user cpu-gc-user))
  (trc "<non-gc sys cpu>" (- cpu-tot-sys cpu-gc-sys))
  (trc "conses" conses)
  (trc "other-bytes" other-bytes)
  (trc "static-bytes" static-bytes)
  (excl::time-report cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes))

;---------------- Metrics -------------------

(defmacro with-metrics ((countp timep &rest trcargs) form-measured &body postlude)
  `(with-counts (,countp , at trcargs)
     (timex (,timep , at trcargs)
       ,form-measured)
     , at postlude))

--- /project/cells-gtk/cvsroot/cells/utils-kt/defpackage.lisp	2006/06/07 16:28:58	NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/defpackage.lisp	2006/06/07 16:28:58	1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
;;;
;;; Copyright (c) 1995,2004 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 :cl-user)

(defpackage :utils-kt
  (:nicknames #:ukt)
  (:use #:common-lisp
    #-(or cormanlisp cmu sbcl) #:clos
    #+sbcl #:sb-mop
    #+mcl #:ccl)
  (:export #:utils-kt-reset
    #:eko #:count-it #:count-of #:trc #:trcp 
    #:wdbg #:maptimes #:bwhen #:bif #:xor
    #:with-dynamic-fn #:last1 #:packed-flat! #:with-metrics 
    #:shortc
    #:intern$
    #:define-constant #:*count* #:*stop*
    #:*dbg* #:*trcdepth*
    #:make-fifo-queue #:fifo-add #:fifo-empty #:fifo-pop #:mapfifo #:with-gensyms
    #:ensure-gethash

    #-(or lispworks mcl) #:true
    #+clisp #:slot-definition-name
))
--- /project/cells-gtk/cvsroot/cells/utils-kt/detritus.lisp	2006/06/07 16:28:58	NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/detritus.lisp	2006/06/07 16:28:58	1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
;;;
;;; 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.
;;;
;;; 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)

(defmacro wdbg (&body body)
  `(let ((*dbg* t))
     , at body))

#+mcl
(defun class-slots (c)
  (nconc (copy-list (class-class-slots c))
         (copy-list (class-instance-slots c))))


#-(or lispworks mcl)
(defun true (it) (declare (ignore it)) t)
(defun false (it) (declare (ignore it)))
(defun xor (c1 c2)
  (if c1 (not c2) c2))

(defun make-fifo-queue () (cons nil nil))
(defun fifo-add (q new)
  (if (car q)
      (let ((last (cdr q))
            (newlast (list new)))
        (rplacd last newlast)
        (rplacd q newlast))
    (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-pop (q)
  (prog1
      (caar q)
    (rplaca q (cdar q))))

(defun mapfifo (fn q)
  (loop until (fifo-empty q)
      do (funcall fn (fifo-pop q))))

#+test
(let ((*print-circle* t))
  (let ((q (make-fifo-queue)))
    (loop for n below 3
      do (fifo-add q n))
    (fifo-queue q)
    (loop until (fifo-empty q)
          do (print (fifo-pop q)))))

(defmacro define-constant (name value &optional docstring)
  "Define a constant properly.  If NAME is unbound, DEFCONSTANT
it to VALUE.  If it is already bound, and it is EQUAL to VALUE,
reuse the SYMBOL-VALUE of NAME.  Otherwise, DEFCONSTANT it again,
resulting in implementation-specific behavior."
  `(defconstant ,name
     (if (not (boundp ',name))
	 ,value
	 (let ((value ,value))
	   (if (equal value (symbol-value ',name))
	       (symbol-value ',name)
	       value)))
     ,@(when docstring (list docstring))))

(defmacro with-gensyms (syms &body body)
  "Paul Graham ON LISP pg 145. Used in macros to avoid variable capture."
  `(let ,(mapcar #'(lambda (s) 
		     `(,s (gensym)))
	  syms)
     , at body))


(defmacro ensure-gethash (object ht default)
  "Sam Steingold: Just like GETHASH with the default argument,
   but DEFAULT is only evaluated when OBJECT is not found and
   in that case the value of DEFAULT is placed into (GETHASH OBJECT HT)."
  (with-gensyms (obj tab)
   `(let ((,obj ,object) (,tab ,ht))
      (or (gethash ,obj ,tab)
	  (setf (gethash ,obj ,tab) ,default)))))


--- /project/cells-gtk/cvsroot/cells/utils-kt/flow-control.lisp	2006/06/07 16:28:58	NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/flow-control.lisp	2006/06/07 16:28:58	1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
;;; 
;;;
;;; 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.
;;;
;;; 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)

(defun last1 (thing)
     (car (last thing)))

(defun max-if (&rest values)
  (loop for x in values when x maximize x))

(defun min-max-of (v1 v2)
  (values (min-if v1 v2) (max-if v1 v2)))


[100 lines skipped]
--- /project/cells-gtk/cvsroot/cells/utils-kt/quad.lisp	2006/06/07 16:28:58	NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/quad.lisp	2006/06/07 16:28:58	1.1

[226 lines skipped]
--- /project/cells-gtk/cvsroot/cells/utils-kt/strings.lisp	2006/06/07 16:28:58	NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/strings.lisp	2006/06/07 16:28:58	1.1

[434 lines skipped]
--- /project/cells-gtk/cvsroot/cells/utils-kt/utils-kt.asd	2006/06/07 16:28:58	NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/utils-kt.asd	2006/06/07 16:28:58	1.1

[461 lines skipped]


From pdenno at common-lisp.net  Wed Jun  7 16:32:41 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:32:41 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060607163241.8933361020@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv1632/root/cells-gtk

Modified Files:
	conditions.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/cells-gtk/conditions.lisp	2006/02/16 18:12:15	1.3
+++ /project/cells-gtk/cvsroot/root/cells-gtk/conditions.lisp	2006/06/07 16:32:41	1.4
@@ -34,5 +34,5 @@
 
 (define-condition gtk-user-signals-quit (condition) ())
 
-(export '(gtk-user-signals-quit gtk-continuable-error gtk-report-error))
+
 



From pdenno at common-lisp.net  Wed Jun  7 16:35:03 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:35:03 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060607163503.75E2963030@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv1752/root/cells-gtk

Modified Files:
	dialogs.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/cells-gtk/dialogs.lisp	2006/02/16 18:12:54	1.6
+++ /project/cells-gtk/cvsroot/root/cells-gtk/dialogs.lisp	2006/06/07 16:35:03	1.7
@@ -151,5 +151,3 @@
   (let ((dialog (to-be (apply #'mk-file-chooser-dialog inits))))
     (md-value dialog)))
 
-(eval-when (compile load eval)
-  (export '(show-message file-chooser)))
\ No newline at end of file



From pdenno at common-lisp.net  Wed Jun  7 16:36:17 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:36:17 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060607163617.D73E863036@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv1814/root/cells-gtk

Modified Files:
	display.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/cells-gtk/display.lisp	2005/02/16 22:18:05	1.3
+++ /project/cells-gtk/cvsroot/root/cells-gtk/display.lisp	2006/06/07 16:36:17	1.4
@@ -153,5 +153,3 @@
 	(:bottom 3)
 	(t 0)))))
 
-(eval-when (compile load eval)
-  (export '(with-markup push-message pop-message pulse)))
\ No newline at end of file



From pdenno at common-lisp.net  Wed Jun  7 16:38:52 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:38:52 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060607163852.6B88663030@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv1881/root/cells-gtk

Modified Files:
	gtk-app.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/cells-gtk/gtk-app.lisp	2006/02/16 21:56:17	1.17
+++ /project/cells-gtk/cvsroot/root/cells-gtk/gtk-app.lisp	2006/06/07 16:38:52	1.18
@@ -152,7 +152,4 @@
     (setf *gtk-loaded* t))
   (gtk-reset))
 
-(eval-when (compile load eval)
-  (export '(gtk-app gtk-reset cells-gtk-init title icon tooltips tooltips-enable tooltips-delay
-             start-app gtk-global-callback-register gtk-global-callback-funcall)))
 



From pdenno at common-lisp.net  Wed Jun  7 16:40:06 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:40:06 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060607164006.4893363036@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv2016/root/cells-gtk

Modified Files:
	drawing.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/cells-gtk/drawing.lisp	2006/02/19 20:11:03	1.6
+++ /project/cells-gtk/cvsroot/root/cells-gtk/drawing.lisp	2006/06/07 16:40:06	1.7
@@ -220,5 +220,3 @@
 (defvar *my-pixmap* nil)
 
 
-(export '(*gcontext* with-pixmap with-gc draw-line draw-text draw-rectangle insert-pixmap
-		     register-gobject))
\ No newline at end of file



From pdenno at common-lisp.net  Wed Jun  7 16:41:38 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:41:38 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060607164138.73C3663036@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv2058/root/cells-gtk

Modified Files:
	menus.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/cells-gtk/menus.lisp	2006/02/19 20:12:16	1.13
+++ /project/cells-gtk/cvsroot/root/cells-gtk/menus.lisp	2006/06/07 16:41:38	1.14
@@ -18,8 +18,6 @@
 
 (in-package :cgtk)
 
-(export '(cgtk-set-active-item-by-path))
-
 (defmacro with-tree-iters (vars &body body)
   `(let (,@(loop for var in vars collect `(,var (gtk-adds-tree-iter-new))))
      (unwind-protect 
@@ -305,4 +303,3 @@
 (def-widget tearoff-menu-item (menu-item)
   () () ())
 
-(export '(gtk-combo-box-set-active))
\ No newline at end of file



From pdenno at common-lisp.net  Wed Jun  7 16:43:08 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:43:08 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060607164308.4125B63036@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv2107/root/cells-gtk

Modified Files:
	packages.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp	2006/02/19 20:12:58	1.5
+++ /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp	2006/06/07 16:43:08	1.6
@@ -16,10 +16,61 @@
  
 |#
 
+(in-package :cl-user)
+
 (defpackage :cells-gtk
   (:nicknames :cgtk)
-  (:use :common-lisp :pod :cells :gtk-ffi))
-
-
-
-
+  (:use :common-lisp :pod :cells :gtk-ffi)
+  (:export #:gtk-user-signals-quit
+           #:gtk-continuable-error
+           #:gtk-report-error
+           #:cgtk-set-active-item-by-path
+           #:gtk-combo-box-set-active
+           #:show-message
+           #:file-chooser
+           #:with-markup
+           #:push-message
+           #:pop-message
+           #:pulse
+           #:gtk-drawing-set-handlers
+           #:*gcontext*
+           #:with-pixmap
+           #:with-gc
+           #:draw-line
+           #:draw-text
+           #:draw-rectangle
+           #:insert-pixmap
+           #:register-gobject
+           #:gtk-app
+           #:gtk-reset
+           #:cells-gtk-init
+           #:title
+           #:icon
+           #:tooltips
+           #:tooltips-enable
+           #:tooltips-delay
+           #:start-app
+           #:gtk-global-callback-register
+           #:gtk-global-callback-funcall
+           #:def-populate-adds
+           #:populate-adds
+           #:with-text-iters
+           #:text-buffer-get-text
+           #:text-buffer-delete-text
+           #:text-buffer-insert-text
+           #:text-buffer-modified-p
+           #:text-view-scroll-to-position
+           #:gtk-text-buffer-get-iter-at-offset
+           #:gtk-text-buffer-create-mark
+           #:gtk-text-view-set-wrap-mode
+           #:gtk-text-view-set-editable
+           #:gtk-text-buffer-move-mark
+           #:gtk-text-view-scroll-mark-onscreen
+           #:mk-listbox
+           #:mk-treebox
+           #:def-columns
+           #:callback
+           #:callback-if
+           #:timeout-add
+           #:focus
+           #:widget-id))



From pdenno at common-lisp.net  Wed Jun  7 16:44:23 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:44:23 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060607164423.705B663036@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv2155/root/cells-gtk

Modified Files:
	textview.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/cells-gtk/textview.lisp	2006/02/19 20:13:26	1.9
+++ /project/cells-gtk/cvsroot/root/cells-gtk/textview.lisp	2006/06/07 16:44:23	1.10
@@ -150,12 +150,6 @@
   (gtk-text-buffer-set-modified (id buffer) val))
 
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(def-populate-adds populate-adds with-text-iters text-buffer-get-text
-            text-buffer-delete-text text-buffer-insert-text text-buffer-modified-p
-	    text-view-scroll-to-position gtk-text-buffer-get-iter-at-offset
-	    gtk-text-buffer-create-mark gtk-text-view-set-wrap-mode gtk-text-view-set-editable
-	    gtk-text-buffer-move-mark gtk-text-view-scroll-mark-onscreen)))
 
 
 



From pdenno at common-lisp.net  Wed Jun  7 16:48:59 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:48:59 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060607164859.CC1A567001@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv3724/root/cells-gtk

Modified Files:
	tree-view.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/cells-gtk/tree-view.lisp	2006/02/19 20:13:51	1.15
+++ /project/cells-gtk/cvsroot/root/cells-gtk/tree-view.lisp	2006/06/07 16:48:59	1.16
@@ -260,5 +260,3 @@
   `(list ,@(loop for (type inits renderer) in args collect
 		 `(list ,type ',inits ,renderer))))
 
-(eval-when (compile load eval)
-  (export '(mk-listbox mk-treebox def-columns)))



From pdenno at common-lisp.net  Wed Jun  7 16:50:15 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:50:15 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060607165015.3A4E167003@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv3844/root/cells-gtk

Modified Files:
	widgets.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/cells-gtk/widgets.lisp	2006/02/19 20:14:26	1.18
+++ /project/cells-gtk/cvsroot/root/cells-gtk/widgets.lisp	2006/06/07 16:50:15	1.19
@@ -387,5 +387,3 @@
 (defun widget-id (widget)
   (id widget))
 
-(eval-when (compile load eval)
-  (export '(callback callback-if timeout-add focus widget-id)))



From pdenno at common-lisp.net  Wed Jun  7 16:51:34 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:51:34 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/gtk-ffi
Message-ID: <20060607165134.A2DE567003@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/gtk-ffi
In directory clnet:/tmp/cvs-serv3884/root/gtk-ffi

Modified Files:
	gtk-core.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-core.lisp	2006/02/19 20:15:07	1.8
+++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-core.lisp	2006/06/07 16:51:34	1.9
@@ -77,8 +77,6 @@
           (funcall fn gva)
       (cffi:foreign-free gva)))
 
-(eval-when (compile load eval) (export 'with-g-value))
-
 #+test
 (def-gtk-lib-functions :gobject
     (g-value-set-string ((value c-pointer)



From pdenno at common-lisp.net  Wed Jun  7 16:57:38 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 12:57:38 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/gtk-ffi
Message-ID: <20060607165738.480FA67003@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/gtk-ffi
In directory clnet:/tmp/cvs-serv4089/root/gtk-ffi

Modified Files:
	gtk-ffi.asd 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.asd	2006/02/19 20:16:57	1.13
+++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.asd	2006/06/07 16:57:38	1.14
@@ -13,7 +13,8 @@
   :name "gtk-ffi"
   :depends-on (:cells :pod-utils :cffi :cffi-uffi-compat)
   :components
-  ((:file "gtk-ffi")
+  ((:file "package")
+   (:file "gtk-ffi" :depends-on ("package"))
    (:file "gtk-core" :depends-on ("gtk-ffi"))
    (:file "gtk-other" :depends-on ("gtk-ffi"))
    (:file "gtk-button" :depends-on ("gtk-ffi"))



From pdenno at common-lisp.net  Wed Jun  7 17:00:25 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 13:00:25 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/gtk-ffi
Message-ID: <20060607170025.B60876800A@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/gtk-ffi
In directory clnet:/tmp/cvs-serv5638/root/gtk-ffi

Modified Files:
	gtk-ffi.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp	2006/06/01 14:16:28	1.20
+++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp	2006/06/07 17:00:25	1.21
@@ -16,11 +16,6 @@
  
 |#
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (unless (find-package :gtk-ffi)
-      (defpackage :gtk-ffi
-	(:use :common-lisp :pod))))
-
 (in-package :gtk-ffi)
 
 ;;; POD throw-away utility to convert hello-c/uffi to cffi
@@ -50,8 +45,12 @@
 		      funcs))
 	     *standard-output*))))
 
+;;keep SBCL happy
+(defconstant +c-null+ 
+  (if (boundp '+c-null+)
+      (symbol-value '+c-null+)
+    (cffi:null-pointer)))
 
-(defconstant +c-null+ (cffi:null-pointer)) 
 (defvar *gtk-debug* nil)
 
 ;;; ==============  Define CFFI types, and their translations.... 
@@ -136,13 +135,13 @@
 				 #+win32 "libgtk-win32-2.0-0.dll" 
 				 #+macosx "libgtk-win32-2.0-0.dylib")
       #+libcellsgtk
-      (cffi:load-foreign-library #+cffi-features:unix "libcellsgtk.so" 
+      (cffi:load-foreign-library #+cffi-features:unix 
+				 (merge-pathnames "libcellsgtk.so" #.*compile-file-pathname*)
 				 #+win32 "libcellsgtk.dll" 
 				 #+macosx "libcellsgtk.dylib")))
 ) ; eval
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(+c-null+ int-slot-indexed load-gtk-libs))
   (defun gtk-function-name (lisp-name)
     (substitute #\_ #\- lisp-name))
 
@@ -425,9 +424,5 @@
 (defun cast (ptr type)
   (deref-pointer-runtime-typed ptr (ffi-to-uffi-type type)))
 
-(eval-when (compile load eval)
-  (export '(uint c-pointer c-ptr-null c-array-ptr c-ptr c-string sint32 uint32 uint8 boolean
-	    ulong int long single-float double-float otherwise *gtk-debug* load-gtk-libs
-	    col-type-to-ffi-type deref-pointer-runtime-typed gtk-tree-iter +c-null+)))
 
 



From pdenno at common-lisp.net  Wed Jun  7 17:02:06 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 13:02:06 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/gtk-ffi
Message-ID: <20060607170206.577566800C@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/gtk-ffi
In directory clnet:/tmp/cvs-serv5703/root/gtk-ffi

Modified Files:
	gtk-utilities.lisp 
Log Message:
Applied patches from Andras Simon

--- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-utilities.lisp	2006/06/01 14:18:22	1.20
+++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-utilities.lisp	2006/06/07 17:02:06	1.21
@@ -210,7 +210,7 @@
     (ecase col-type
       ((:string :icon)
        (get-gtk-string
-        (cffi:make-pointer (cffi:mem-aref buffer :pointer 0) :cstring)))
+        (cffi:make-pointer (cffi:mem-aref buffer :pointer 0))))
       (:boolean (not (zerop (cffi:mem-aref buffer :unsigned-char 0))))
       (:date (cffi:mem-aref buffer :FLOAT 0))
       (:int (cffi:mem-aref buffer :int 0))
@@ -268,15 +268,4 @@
         collect (cffi:foreign-slot-value lst-address 'gslist 'data)
         finally (g-slist-free glist))))
 
-(eval-when (compile load eval)
-  (export '(gtk-signal-connect gtk-signal-connect-swap gtk-object-set-property
-             with-gtk-string get-gtk-string to-gtk-string 
-             with-gdk-threads make-gtk-tree-iter with-tree-iter
-             gtk-widget-set-popup gvi
-             gtk-list-store-new gtk-list-store-set gtk-list-store-set-items
-             gtk-tree-store-new gtk-tree-store-set gtk-tree-store-set-kids
-             gtk-tree-model-get-cell
-             gtk-tree-view-render-cell
-             gtk-file-chooser-get-filenames-strs
-             )))
 



From pdenno at common-lisp.net  Wed Jun  7 17:20:10 2006
From: pdenno at common-lisp.net (pdenno)
Date: Wed,  7 Jun 2006 13:20:10 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS public_html
Message-ID: <20060607172010.822026A006@common-lisp.net>

Update of /project/cells-gtk/cvsroot/public_html
In directory clnet:/tmp/cvs-serv7775/public_html

Modified Files:
	index.html 
Log Message:
Announce in NEWS adds to CVS.

--- /project/cells-gtk/cvsroot/public_html/index.html	2006/06/01 14:14:21	1.27
+++ /project/cells-gtk/cvsroot/public_html/index.html	2006/06/07 17:20:10	1.28
@@ -74,13 +74,22 @@
 <h1 id='news'>News</h1>
 
 <ul>
+  <li> <strong>2006-06-07</strong> 
+          <ul>
+           <li>Patches from Andras Simon allow Cells-GTK to load without complaints under
+              SBCL. (Tested under SBCL 0.9.12).</li>
+          <li>The patch also allows libcellsgtk.so to be located wherever it
+              was built, rather than having to copy it to /usr/lib, etc.</li>
+          <li>A version of Cells (What was called "Cells 2" at some point) was added to CVS. 
+              Having our own copy should help keep things stable as Cells evolves.</li>
+         </ul>
   <li> <strong>2006-06-01</strong> Patches from Marco Gidde make Cells-GTK work better under SBCL. 
         These patches were applied to the CVS repository, but are not in any snapshot yet. See the repository 
         versions of gtk-ffi/gtk-utilities.lisp pod-utils/utils.lisp and gtk-ffi/gtk-ffi.lisp for
         the fixes, or read the <a href='http://common-lisp.net/pipermail/cells-gtk-devel/2006-May/000171.html'>
-        mail</a> from Marco. It includes the patches.
+        mail</a> from Marco. It includes the patches.</li>
   <li> <strong>2006-02-16</strong> Native CFFI now used in most of the code. There is a 
-       <a href="ftp://common-lisp.net/pub/project/cells-gtk/cells-gtk-2006-02-16.tgz">snapshot release</a>.
+       <a href="ftp://common-lisp.net/pub/project/cells-gtk/cells-gtk-2006-02-16.tgz">snapshot release</a>.</li>
   <li> <strong>2006-01-03</strong> BIG NEWS! cells-gtk now runs under <a href="http://clisp.cons.org">CLISP</a>
    and uses <a href="http://common-lisp.net/project/cffi/">CFFI</a>, not Hello-c for its foreign function interface. 
    The 2006-01-03 tarball reflects these changes. Especial thanks to Novikov Leonid, who did the CLISP port
@@ -94,7 +103,7 @@
       <a href="http://common-lisp.net/pipermail/cells-gtk-devel/2006-January.txt">note</a> in
       the cells-gtk-devel archive for January 2006.
    </ul>    
-   If I didn't break anything, it also works with CLISP/PC and Lispworks/PC.</li>
+   If I didn't break anything, it also works with CLISP/Win32 and Lispworks/Win32.</li>
   <li> <strong>2005-11-15</strong> We now provide the win32 .dll
    and linux .so for libcellsgtk. They are:
    <a href="ftp://common-lisp.net/pub/project/cells-gtk/libcellsgtk.so">this for linux</a> and 



From pdenno at common-lisp.net  Thu Jun  8 14:58:24 2006
From: pdenno at common-lisp.net (pdenno)
Date: Thu,  8 Jun 2006 10:58:24 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/gtk-ffi
Message-ID: <20060608145824.8D5CC32008@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/gtk-ffi
In directory clnet:/tmp/cvs-serv16868

Added Files:
	package.lisp 
Log Message:
new file


--- /project/cells-gtk/cvsroot/root/gtk-ffi/package.lisp	2006/06/08 14:58:24	NONE
+++ /project/cells-gtk/cvsroot/root/gtk-ffi/package.lisp	2006/06/08 14:58:24	1.1
#|

 Gtk ffi

 Copyright (c) 2004 by Vasilis Margioulas <vasilism at sch.gr>

 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 :cl-user)

(defpackage :gtk-ffi
  (:use :common-lisp :pod)
  (:export #:+c-null+
	   #:int-slot-indexed
	   #:load-gtk-libs
	   #:uint
	   #:c-pointer
	   #:c-ptr-null
	   #:c-array-ptr
	   #:c-ptr
	   #:c-string
	   #:sint32
	   #:uint32
	   #:uint8
	   #:boolean
	   #:ulong
	   #:int
	   #:long
	   #:single-float
	   #:double-float
	   #:otherwise
	   #:*gtk-debug*
	   #:load-gtk-libs
	   #:col-type-to-ffi-type
	   #:deref-pointer-runtime-typed
	   #:gtk-tree-iter
	   #:with-g-value
	   #:gtk-signal-connect
	   #:gtk-signal-connect-swap
	   #:gtk-object-set-property
	   #:with-gtk-string
	   #:get-gtk-string
	   #:to-gtk-string
	   #:with-gdk-threads
	   #:make-gtk-tree-iter
	   #:with-tree-iter
	   #:gtk-widget-set-popup
	   #:gvi
	   #:gtk-list-store-new
	   #:gtk-list-store-set
	   #:gtk-list-store-set-items
	   #:gtk-tree-store-new
	   #:gtk-tree-store-set
	   #:gtk-tree-store-set-kids
	   #:gtk-tree-model-get-cell
	   #:gtk-tree-view-render-cell
	   #:gtk-file-chooser-get-filenames-strs))



From asimon at common-lisp.net  Tue Jun 20 14:44:42 2006
From: asimon at common-lisp.net (asimon)
Date: Tue, 20 Jun 2006 10:44:42 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/gtk-ffi
Message-ID: <20060620144442.6DF3852000@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/gtk-ffi
In directory clnet:/tmp/cvs-serv28938/gtk-ffi

Modified Files:
	package.lisp 
Log Message:
Move export to the package def

--- /project/cells-gtk/cvsroot/root/gtk-ffi/package.lisp	2006/06/08 14:58:24	1.1
+++ /project/cells-gtk/cvsroot/root/gtk-ffi/package.lisp	2006/06/20 14:44:42	1.2
@@ -64,5 +64,6 @@
 	   #:gtk-tree-store-set-kids
 	   #:gtk-tree-model-get-cell
 	   #:gtk-tree-view-render-cell
-	   #:gtk-file-chooser-get-filenames-strs))
+	   #:gtk-file-chooser-get-filenames-strs
+	   #:gtk-drawing-set-handlers))
 



From asimon at common-lisp.net  Tue Jun 20 14:45:47 2006
From: asimon at common-lisp.net (asimon)
Date: Tue, 20 Jun 2006 10:45:47 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060620144547.8AC9C54060@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv30524/cells-gtk

Modified Files:
	packages.lisp 
Log Message:
Move export to the package def

--- /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp	2006/06/07 16:43:08	1.6
+++ /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp	2006/06/20 14:45:47	1.7
@@ -32,7 +32,6 @@
            #:push-message
            #:pop-message
            #:pulse
-           #:gtk-drawing-set-handlers
            #:*gcontext*
            #:with-pixmap
            #:with-gc



From asimon at common-lisp.net  Tue Jun 20 14:45:59 2006
From: asimon at common-lisp.net (asimon)
Date: Tue, 20 Jun 2006 10:45:59 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk
Message-ID: <20060620144559.2B4AA54060@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory clnet:/tmp/cvs-serv30553/cells-gtk

Modified Files:
	drawing.lisp 
Log Message:
Move export to the package def

--- /project/cells-gtk/cvsroot/root/cells-gtk/drawing.lisp	2006/06/07 16:40:06	1.7
+++ /project/cells-gtk/cvsroot/root/cells-gtk/drawing.lisp	2006/06/20 14:45:59	1.8
@@ -69,7 +69,6 @@
   (gtk-signal-connect-swap widget "expose-event"
 			   (cffi:get-callback 'drawing-expose-event-handler)
 			   :data data))
-(export '(gtk-drawing-set-handlers))
 
 ;;;============================================================================
 (in-package :cgtk)



From pdenno at common-lisp.net  Fri Jun 30 15:24:21 2006
From: pdenno at common-lisp.net (pdenno)
Date: Fri, 30 Jun 2006 11:24:21 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS 
Message-ID: <20060630152421.1F36C7C039@common-lisp.net>

Update of /project/cells-gtk/cvsroot
In directory clnet:/tmp/cvs-serv16383

Modified Files:
	load.lisp 
Log Message:
gtk-demo now exported, so no ::

--- /project/cells-gtk/cvsroot/load.lisp	2006/02/19 20:07:06	1.2
+++ /project/cells-gtk/cvsroot/load.lisp	2006/06/30 15:24:21	1.3
@@ -38,7 +38,7 @@
   (asdf:oos 'asdf:load-op :cells-gtk)
   (asdf:oos 'asdf:load-op :test-gtk))
 
-(format t "~3% Done! Now try (test-gtk::gtk-demo)")
+(format t "~3% Done! Now try (test-gtk:gtk-demo) or if problems, (test-gtk:gtk-demo t)")
 
 
 



From pdenno at common-lisp.net  Fri Jun 30 15:25:11 2006
From: pdenno at common-lisp.net (pdenno)
Date: Fri, 30 Jun 2006 11:25:11 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/cells-gtk/test-gtk
Message-ID: <20060630152511.C98187C039@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk
In directory clnet:/tmp/cvs-serv16486/root/cells-gtk/test-gtk

Modified Files:
	test-gtk.lisp 
Log Message:
export gtk-demo

--- /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk/test-gtk.lisp	2006/02/19 20:19:13	1.13
+++ /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk/test-gtk.lisp	2006/06/30 15:25:11	1.14
@@ -1,5 +1,6 @@
 (defpackage :test-gtk
-  (:use :common-lisp :pod :cells :gtk-ffi :cells-gtk))
+  (:use :common-lisp :pod :cells :gtk-ffi :cells-gtk)
+  (:export gtk-demo))
 
 (in-package :test-gtk)
 



From pdenno at common-lisp.net  Fri Jun 30 15:26:54 2006
From: pdenno at common-lisp.net (pdenno)
Date: Fri, 30 Jun 2006 11:26:54 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS root/gtk-ffi
Message-ID: <20060630152654.BB9ED7C039@common-lisp.net>

Update of /project/cells-gtk/cvsroot/root/gtk-ffi
In directory clnet:/tmp/cvs-serv16532/root/gtk-ffi

Modified Files:
	gtk-ffi.lisp 
Log Message:
Use cffi-features.

--- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp	2006/06/07 17:00:25	1.21
+++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp	2006/06/30 15:26:54	1.22
@@ -82,63 +82,57 @@
   (setf (cffi:mem-aref (cffi:foreign-slot-value obj obj-type slot) :int index)
     new-value))
 
-(cffi:define-foreign-library 'gobject
-  (:linux "libgobject-2.0.so")
-  (:win32 "libgobject-2.0-0.dll")
-  (:macosx "libgobject-2.0-0.dylib"))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(cffi:define-foreign-library :gobject
+  (cffi-features:unix "libgobject-2.0.so")
+  (cffi-features:windows "libgobject-2.0-0.dll")
+  (cffi-features:darwin "libgobject-2.0-0.dylib"))
 
 (cffi:define-foreign-library :glib
-  (:linux "libglib-2.0.so")
-  (:win32 "libglib-2.0-0.dll")
-  (:macosx "libglib-2.0-0.dylib"))
+  (cffi-features:unix "libglib-2.0.so")
+  (cffi-features:windows "libglib-2.0-0.dll")
+  (cffi-features:darwin "libglib-2.0-0.dylib"))
 
 (cffi:define-foreign-library :gthread
-  (:linux "libgthread-2.0.so")
-  (:win32 "libgthread-2.0-0.dll")
-  (:macosx "libgthread-2.0-0.dylib"))
+  (cffi-features:unix "libgthread-2.0.so")
+  (cffi-features:windows "libgthread-2.0-0.dll")
+  (cffi-features:darwin "libgthread-2.0-0.dylib"))
 
 (cffi:define-foreign-library :gdk
-  (:linux "libgdk-x11-2.0.so")
-  (:win32 "libgdk-win32-2.0-0.dll")
-  (:macosx "libgdk-win32-2.0-0.dylib")) ; pod ???
+  (cffi-features:unix "libgdk-x11-2.0.so")
+  (cffi-features:windows "libgdk-win32-2.0-0.dll")
+  (cffi-features:darwin "libgdk-win32-2.0-0.dylib")) ; pod ???
 
 (cffi:define-foreign-library :gtk
-  (:linux "libgtk-x11-2.0.so")
-  (:win32 "libgtk-win32-2.0-0.dll")
-  (:macosx "libgtk-win32-2.0-0.dylib")) ; pod ???
+  (cffi-features:unix "libgtk-x11-2.0.so")
+  (cffi-features:windows "libgtk-win32-2.0-0.dll")
+  (cffi-features:darwin "libgtk-win32-2.0-0.dylib")) ; pod ???
 
 #+libcellsgtk
 (cffi:define-foreign-library :cgtk
-  (:linux "libcellsgtk.so")
-  (:win32 "libcellsgtk.dll")
-  (:macosx "libcellsgtk.dylib"))
+  (cffi-features:unix "libcellsgtk.so")
+  (cffi-features:windows "libcellsgtk.dll")
+  (cffi-features:darwin "libcellsgtk.dylib"))
+) ;eval-when
 
 ;;; After doing this, should be able to do (g-thread-init c-null)
 ;;; The above define-foreigh-library appears to be useless (doesn't
 ;;; work through the symbols) use the names. 
+
+;;; LW Win32 is hanging on POD's machine only:
+;;; (fli:register-module "libgdk-win32-2.0-0.dll" :connection-style :immediate)
+;;; (fli:register-module "c:\\Program Files\\Common Files\\GTK\\2.0\\bin\\libgdk-win32-2.0-0.dll" 
+;;;                      :connection-style :immediate)
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun load-gtk-libs ()
     (handler-bind ((style-warning #'muffle-warning))
-      (cffi:load-foreign-library #+cffi-features:unix "libgobject-2.0.so" 
-				 #+win32 "libgobject-2.0-0.dll" 
-				 #+macosx "libgobject-2.0-0.dylib")
-      (cffi:load-foreign-library #+cffi-features:unix "libglib-2.0.so" 
-				 #+win32 "libglib-2.0-0.dll" 
-				 #+macosx "libglib-2.0-0.dylib")
-      (cffi:load-foreign-library #+cffi-features:unix "libgthread-2.0.so" 
-				 #+win32 "libgthread-2.0-0.dll" 
-				 #+macosx "libgthread-2.0-0.dylib")
-      (cffi:load-foreign-library #+cffi-features:unix "libgdk-x11-2.0.so" 
-				 #+win32 "libgdk-win32-2.0-0.dll" 
-				 #+macosx "libgdk-win32-2.0-0.dylib")
-      (cffi:load-foreign-library #+cffi-features:unix "libgtk-x11-2.0.so" 
-				 #+win32 "libgtk-win32-2.0-0.dll" 
-				 #+macosx "libgtk-win32-2.0-0.dylib")
+      (cffi:load-foreign-library :gobject)
+      (cffi:load-foreign-library :glib)
+      (cffi:load-foreign-library :gthread)
+      (cffi:load-foreign-library :gdk)
+      (cffi:load-foreign-library :gtk)
       #+libcellsgtk
-      (cffi:load-foreign-library #+cffi-features:unix 
-				 (merge-pathnames "libcellsgtk.so" #.*compile-file-pathname*)
-				 #+win32 "libcellsgtk.dll" 
-				 #+macosx "libcellsgtk.dylib")))
+      (cffi:load-foreign-library :cgtk)))
 ) ; eval
 
 (eval-when (:compile-toplevel :load-toplevel :execute)



From pdenno at common-lisp.net  Fri Jun 30 15:45:25 2006
From: pdenno at common-lisp.net (pdenno)
Date: Fri, 30 Jun 2006 11:45:25 -0400 (EDT)
Subject: [cells-gtk-cvs] CVS public_html
Message-ID: <20060630154525.9A2C146113@common-lisp.net>

Update of /project/cells-gtk/cvsroot/public_html
In directory clnet:/tmp/cvs-serv20417/public_html

Modified Files:
	index.html 
Log Message:
Announce new tarballs

--- /project/cells-gtk/cvsroot/public_html/index.html	2006/06/07 17:20:10	1.28
+++ /project/cells-gtk/cvsroot/public_html/index.html	2006/06/30 15:45:25	1.29
@@ -74,6 +74,7 @@
 <h1 id='news'>News</h1>
 
 <ul>
+  <li> <strong>2006-06-30</strong> New tarballs. See below.
   <li> <strong>2006-06-07</strong> 
           <ul>
            <li>Patches from Andras Simon allow Cells-GTK to load without complaints under
@@ -134,6 +135,16 @@
       snapshots of the CVS repository, and contain all the ancillary modules (cells, cffi, etc). 
       Here are a few:
        <ul>
+         <li><a href="ftp://common-lisp.net/pub/project/cells-gtk/cells-gtk-2006-06-30.tgz">cells-gtk-2006-06-30.tgz</a> and <a href="ftp://common-lisp.net/pub/project/cells-gtk/cells-gtk-2006-06-30.zip">cells-gtk-2006-06-30.zip</a> and 
+	   <ul>
+             <li>Uses 2006-06-26 version of CFFI.
+	     <li>Cleaner load with sbcl. (Thanks, Andras Simon.)
+	     <li>Tested with LINUX: LW/Pro, sbcl, clisp; WIN32: clisp.
+             <li>Seems to have problems loading libraries with cmucl (not investigated much).
+             <li>I (Peter Denno) had problems with LW/Win32. But others seem ok. -- If this form:<br>
+                 <tt>(fli:register-module "libgdk-win32-2.0-0.dll" :connection-style :immediate)</tt><br>
+		 -- returns OK (once you've installed GTK libs) then you should be OK. 
+           </ul>
          <li><a href="ftp://common-lisp.net/pub/project/cells-gtk/cells-gtk-2006-02-16.tgz">cells-gtk-2006-02-16.tgz</a>
 	   <ul>
              <li>Native CFFI. That is, not Hello-C to UFFI, to CFFI-UFFI-COMPAT (yuk!).</li>