From ktilton at common-lisp.net Sun Apr 6 19:14:20 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 6 Apr 2008 15:14:20 -0400 (EDT) Subject: [cells-cvs] CVS Cells-js Message-ID: <20080406191420.ABAB045000@common-lisp.net> Update of /project/cells/cvsroot/Cells-js In directory clnet:/tmp/cvs-serv32148 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import From ktilton at common-lisp.net Sun Apr 6 19:15:18 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 6 Apr 2008 15:15:18 -0400 (EDT) Subject: [cells-cvs] CVS Cells-js/web-pages Message-ID: <20080406191518.725B16410D@common-lisp.net> Update of /project/cells/cvsroot/Cells-js/web-pages In directory clnet:/tmp/cvs-serv32422/web-pages Log Message: Directory /project/cells/cvsroot/Cells-js/web-pages added to the repository From ktilton at common-lisp.net Sun Apr 6 19:16:17 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 6 Apr 2008 15:16:17 -0400 (EDT) Subject: [cells-cvs] CVS Cells-js Message-ID: <20080406191617.908B712064@common-lisp.net> Update of /project/cells/cvsroot/Cells-js In directory clnet:/tmp/cvs-serv32532 Added Files: cell-types.js cells.js constructors.js defmodel.js defpackage.js family-values.js family.js fm-utilities.js initialize.js integrity.js link.js md-slot-value.js md-utilities.js model-object.js propagate.js slot-utilities.js synapse-types.js synapse.js test-cycle.js test-ephemeral.js test-propagation.js test-synapse.js test.js trc-eko.js variables.js Log Message: Initial load of Lisp Cells source prior to revision into JS --- /project/cells/cvsroot/Cells-js/cell-types.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/cell-types.js 2008/04/06 19:16:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| Cells -- Automatic Dataflow Managememnt Copyright (C) 1995, 2006 by Kenneth Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cells) (defstruct (cell (:conc-name c-)) model slot-name value inputp ;; t for old c-variable class synaptic (caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :uncurrent | :valid} ; uncurrent (aka dirty) new for 06-10-15. we need this so ; c-quiesce can force a caller to update when asked ; in case the owner of the quiesced cell goes out of existence ; in a way the caller will not see via any kids dependency. Saw ; this one coming a long time ago: depending on cell X implies ; a dependency on the existence of instance owning X (pulse 0 :type fixnum) (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP (pulse-observed 0 :type fixnum) lazy (optimize t) debug md-info) ;_____________________ print __________________________________ #+sigh (defmethod print-object :before ((c cell) stream) (declare (ignorable stream)) #+shhh (unless (or *stop* *print-readably*) (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) (declare (ignorable stream)) (unless *stop* (let ((*print-circle* t)) #+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c)) (if *print-readably* (call-next-method) (progn (c-print-value c stream) (format stream "=~d/~a/~a/~a]" (c-pulse c) (c-state c) (symbol-name (or (c-slot-name c) :anoncell)) (print-cell-model (c-model c)))))))) (export! print-cell-model) (defgeneric print-cell-model (md) (:method (other) (print-object other nil))) (defmethod trcp :around ((c cell)) (or (c-debug c) (call-next-method))) (defun c-callers (c) "Make it easier to change implementation" (fifo-data (c-caller-store c))) (defun caller-ensure (used new-caller) (unless (find new-caller (c-callers used)) (trc nil "caller-ensure fifo-adding new-caller" new-caller :used used) (fifo-add (c-caller-store used) new-caller))) (defun caller-drop (used caller) (fifo-delete (c-caller-store used) caller)) ; --- ephemerality -------------------------------------------------- ; ; Not a type, but an option to the :cell parameter of defmodel ; (defun ephemeral-p (c) (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c)))) (defun ephemeral-reset (c) (when (ephemeral-p c) ;; so caller does not need to worry about this ; ; as of Cells3 we defer resetting ephemerals because everything ; else gets deferred and we cannot /really/ reset it until ; within finish-business we are sure all callers have been recalculated ; and all outputs completed. ; ; ;; good q: what does (setf 'x) return? historically nil, but...? ; ;;(trcx bingo-ephem c) (with-integrity (:ephemeral-reset c) (trc nil "!!!!!!!!!!!!!! ephemeral-reset resetting:" c) (md-slot-value-store (c-model c) (c-slot-name c) nil) (setf (c-value c) nil)))) ; ----------------------------------------------------- (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-)) (code nil :type list) ;; /// feature this out on production build rule) (defun c-optimized-away-p (c) (eq :optimized-away (c-state c))) ;---------------------------- (defmethod trcp-slot (self slot-name) (declare (ignore self slot-name))) (defstruct (c-dependent (:include c-ruled) (:conc-name cd-)) ;; chop (synapses nil :type list) (useds nil :type list) (usage (blank-usage-mask))) (defun blank-usage-mask () (make-array 16 :element-type 'bit :initial-element 0)) (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)) (defun c-unboundp (c) (eql :unbound (c-value-state c))) ;__________________ (defmethod c-print-value ((c c-ruled) stream) (format stream "~a" (cond ((c-validp c) (cons (c-value c) "")) ((c-unboundp c) "") ((not (c-currentp c)) "dirty") (t "")))) (defmethod c-print-value (c stream) (declare (ignore c stream))) --- /project/cells/cvsroot/Cells-js/cells.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/cells.js 2008/04/06 19:16:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| Cells -- Automatic Dataflow Managememnt Copyright (C) 1995, 2006 by Kenneth Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# #| Notes I don't like the way with-cc defers twice, first the whole thing and then when the body finally runs we are still within the original integrity and each setf gets queued to UFB separately before md-slot-value-assume finally runs. I think all that is going on here is that we want the programmer to use with-cc to show they know the setf will not be returning a useful value. But since they have coded the with-cc we should be able to figure out a way to let those SETFs thru as if they were outside integrity, and then we get a little less UFBing but even better SETF behaves as it should. It would be nice to do referential integrity and notice any time a model object gets stored in a cellular slot (or in a list in such) and then mop those up on not-to-be. |# (eval-when (compile load) (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) (in-package :cells) (defparameter *c-prop-depth* 0) (defparameter *causation* nil) (defparameter *data-pulse-id* 0) (defparameter *c-debug* nil) (defparameter *defer-changes* nil) (defparameter *within-integrity* nil) (defparameter *client-queue-handler* nil) (defparameter *unfinished-business* nil) #+test (cells-reset) (defun cells-reset (&optional client-queue-handler &key debug) (utils-kt-reset) (setf *c-debug* debug *c-prop-depth* 0 *data-pulse-id* 0 *defer-changes* nil ;; should not be necessary, but cannot be wrong *client-queue-handler* client-queue-handler *within-integrity* nil *unfinished-business* nil *trcdepth* 0) (trc nil "------ cell reset ----------------------------")) (defun c-stop (&optional why) (setf *stop* t) (print `(c-stop-entry ,why)) (format t "~&C-STOP> stopping because ~a" why) ) (define-symbol-macro .stop (c-stop :user)) (defun c-stopped () *stop*) (export! .stopped) (define-symbol-macro .stopped (c-stopped)) (defmacro c-assert (assertion &optional places fmt$ &rest fmt-args) (declare (ignorable assertion places fmt$ fmt-args)) #+(or)`(progn) `(unless *stop* (unless ,assertion ,(if fmt$ `(c-break ,fmt$ , at fmt-args) `(c-break "failed assertion: ~a" ',assertion))))) (defvar *call-stack* nil) (defvar *depender* nil) ;; 2008-03-15: *depender* let's us differentiate between the call stack and ;; and dependency. The problem with overloading *call-stack* with both roles ;; is that we miss cyclic reentrance when we use without-c-dependency in a ;; rule to get "once" behavior or just when fm-traversing to find someone (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 (*depender*) , at body)) (export! .cause) (define-symbol-macro .cause (car *causation*)) (define-condition unbound-cell (unbound-slot) ((cell :initarg :cell :reader cell :initform nil))) (defgeneric slot-value-observe (slotname self new old old-boundp cell) #-(or cormanlisp) (:method-combination progn)) #-cells-testing (defmethod slot-value-observe #-(or cormanlisp) progn (slot-name self new old old-boundp cell) (declare (ignorable slot-name self new old old-boundp cell))) ; -------- 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 "")) (: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 : ~s" condition) (break "~&i say, unhandled : ~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) (unless *stop* (let ((*print-level* 5) (*print-circle* t) (args2 (mapcar 'princ-to-string args))) (c-stop args) (format t "~&c-break > stopping > ~{~a ~}" args2) (print `(c-break-args , at args2)) (apply 'error args2))))--- /project/cells/cvsroot/Cells-js/constructors.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/constructors.js 2008/04/06 19:16:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| Cells -- Automatic Dataflow Managememnt Copyright (C) 1995, 2006 by Kenneth Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cells) (eval-now! (export '(.cache-bound-p ;; Cells Constructors c?n c?once c?n-until c?1 c_1 c?+n ;; Debug Macros and Functions c?dbg c_?dbg c-input-dbg ))) ;___________________ constructors _______________________________ (defmacro c-lambda (&body body) `(c-lambda-var (slot-c) , at body)) [158 lines skipped] --- /project/cells/cvsroot/Cells-js/defmodel.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/defmodel.js 2008/04/06 19:16:17 1.1 [359 lines skipped] --- /project/cells/cvsroot/Cells-js/defpackage.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/defpackage.js 2008/04/06 19:16:17 1.1 [422 lines skipped] --- /project/cells/cvsroot/Cells-js/family-values.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/family-values.js 2008/04/06 19:16:17 1.1 [518 lines skipped] --- /project/cells/cvsroot/Cells-js/family.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/family.js 2008/04/06 19:16:17 1.1 [729 lines skipped] --- /project/cells/cvsroot/Cells-js/fm-utilities.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/fm-utilities.js 2008/04/06 19:16:17 1.1 [1374 lines skipped] --- /project/cells/cvsroot/Cells-js/initialize.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/initialize.js 2008/04/06 19:16:17 1.1 [1437 lines skipped] --- /project/cells/cvsroot/Cells-js/integrity.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/integrity.js 2008/04/06 19:16:17 1.1 [1636 lines skipped] --- /project/cells/cvsroot/Cells-js/link.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/link.js 2008/04/06 19:16:17 1.1 [1775 lines skipped] --- /project/cells/cvsroot/Cells-js/md-slot-value.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/md-slot-value.js 2008/04/06 19:16:17 1.1 [2134 lines skipped] --- /project/cells/cvsroot/Cells-js/md-utilities.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/md-utilities.js 2008/04/06 19:16:17 1.1 [2222 lines skipped] --- /project/cells/cvsroot/Cells-js/model-object.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/model-object.js 2008/04/06 19:16:17 1.1 [2504 lines skipped] --- /project/cells/cvsroot/Cells-js/propagate.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/propagate.js 2008/04/06 19:16:17 1.1 [2786 lines skipped] --- /project/cells/cvsroot/Cells-js/slot-utilities.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/slot-utilities.js 2008/04/06 19:16:17 1.1 [2883 lines skipped] --- /project/cells/cvsroot/Cells-js/synapse-types.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/synapse-types.js 2008/04/06 19:16:17 1.1 [3035 lines skipped] --- /project/cells/cvsroot/Cells-js/synapse.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/synapse.js 2008/04/06 19:16:17 1.1 [3124 lines skipped] --- /project/cells/cvsroot/Cells-js/test-cycle.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/test-cycle.js 2008/04/06 19:16:17 1.1 [3201 lines skipped] --- /project/cells/cvsroot/Cells-js/test-ephemeral.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/test-ephemeral.js 2008/04/06 19:16:17 1.1 [3258 lines skipped] --- /project/cells/cvsroot/Cells-js/test-propagation.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/test-propagation.js 2008/04/06 19:16:17 1.1 [3303 lines skipped] --- /project/cells/cvsroot/Cells-js/test-synapse.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/test-synapse.js 2008/04/06 19:16:17 1.1 [3405 lines skipped] --- /project/cells/cvsroot/Cells-js/test.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/test.js 2008/04/06 19:16:17 1.1 [3633 lines skipped] --- /project/cells/cvsroot/Cells-js/trc-eko.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/trc-eko.js 2008/04/06 19:16:17 1.1 [3792 lines skipped] --- /project/cells/cvsroot/Cells-js/variables.js 2008/04/06 19:16:17 NONE +++ /project/cells/cvsroot/Cells-js/variables.js 2008/04/06 19:16:17 1.1 [3910 lines skipped] From ktilton at common-lisp.net Sun Apr 6 19:35:40 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 6 Apr 2008 15:35:40 -0400 (EDT) Subject: [cells-cvs] CVS Cells-js Message-ID: <20080406193540.2B3E71501F@common-lisp.net> Update of /project/cells/cvsroot/Cells-js In directory clnet:/tmp/cvs-serv6206 Modified Files: cell-types.js cells.js constructors.js defmodel.js family-values.js family.js fm-utilities.js initialize.js integrity.js link.js md-slot-value.js md-utilities.js model-object.js propagate.js slot-utilities.js synapse-types.js synapse.js test.js trc-eko.js variables.js Log Message: --- /project/cells/cvsroot/Cells-js/cell-types.js 2008/04/06 19:16:16 1.1 +++ /project/cells/cvsroot/Cells-js/cell-types.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/cells.js 2008/04/06 19:16:16 1.1 +++ /project/cells/cvsroot/Cells-js/cells.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,9 +14,9 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ -#| Notes +/* Notes I don't like the way with-cc defers twice, first the whole thing and then when the body finally runs we are still within the original integrity and each setf gets queued @@ -29,7 +29,7 @@ It would be nice to do referential integrity and notice any time a model object gets stored in a cellular slot (or in a list in such) and then mop those up on not-to-be. -|# +*/ (eval-when (compile load) --- /project/cells/cvsroot/Cells-js/constructors.js 2008/04/06 19:16:16 1.1 +++ /project/cells/cvsroot/Cells-js/constructors.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/defmodel.js 2008/04/06 19:16:16 1.1 +++ /project/cells/cvsroot/Cells-js/defmodel.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) (defmacro defmodel (class directsupers slotspecs &rest options) --- /project/cells/cvsroot/Cells-js/family-values.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/family-values.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/family.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/family.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/fm-utilities.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/fm-utilities.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) @@ -249,10 +249,10 @@ ;; -#| +/* (defun fm-member-named (kidname kids) (member kidname kids :key #'md-name)) - |# + */ (defun true-that (that) (declare (ignore that)) t) ;; --- /project/cells/cvsroot/Cells-js/initialize.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/initialize.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/integrity.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/integrity.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/link.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/link.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/md-slot-value.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/md-slot-value.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/md-utilities.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/md-utilities.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/model-object.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/model-object.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/propagate.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/propagate.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/slot-utilities.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/slot-utilities.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) @@ -88,10 +88,10 @@ (slot-makunbound self slot-name) (makunbound self))) -#| sample incf +/* sample incf (defmethod c-value-incf ((base fpoint) delta) (declare (ignore model)) (if delta (fp-add base delta) base)) -|# +*/ --- /project/cells/cvsroot/Cells-js/synapse-types.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/synapse-types.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/synapse.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/synapse.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/test.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/test.js 2008/04/06 19:35:38 1.2 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -#| Synapse Cell Unification Notes +/* Synapse Cell Unification Notes - start by making Cells synapse-y @@ -47,16 +47,16 @@ - do diff unchanged tests such as string-equal work -|# +*/ -#| do list +/* do list -- can we lose the special handling of the .kids slot? -- test drifters (and can they be handled without creating a special subclass for them?) -|# +*/ (eval-when (compile load) (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) --- /project/cells/cvsroot/Cells-js/trc-eko.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/trc-eko.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* The Newly Cells-aware TRC trace and EKO value echo facilities @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) --- /project/cells/cvsroot/Cells-js/variables.js 2008/04/06 19:16:17 1.1 +++ /project/cells/cvsroot/Cells-js/variables.js 2008/04/06 19:35:38 1.2 @@ -1,5 +1,5 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -#| +/* Cells -- Automatic Dataflow Managememnt @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -|# +*/ (in-package :cells) From ktilton at common-lisp.net Fri Apr 11 09:19:41 2008 From: ktilton at common-lisp.net (ktilton) Date: Fri, 11 Apr 2008 05:19:41 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080411091941.6AA2FD003@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv5826 Modified Files: cells.lisp family.lisp fm-utilities.lisp integrity.lisp md-slot-value.lisp Log Message: --- /project/cells/cvsroot/cells/cells.lisp 2008/03/15 15:18:34 1.25 +++ /project/cells/cvsroot/cells/cells.lisp 2008/04/11 09:19:29 1.26 @@ -16,14 +16,26 @@ |# -(eval-when (compile load) - (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) +#| Notes +I don't like the way with-cc defers twice, first the whole thing and then when the +body finally runs we are still within the original integrity and each setf gets queued +to UFB separately before md-slot-value-assume finally runs. I think all that is going on here +is that we want the programmer to use with-cc to show they know the setf will not be returning +a useful value. But since they have coded the with-cc we should be able to figure out a way to +let those SETFs thru as if they were outside integrity, and then we get a little less UFBing +but even better SETF behaves as it should. +It would be nice to do referential integrity and notice any time a model object gets stored in +a cellular slot (or in a list in such) and then mop those up on not-to-be. + +|# -(in-package :cells) +(eval-when (compile load) + (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) +(in-package :cells) (defparameter *c-prop-depth* 0) (defparameter *causation* nil) @@ -94,11 +106,8 @@ `t)))) (defmacro without-c-dependency (&body body) - `(call-without-c-dependency (lambda () , at body))) - -(defun call-without-c-dependency (fn) - (let (*depender*) - (funcall fn))) + ` (let (*depender*) + , at body)) (export! .cause) @@ -117,7 +126,8 @@ (slot-name self new old old-boundp cell) (declare (ignorable slot-name self new old old-boundp cell))) - +#+hunh +(fmakunbound 'slot-value-observe) ; -------- cell conditions (not much used) --------------------------------------------- (define-condition xcell () ;; new 2k0227 --- /project/cells/cvsroot/cells/family.lisp 2008/02/16 09:34:29 1.23 +++ /project/cells/cvsroot/cells/family.lisp 2008/04/11 09:19:30 1.24 @@ -91,9 +91,7 @@ (.kids :initform (c-in nil) ;; most useful :owning t :accessor kids - :initarg :kids) - ) - (:default-initargs :fm-parent (when (boundp '*parent*) *parent*))) + :initarg :kids))) (defmacro the-kids (&rest kids) `(let ((*parent* self)) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2008/01/29 04:29:52 1.17 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2008/04/11 09:19:31 1.18 @@ -115,6 +115,17 @@ :with-dependency dependently) (nreverse collection))) +(export! fm-collect-some) + +(defun fm-collect-some (tree test &optional skip-top dependently) + (let (collection) + (fm-traverse tree (lambda (node) + (unless (and skip-top (eq node tree)) + (bwhen (s (funcall test node)) + (push s collection)))) + :with-dependency dependently) + (nreverse collection))) + (defun fm-value-dictionary (tree value-fn &optional include-top) (let (collection) (fm-traverse tree --- /project/cells/cvsroot/cells/integrity.lisp 2008/02/01 03:18:36 1.20 +++ /project/cells/cvsroot/cells/integrity.lisp 2008/04/11 09:19:32 1.21 @@ -48,7 +48,15 @@ (return-from call-with-integrity)) (if *within-integrity* (if opcode - (ufb-add opcode (cons defer-info action)) + (progn + (ufb-add opcode (cons defer-info action)) + ; + ; SETF is supposed to return the value being installed + ; in the place, but if the SETF is deferred we return + ; something that will help someone who tries to use + ; the setf'ed value figure out what is going on: + ; + :deferred-to-ufb-1) (funcall action opcode defer-info)) (let ((*within-integrity* t) *unfinished-business* @@ -63,18 +71,15 @@ (finish-business))))) (defun ufb-queue (opcode) - (assert (find opcode *ufb-opcodes*)) (cdr (assoc opcode *unfinished-business*))) (defun ufb-queue-ensure (opcode) - (assert (find opcode *ufb-opcodes*)) (or (ufb-queue opcode) (cdr (car (push (cons opcode (make-fifo-queue)) *unfinished-business*))))) (defparameter *no-tell* nil) (defun ufb-add (opcode continuation) - (assert (find opcode *ufb-opcodes*)) #+trythis (when (and *no-tell* (eq opcode :tell-dependents)) (break "truly queueing tell under no-tell")) (trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation))) @@ -137,7 +142,7 @@ ; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem. (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents))) - (trc "retelling dependenst, one new one being" uqp) + #+x42 (trc "retelling dependenst, one new one being" uqp) (go tell-dependents)) ;--- process client queue ------------------------------ @@ -175,7 +180,7 @@ (bwhen (task-info (fifo-pop (ufb-queue :change))) (trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change))) (destructuring-bind (defer-info . task-fn) task-info - (trc nil "finbiz: deferred state change" defer-info) + #+xxx (trc "fbz: dfrd chg" defer-info (fifo-length (ufb-queue :change))) (data-pulse-next (list :finbiz defer-info)) (funcall task-fn :change defer-info) ; --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/03/15 15:18:34 1.40 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/11 09:19:32 1.41 @@ -131,7 +131,7 @@ (bwhen (v (c-value c)) (if (mdead v) (progn - (format t "~&on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v) + #+shhh (format t "~&on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v) nil) v))) @@ -227,7 +227,8 @@ (defun (setf md-slot-value) (new-value self slot-name &aux (c (md-slot-cell self slot-name))) - + #+shhh (when *within-integrity* + (trc "mdsetf>" self (type-of self) slot-name :new new-value)) (when *c-debug* (c-setting-debug self slot-name c new-value)) From ktilton at common-lisp.net Fri Apr 11 09:19:42 2008 From: ktilton at common-lisp.net (ktilton) Date: Fri, 11 Apr 2008 05:19:42 -0400 (EDT) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20080411091942.2C3E9D002@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv5826/gui-geometry Modified Files: geo-family.lisp geo-macros.lisp geometer.lisp Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2007/11/30 16:51:19 1.12 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2008/04/11 09:19:41 1.13 @@ -120,64 +120,35 @@ ;--------------- geo.row.flow ---------------------------- (export! geo-row-flow) -(defmodel geo-row-flow (geo-inline) - ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz) - (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt) - (aligned :cell nil :initarg :aligned :initform nil :reader aligned)) - (:default-initargs - :lb (c? (geo-kid-wrap self 'pb)) - :kid-slots (lambda (self) - (declare (ignore self)) - - (list - (mk-kid-slot (py) - (c? (py-maintain-pt - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent)) - (^prior-sib-pb self (spacing-vt .parent)) - (^prior-sib-pt self)))))) - (mk-kid-slot (px) - (c? (px-maintain-pl - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent)) - 0 - ph))))))))) - -#| archive - -(defmodel geo-row-fv (family-values geo-row)()) -(defmodel geo-inline-fv (family-values geo-inline)()) - -;-------------------------- IMMatrix ------------------------------------------ - -(defmodel im-matrix (geo-zero-tl) - ((columns :cell nil :initarg :columns :initform nil :accessor columns) - (indent-hz :cell nil :initarg :indent-hz :initform 0 :accessor indent-hz) - (spacing-hz :cell nil :initarg :spacing-hz :initform 0 :accessor spacing-hz) - (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :accessor spacing-vt)) - (:default-initargs - :kid-slots (lambda (self) - (declare (ignore self)) - (list - (mk-kid-slot (px) - (c? (let ((parent (fm-parent self))) - (+ (indent-hz parent) - (if (zerop (mod (fm-pos self) - (or (columns parent) - (length (kids parent))))) - 0 - (+ (spacing-hz parent) - (pr (find-prior self (kids parent))))))))) - (mk-kid-slot (py) - (c? (let* ((parent (fm-parent self)) - (psib (find-prior self (kids parent)))) - (if (and psib (columns parent)) - (if (zerop (mod (fm-pos self) (columns parent))) - (+ (- (abs (spacing-vt parent))) (pb psib)) - (pt psib)) - 0)))))))) +(defmd geo-row-flow (geo-inline) + (spacing-hz 0) + (spacing-vt 0) + (aligned :cell nil) + (row-flow-layout + (c? (loop with max-pb = 0 and pl = 0 and pt = 0 + for k in (^kids) + for kpr = (+ pl (l-width k)) + when (unless (= pl 0) + (> kpr (- (l-width self) (outset self)))) do + (setf pl 0 + pt (+ max-pb (downs (^spacing-vt)))) + + collect (cons pl pt) into pxys + do (incf pl (+ (l-width k)(^spacing-hz))) + (setf max-pb (min max-pb (+ pt (downs (l-height k))))) + finally (return (cons max-pb pxys))))) + :lb (c? (+ (bif (xys (^row-flow-layout)) + (car xys) 0) + (downs (outset self)))) + :kid-slots (lambda (self) + (declare (ignore self)) + (list + (mk-kid-slot (px) + (c? (px-maintain-pl (car (nth (kid-no self) (cdr (row-flow-layout .parent))))))) + (mk-kid-slot (py) + (c? (py-maintain-pt (cdr (nth (kid-no self) (cdr (row-flow-layout .parent)))))))))) + -|# --- /project/cells/cvsroot/cells/gui-geometry/geo-macros.lisp 2007/12/11 19:35:16 1.1 +++ /project/cells/cvsroot/cells/gui-geometry/geo-macros.lisp 2008/04/11 09:19:41 1.2 @@ -77,7 +77,7 @@ (defmacro py-maintain-pB (pB) `(- ,pB (^lB))) -(export! centered-h? centered-v?) +(export! centered-h? centered-v? lb-maintain-pB) (defmacro ^fill-down (upper-type &optional (padding 0)) (let ((filled (gensym))) --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2007/11/30 16:51:19 1.13 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2008/04/11 09:19:41 1.14 @@ -110,13 +110,26 @@ ;sum pXYs up the family tree ;gave an odd result for cursor display.... (defun v2-xlate (outer inner outer-v2) - (if (eql outer inner) + (if (eq outer inner) outer-v2 (v2-xlate outer (fm-parent inner) (v2-subtract outer-v2 (mkv2 (px inner) (py inner)))))) -(export! h-xlate v-xlate) +(defun v2-xlate-out (inner outer inner-v2) + (if (eq outer inner) + inner-v2 + (v2-xlate (fm-parent inner) outer + (v2-add inner-v2 + (mkv2 (px inner) (py inner)))))) + +(defun v2-xlate-between (from-v2 from to) + (cond + ((fm-includes from to)(v2-xlate from to from-v2)) + ((fm-includes to from)(v2-xlate-out from to from-v2)) + (t (break "time to extend v2-xlate-between")))) + +(export! h-xlate v-xlate v2-xlate-between) (defun h-xlate (outer inner outer-h) (if (eql outer inner) From ktilton at common-lisp.net Fri Apr 11 09:19:47 2008 From: ktilton at common-lisp.net (ktilton) Date: Fri, 11 Apr 2008 05:19:47 -0400 (EDT) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20080411091947.30585D003@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv5826/utils-kt Modified Files: datetime.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2007/11/30 16:51:20 1.4 +++ /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2008/04/11 09:19:47 1.5 @@ -193,12 +193,13 @@ month year day-of-week daylight-saving-time-p time-zone)) (format nil "~4,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A" - year month date hours minutes seconds (floor (now) 10)))) + year month date hours minutes seconds (floor (* 10 (mod (now) 1.0)))))) (defun hyphenated-time-string () (substitute #\- #\: (ymdhmsh))) #+test (hyphenated-time-string) - +#+test +(ymdhmsh) \ No newline at end of file From ktilton at common-lisp.net Fri Apr 11 09:23:51 2008 From: ktilton at common-lisp.net (ktilton) Date: Fri, 11 Apr 2008 05:23:51 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20080411092351.AD5007113E@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv7901 Modified Files: composites.lisp run.lisp tk-interp.lisp Log Message: --- /project/cells/cvsroot/Celtk/composites.lisp 2008/03/23 23:47:42 1.27 +++ /project/cells/cvsroot/Celtk/composites.lisp 2008/04/11 09:23:51 1.28 @@ -123,12 +123,16 @@ (loop for task in *app-idle-tasks* do (funcall task self task))) -(defmd window (toplevel composite-widget decoration-mixin) +(export! resources ^resources) + +(defmd window (toplevel composite-widget) (title$ (c? (string-capitalize (class-name (class-of self))))) (dictionary (make-hash-table :test 'equalp)) (tkwins (make-hash-table)) (xwins (make-hash-table)) (cursor :arrow :cell nil) + (resources (c-in nil) + :documentation "A-list of anything useful to be used consistently, such as ((paper . \"paper038edgeless\")(metal . \"metal033\"))") (keyboard-modifiers (c-in nil)) (callbacks (make-hash-table :test #'eq)) (edit-style (c-in nil)) @@ -144,6 +148,7 @@ Actually holds last event code, :focusin or :focusout") on-key-down on-key-up + (show-tool-tips? (c-in t)) :width (c?n 800) :height (c?n 600)) @@ -155,7 +160,7 @@ (trc nil "configure cursor" self new-value) (tk-format-now ". configure -cursor ~a" (string-downcase (symbol-name new-value))))) -(export! .control-key-p .alt-key-p .shift-key-p focus-state ^focus-state) +(export! .control-key-p .alt-key-p .shift-key-p focus-state ^focus-state show-tool-tips? ^show-tool-tips?) (define-symbol-macro .control-key-p (find :control (keyboard-modifiers .tkw))) (define-symbol-macro .alt-key-p (find :alt (keyboard-modifiers .tkw))) (define-symbol-macro .shift-key-p (find :shift (keyboard-modifiers .tkw))) --- /project/cells/cvsroot/Celtk/run.lisp 2008/03/23 23:47:42 1.28 +++ /project/cells/cvsroot/Celtk/run.lisp 2008/04/11 09:23:51 1.29 @@ -18,6 +18,7 @@ (in-package :Celtk) + ;;; --- running a Celtk (window class, actually) -------------------------------------- (eval-now! --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2008/01/03 20:23:30 1.20 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2008/04/11 09:23:51 1.21 @@ -214,6 +214,12 @@ (tcl-find-executable (argv0)) (set-initialized))) +#+test +(load-foreign-library 'Togl) + +#+test +(load "togl17.dll" :verbose t) + ;; Send a script to a given Tcl/Tk interpreter (defun eval-script (interp script) From ktilton at common-lisp.net Fri Apr 11 09:24:42 2008 From: ktilton at common-lisp.net (ktilton) Date: Fri, 11 Apr 2008 05:24:42 -0400 (EDT) Subject: [cells-cvs] CVS triple-cells Message-ID: <20080411092442.80CC07113E@common-lisp.net> Update of /project/cells/cvsroot/triple-cells In directory clnet:/tmp/cvs-serv8262 Modified Files: defpackage.lisp observer.lisp triple-cells.lpr Log Message: --- /project/cells/cvsroot/triple-cells/defpackage.lisp 2008/02/23 01:22:11 1.2 +++ /project/cells/cvsroot/triple-cells/defpackage.lisp 2008/04/11 09:24:42 1.3 @@ -31,3 +31,6 @@ (:nicknames :3c) (:use #:common-lisp #:utils-kt #:db.agraph #:cells)) ;; cells just for TRC (so far) +(in-package :triple-cells) + +(defvar *3c-observers*) \ No newline at end of file --- /project/cells/cvsroot/triple-cells/observer.lisp 2008/02/23 01:22:11 1.2 +++ /project/cells/cvsroot/triple-cells/observer.lisp 2008/04/11 09:24:42 1.3 @@ -57,7 +57,7 @@ ;;; ---------------------------------------------------- -(defvar *3c-observers*) + (defun (setf 3c-observer) (function c-node) (assert (functionp function) () "3c-observer setf not rule: ~a ~a" (type-of function) function) --- /project/cells/cvsroot/triple-cells/triple-cells.lpr 2008/02/23 01:22:11 1.4 +++ /project/cells/cvsroot/triple-cells/triple-cells.lpr 2008/04/11 09:24:42 1.5 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Apr 3, 2008 23:47)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -7,13 +7,13 @@ (define-project :name :triple-cells :modules (list (make-instance 'module :name "defpackage.lisp") (make-instance 'module :name "ag-utilities.lisp") + (make-instance 'module :name "3c-integrity.lisp") (make-instance 'module :name "core.lisp") (make-instance 'module :name "api.lisp") (make-instance 'module :name "dataflow.lisp") (make-instance 'module :name "observer.lisp") (make-instance 'module :name "hello-world.lisp") - (make-instance 'module :name "read-me.lisp") - (make-instance 'module :name "3c-integrity.lisp")) + (make-instance 'module :name "read-me.lisp")) :projects (list (make-instance 'project-module :name "..\\Cells\\cells")) :libraries nil From phildebrandt at common-lisp.net Fri Apr 11 13:58:47 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Fri, 11 Apr 2008 09:58:47 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080411135847.7C7C85D08A@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv28945 Modified Files: family.lisp Log Message: family check. --- /project/cells/cvsroot/cells/family.lisp 2008/04/11 09:19:30 1.24 +++ /project/cells/cvsroot/cells/family.lisp 2008/04/11 13:58:47 1.25 @@ -14,6 +14,8 @@ See the Lisp Lesser GNU Public License for more details. +## useless edit by PH + |# (in-package :cells) From phildebrandt at common-lisp.net Fri Apr 11 14:00:15 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Fri, 11 Apr 2008 10:00:15 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080411140015.07759640D6@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv29303 Modified Files: family.lisp Log Message: family changed back. --- /project/cells/cvsroot/cells/family.lisp 2008/04/11 13:58:47 1.25 +++ /project/cells/cvsroot/cells/family.lisp 2008/04/11 14:00:14 1.26 @@ -14,8 +14,6 @@ See the Lisp Lesser GNU Public License for more details. -## useless edit by PH - |# (in-package :cells) From phildebrandt at common-lisp.net Fri Apr 11 14:38:42 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Fri, 11 Apr 2008 10:38:42 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk Message-ID: <20080411143842.C110E2B078@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk In directory clnet:/tmp/cvs-serv8725 Modified Files: INSTALL.TXT Log Message: test --- /project/cells/cvsroot/cells-gtk/INSTALL.TXT 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/INSTALL.TXT 2008/04/11 14:38:42 1.2 @@ -1,3 +1,4 @@ +#check To compile and run: From ktilton at common-lisp.net Sat Apr 12 22:53:26 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 12 Apr 2008 18:53:26 -0400 (EDT) Subject: [cells-cvs] CVS cells/cells-test Message-ID: <20080412225326.95FBA4B023@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv19981/cells-test Modified Files: test-kid-slotting.lisp Log Message: Allow access to dead instances during *not-to-be* processing. --- /project/cells/cvsroot/cells/cells-test/test-kid-slotting.lisp 2006/06/20 14:16:45 1.3 +++ /project/cells/cvsroot/cells/cells-test/test-kid-slotting.lisp 2008/04/12 22:53:26 1.4 @@ -26,8 +26,8 @@ (defmd image (family) left top width height) -(defun right (x) (+ (left x) (width x))) -(defun bottom (x) (+ (top x) (height x))) +(defun i-right (x) (+ (left x) (width x))) +(defun i-bottom (x) (+ (top x) (height x))) (defmd stack (image) justify @@ -42,7 +42,7 @@ (:right (- (width .parent) (^width))))))) (mk-kid-slot (top) (c? (bif (psib (psib)) - (bottom psib) + (i-bottom psib) (top .parent)))))) :accessor kid-slots :initarg :kid-slots)) @@ -53,7 +53,7 @@ ;; because they will be endowed with rules as necessary to achieve that end by the parent stack. ;; ;; note the ifmissing option, which defaults to nil. the stack's goal is mainly to manage the -;; top attribute of each kid to match any predecessor's bottom attribute. the stack will as a +;; top attribute of each kid to match any predecessor's i-bottom attribute. the stack will as a ;; a convenience arrange for horizontal justification, but if some kid chose to define its ;; left attribute that would be honored. ;; @@ -74,11 +74,11 @@ (every (lambda (k) (eql 10 (left k))) (kids stack)))) (ct-assert (every (lambda (k) - (eql (top k) (bottom (fm-prior-sib k)))) + (eql (top k) (i-bottom (fm-prior-sib k)))) (cdr (kids stack)))) (setf (justify stack) :right) - (ct-assert (and (eql 510 (right stack)) - (every (lambda (k) (eql 510 (right k))) + (ct-assert (and (eql 510 (i-right stack)) + (every (lambda (k) (eql 510 (i-right k))) (kids stack)))) )) From ktilton at common-lisp.net Sat Apr 12 22:53:26 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 12 Apr 2008 18:53:26 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080412225326.DD46A4B023@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv19981 Modified Files: cells.lisp md-slot-value.lisp md-utilities.lisp Log Message: Allow access to dead instances during *not-to-be* processing. --- /project/cells/cvsroot/cells/cells.lisp 2008/04/11 09:19:29 1.26 +++ /project/cells/cvsroot/cells/cells.lisp 2008/04/12 22:53:26 1.27 @@ -47,6 +47,7 @@ (defparameter *within-integrity* nil) (defparameter *client-queue-handler* nil) (defparameter *unfinished-business* nil) +(defparameter *not-to-be* nil) #+test (cells-reset) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/11 09:19:32 1.41 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/12 22:53:26 1.42 @@ -21,8 +21,9 @@ (defparameter *ide-app-hard-to-kill* t) (defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name))) - (when (mdead self) - (trc "md-slot-value passed dead self, returning NIL" self) + (when (and (not *not-to-be*) + (mdead self)) + (trc "md-slot-value passed dead self, returning NIL" self slot-name c) (inspect self) (break "see inspector for dead ~a" self) (return-from md-slot-value nil)) @@ -57,7 +58,7 @@ (record-caller c)))) (defun chk (s &optional (key 'anon)) - (when (eq :eternal-rest (md-state s)) + (when (mdead s) (break "model ~a is dead at ~a" s key))) ;;;(defmethod trcp ((c cell)) @@ -77,6 +78,9 @@ (count-it :ensure-value-is-current) ;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer) + (when *not-to-be* + (return-from ensure-value-is-current t)) + (when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c)))) (break "model ~a of cell ~a is dead" (c-model c) c)) --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/01/29 04:29:52 1.14 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/12 22:53:26 1.15 @@ -31,9 +31,9 @@ ;___________________ birth / death__________________________________ (defgeneric mdead (self) - (:method ((self model-object)) - (eq :eternal-rest (md-state self))) + (unless *not-to-be* + (eq :eternal-rest (md-state self)))) (:method (self) (declare (ignore self)) @@ -45,20 +45,20 @@ (:method :around ((self model-object)) (declare (ignorable self)) - (trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver)) - "not.to-be nailing" self) - ;;showpanic (c-assert (not (eq (md-state self) :eternal-rest))) - (unless (eq (md-state self) :eternal-rest) - (call-next-method) - - (setf (fm-parent self) nil - (md-state self) :eternal-rest) - - (md-map-cells self nil - (lambda (c) - (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not.to-be with primary method (use :before etc) + (let ((*not-to-be* t)) + (trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver)) + "not.to-be nailing" self) + (unless (eq (md-state self) :eternal-rest) + (call-next-method) + + (setf (fm-parent self) nil + (md-state self) :eternal-rest) + + (md-map-cells self nil + (lambda (c) + (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not.to-be with primary method (use :before etc) - (trc nil "not.to-be cleared 2 fm-parent, eternal-rest" self)))) + (trc nil "not.to-be cleared 2 fm-parent, eternal-rest" self))))) (defun md-quiesce (self) (trc nil "md-quiesce nailing cells" self (type-of self)) From r at common-lisp.net Sun Apr 13 08:07:53 2008 From: r at common-lisp.net (Frieda) Date: Sun, 13 Apr 2008 16:07:53 +0800 Subject: [cells-cvs] Research has revealed! Message-ID: <4801BF59.5050604@common-lisp.net> Recent discoveries in herbal science have shed new light on the subject of penis enlargement. Research has revealed that your penis has the ability to grow beyond its current size when fully erect. Like all the other muscles in your body, your penis is actually designed to grow! http://www.qunebtoh.com/ From phildebrandt at common-lisp.net Sun Apr 13 10:22:03 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:22:03 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080413102203.C182D751AF@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv30090 Modified Files: md-slot-value.lisp Log Message: Fixed ensure-value-is-current, now works with my code. --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/12 22:53:26 1.42 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/13 10:22:03 1.43 @@ -79,7 +79,7 @@ ;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer) (when *not-to-be* - (return-from ensure-value-is-current t)) + (return-from ensure-value-is-current (c-value c))) (when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c)))) (break "model ~a of cell ~a is dead" (c-model c) c)) From phildebrandt at common-lisp.net Sun Apr 13 10:57:36 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:57:36 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/gtk-ffi Message-ID: <20080413105736.78341751B3@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/gtk-ffi In directory clnet:/tmp/cvs-serv4765/gtk-ffi Log Message: Directory /project/cells/cvsroot/cells-gtk3/gtk-ffi added to the repository From phildebrandt at common-lisp.net Sun Apr 13 10:57:36 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:57:36 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk Message-ID: <20080413105736.54BE4751B1@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv4765/cells-gtk Log Message: Directory /project/cells/cvsroot/cells-gtk3/cells-gtk added to the repository From phildebrandt at common-lisp.net Sun Apr 13 10:57:36 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:57:36 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/ph-maths Message-ID: <20080413105736.C942C751B2@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/ph-maths In directory clnet:/tmp/cvs-serv4765/ph-maths Log Message: Directory /project/cells/cvsroot/cells-gtk3/ph-maths added to the repository From phildebrandt at common-lisp.net Sun Apr 13 10:57:36 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:57:36 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/pod-utils Message-ID: <20080413105736.E10AA751B5@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/pod-utils In directory clnet:/tmp/cvs-serv4765/pod-utils Log Message: Directory /project/cells/cvsroot/cells-gtk3/pod-utils added to the repository From phildebrandt at common-lisp.net Sun Apr 13 10:57:36 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:57:36 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/test-images Message-ID: <20080413105736.51A16751B1@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/test-images In directory clnet:/tmp/cvs-serv4765/test-images Log Message: Directory /project/cells/cvsroot/cells-gtk3/test-images added to the repository From phildebrandt at common-lisp.net Sun Apr 13 10:58:04 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:58:04 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk Message-ID: <20080413105804.898E5751B6@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv4893/cells-gtk/test-gtk Log Message: Directory /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk added to the repository From phildebrandt at common-lisp.net Sun Apr 13 10:59:16 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:59:16 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3 Message-ID: <20080413105916.A569B751B5@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3 In directory clnet:/tmp/cvs-serv5005 Added Files: INSTALL.TXT asdf.lisp config.lisp Log Message: cells-gtk3 initial. --- /project/cells/cvsroot/cells-gtk3/INSTALL.TXT 2008/04/13 10:59:16 NONE +++ /project/cells/cvsroot/cells-gtk3/INSTALL.TXT 2008/04/13 10:59:16 1.1 You don't need to read this file if you are installing from a snapshot tarball. This only concerns the situation where you get the pieces cells, hello-c, cells-gtk etc, individually. ############################################################################################################# The notes below apply to the UFFI port of Cells-gtk done by Ken Tilton. (Actually I have forked UFFI and call it Hello-C, but the idea is the same: portable FFI.) For the original version by Vasilis Margioulas, which uses native CLisp FFI to good advantage, grab this: http://common-lisp.net/cgi-bin/viewcvs.cgi/cells-gtk/clisp-cgtk/clisp-cgtk.tar.gz?tarball=1&cvsroot=cells-gtk ...and follow the INSTALL.TXT in that. ############################################################################################################## Dependencies: Utils-kt: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/utils-kt/utils-kt.tar.gz?tarball=1&cvsroot=cells Hello-C: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/hello-c/hello-c.tar.gz?tarball=1&cvsroot=cells Cells: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/cells/cells.tar.gz?tarball=1&cvsroot=cells On windows install Gtk: http://prdownloads.sourceforge.net/gimp-win/gtk%2B-2.4.10-20041001-setup.zip?download Add the gtk libs to your PATH variable: Start>Settings>Control Panel>System>Advanced>Environment Variables> Then select PATH and hit "Edit". Append to existing value: "C:\Program Files\Common Files\GTK\2.0\bin"; ..prior values... Edit load.lisp and follow the instructions there. No, you cannot just load it. Note: On windows under emacs with slime, the gtk window does not popup. You must start the application from a dos prompt. Tested on: Windows xp with gtk 2.4.10 and clisp 2.33, using AllegroCL 6.2 Enterprise and Lispworks 4.3 Personal Known bugs: On Windows: Clisp crash if [My Computer]-> [Properties]-> [Advanced]-> [Perfomance Settings]-> [Show windows contents while dragging] is set and resize the window while viewing a listbox or treebox. --- /project/cells/cvsroot/cells-gtk3/asdf.lisp 2008/04/13 10:59:16 NONE +++ /project/cells/cvsroot/cells-gtk3/asdf.lisp 2008/04/13 10:59:16 1.1 ;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; . But note first that the canonical ;;; source for asdf is presently the cCLan CVS repository at ;;; ;;; ;;; If you obtained this copy from anywhere else, and you experience ;;; trouble using it, or find bugs, you may want to check at the ;;; location above for a more recent version (and for documentation ;;; and test files, if your copy came without them) before reporting ;;; bugs. There are usually two "supported" revisions - the CVS HEAD ;;; is the latest development version, whereas the revision tagged ;;; RELEASE may be slightly older but is considered `stable' ;;; Copyright (c) 2001-2003 Daniel Barlow and contributors ;;; ;;; 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. ;;; the problem with writing a defsystem replacement is bootstrapping: ;;; we can't use defsystem to compile it. Hence, all in one file (defpackage #:asdf (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command #:system-definition-pathname #:find-component ; miscellaneous #:hyperdocumentation #:hyperdoc #:compile-op #:load-op #:load-source-op #:test-system-version #:test-op #:operation ; operations #:feature ; sort-of operation #:version ; metaphorically sort-of an operation #:input-files #:output-files #:perform ; operation methods #:operation-done-p #:explain #:component #:source-file #:c-source-file #:cl-source-file #:java-source-file #:static-file #:doc-file #:html-file #:text-file #:source-file-type #:module ; components #:system #:unix-dso #:module-components ; component accessors #:component-pathname #:component-relative-pathname #:component-name #:component-version #:component-parent #:component-property #:component-system #:component-depends-on #:system-description #:system-long-description #:system-author #:system-maintainer #:system-license #:operation-on-warnings #:operation-on-failure ;#:*component-parent-pathname* #:*system-definition-search-functions* #:*central-registry* ; variables #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*asdf-revision* #:operation-error #:compile-failed #:compile-warned #:compile-error #:system-definition-error #:missing-component #:missing-dependency #:circular-dependency ; errors #:retry #:accept ; restarts ) (:use :cl)) #+nil (error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") (in-package #:asdf) (defvar *asdf-revision* (let* ((v "$Revision: 1.1 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot (list (parse-integer v :start (1+ colon) :junk-allowed t) (parse-integer v :start (1+ dot) :junk-allowed t))))) (defvar *compile-file-warnings-behaviour* :warn) (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) (defvar *verbose-out* nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utility stuff (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) (defun pathname-sans-name+type (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME and TYPE components" (make-pathname :name nil :type nil :defaults pathname)) (define-modify-macro appendf (&rest args) append "Append onto list") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; classes, condiitons (define-condition system-definition-error (error) () ;; [this use of :report should be redundant, but unfortunately it's not. ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function ;; over print-object; this is always conditions::%print-condition for ;; condition objects, which in turn does inheritance of :report options at ;; run-time. fortunately, inheritance means we only need this kludge here in ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] #+cmu (:report print-object)) (define-condition formatted-system-definition-error (system-definition-error) ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) (apply #'format s (format-control c) (format-arguments c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components))) (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (version :initform nil :reader missing-version :initarg :version) (parent :initform nil :reader missing-parent :initarg :parent))) (define-condition missing-dependency (missing-component) ((required-by :initarg :required-by :reader missing-required-by))) (define-condition operation-error (error) ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) (format s "~@" (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) (defclass component () ((name :accessor component-name :initarg :name :documentation "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) (in-order-to :initform nil :initarg :in-order-to) ;;; XXX crap name (do-first :initform nil :initarg :do-first) ;; methods defined using the "inline" style inside a defsystem form: ;; need to store them somewhere so we can delete them when the system ;; is re-evaluated (inline-methods :accessor component-inline-methods :initform nil) (parent :initarg :parent :initform nil :reader component-parent) ;; no direct accessor for pathname, we do this as a method to allow ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname) (operation-times :initform (make-hash-table ) :accessor component-operation-times) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties :initform nil))) ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) (format s "~@<~A, required by ~A~@:>" (call-next-method c nil) (missing-required-by c))) (defun sysdef-error (format &rest arguments) (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) ;;;; methods: components (defmethod print-object ((c missing-component) s) (format s "~@" (missing-requires c) (missing-version c) (when (missing-parent c) (component-name (missing-parent c))))) (defgeneric component-system (component) (:documentation "Find the top-level system containing COMPONENT")) (defmethod component-system ((component component)) (aif (component-parent component) (component-system it) component)) (defmethod print-object ((c component) stream) (print-unreadable-object (c stream :type t :identity t) (ignore-errors (prin1 (component-name c) stream)))) (defclass module (component) ((components :initform nil :accessor module-components :initarg :components) ;; what to do if we can't satisfy a dependency of one of this module's ;; components. This allows a limited form of conditional processing (if-component-dep-fails :initform :fail :accessor module-if-component-dep-fails :initarg :if-component-dep-fails) (default-component-class :accessor module-default-component-class :initform 'cl-source-file :initarg :default-component-class))) (defgeneric component-pathname (component) (:documentation "Extracts the pathname applicable for a particular component.")) (defun component-parent-pathname (component) (aif (component-parent component) (component-pathname it) *default-pathname-defaults*)) (defgeneric component-relative-pathname (component) (:documentation "Extracts the relative pathname applicable for a particular component.")) (defmethod component-relative-pathname ((component module)) (or (slot-value component 'relative-pathname) (make-pathname :directory `(:relative ,(component-name component)) :host (pathname-host (component-parent-pathname component))))) (defmethod component-pathname ((component component)) (let ((*default-pathname-defaults* (component-parent-pathname component))) (merge-pathnames (component-relative-pathname component)))) (defgeneric component-property (component property)) (defmethod component-property ((c component) property) (cdr (assoc property (slot-value c 'properties) :test #'equal))) (defgeneric (setf component-property) (new-value component property)) (defmethod (setf component-property) (new-value (c component) property) (let ((a (assoc property (slot-value c 'properties) :test #'equal))) (if a (setf (cdr a) new-value) (setf (slot-value c 'properties) (acons property new-value (slot-value c 'properties)))))) (defclass system (module) ((description :accessor system-description :initarg :description) (long-description :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) (licence :accessor system-licence :initarg :licence))) ;;; version-satisfies ;;; with apologies to christophe rhodes ... (defun split (string &optional max (ws '(#\Space #\Tab))) (flet ((is-ws (char) (find char ws))) (nreverse (let ((list nil) (start 0) (words 0) end) (loop (when (and max (>= words (1- max))) (return (cons (subseq string start) list))) (setf end (position-if #'is-ws string :start start)) (push (subseq string start end) list) (incf words) (unless end (return list)) (setf start (1+ end))))))) (defgeneric version-satisfies (component version)) (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) (return-from version-satisfies t)) (let ((x (mapcar #'parse-integer (split (component-version c) nil '(#\.)))) (y (mapcar #'parse-integer (split version nil '(#\.))))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) ((> (car x) (car y)) t) ((= (car x) (car y)) (bigger (cdr x) (cdr y)))))) (and (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; finding systems (defvar *defined-systems* (make-hash-table :test 'equal)) (defun coerce-name (name) (typecase name (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) (t (sysdef-error "~@" name)))) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- (defvar *system-definition-search-functions* '(sysdef-central-registry-search)) (defun system-definition-pathname (system) (some (lambda (x) (funcall x system)) *system-definition-search-functions*)) (defvar *central-registry* '(*default-pathname-defaults* #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" #+nil "telent:asdf;systems;")) (defun sysdef-central-registry-search (system) (let ((name (coerce-name system))) (block nil (dolist (dir *central-registry*) (let* ((defaults (eval dir)) (file (and defaults (make-pathname :defaults defaults :version :newest :name name :type "asd" :case :local)))) (if (and file (probe-file file)) [755 lines skipped] --- /project/cells/cvsroot/cells-gtk3/config.lisp 2008/04/13 10:59:16 NONE +++ /project/cells/cvsroot/cells-gtk3/config.lisp 2008/04/13 10:59:16 1.1 [799 lines skipped] From phildebrandt at common-lisp.net Sun Apr 13 10:59:20 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:59:20 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk Message-ID: <20080413105920.2558D751B5@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv5005/cells-gtk Added Files: #cells-gtk.asd# #tree-view.lisp# actions.lisp addon.lisp buttons.lisp cairo-drawing-area.lisp callback.lisp cells-gtk.asd cells-gtk.lpr cells3-porting-notes.lisp compat.lisp conditions.lisp dialogs.lisp display.lisp drawing-area.lisp drawing.lisp entry.lisp gl-drawing-area.lisp gtk-app.lisp layout.lisp menus.lisp packages.lisp textview.lisp tree-view.lisp widgets.lisp Log Message: cells-gtk3 initial. --- /project/cells/cvsroot/cells-gtk3/cells-gtk/#cells-gtk.asd# 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/#cells-gtk.asd# 2008/04/13 10:59:18 1.1 (in-package :common-lisp-user) (defpackage #:cells-gtk-asd (:use :cl :asdf)) (in-package :cells-gtk-asd) ;;; ;;; features ;;; ;;; run gtk in its own thread (requires bordeaux-threads) b(pushnew :cells-gtk-threads *features*) ;;; drawing-area widget using cairo (requires cl-cairo2) (pushnew :cells-gtk-cairo *features*) ;;; drawing-area widget using OpenGL (requires libgtkglext1) ;(pushnew :cells-gtk-opengl *features*) (asdf:defsystem :cells-gtk :name "cells-gtk" :depends-on (:cells :utils-kt :pod-utils :gtk-ffi :ph-maths #+cells-gtk-cairo :cl-cairo2 #+cells-gtk-threads :bordeaux-threads) :serial t :components ((:file "packages") (:file "conditions") (:file "compat") (:file "cells3-porting-notes" :depends-on ("packages")) (:file "widgets" :depends-on ("conditions")) (:file "layout" :depends-on ("widgets")) (:file "display" :depends-on ("widgets")) (:file "drawing-area" :depends-on ("widgets")) #+cells-gtk-cairo (:file "cairo-drawing-area" :depends-on ("widgets")) #+cells-gtk-opengl (:file "gl-drawing-area" :depends-on ("widgets")) (:file "buttons" :depends-on ("widgets")) (:file "entry" :depends-on ("widgets")) (:file "tree-view" :depends-on ("widgets")) (:file "menus" :depends-on ("widgets")) (:file "dialogs" :depends-on ("widgets")) (:file "textview" :depends-on ("widgets")) (:file "addon" :depends-on ("widgets")) (:file "gtk-app") )) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/#tree-view.lisp# 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/#tree-view.lisp# 2008/04/13 10:59:18 1.1 #| Cells Gtk Copyright (c) 2004 by Vasilis Margioulas 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. |# ;;; Todo: separate tree-model/tree-store stuff into another file (used by combo box too). ;;; BTW Tree-store implements the tree-model interface, among other things. (in-package :cgtk) (def-object list-store () ((item-types :accessor item-types :initarg :item-types :initform nil) (of-tree :accessor of-tree :initform (c-in nil))) () () :new-args (c_1 (list (item-types self)))) (def-object tree-store () ((item-types :accessor item-types :initarg :item-types :initform nil) (of-tree :accessor of-tree :initform (c-in nil))) () () :new-args (c_1 (list (item-types self)))) (defun tv-fail (&rest args) (declare (ignore args))) (defgeneric get-selection (none)) (def-widget tree-view (container) ((columns-def :accessor columns-def :initarg :columns :initform nil) (column-types :accessor column-types :initform (c? (mapcar #'first (columns-def self)))) (column-inits :accessor column-inits :initform (c? (mapcar #'second (columns-def self)))) (column-render :accessor column-render :initform (c? (loop for col-def in (columns-def self) for pos from 0 append (when (third col-def) (list pos (third col-def)))))) (node-render :accessor node-render :initform (c? (loop for col-def in (columns-def self) for pos from 0 append (when (fourth col-def) (list pos (fourth col-def)))))) (columns :accessor columns :initform (c? (mapcar #'(lambda (col-init) (apply #'make-be 'tree-view-column :container self col-init)) (column-inits self)))) (select-if :unchanged-if #'tv-fail :accessor select-if :initarg :select-if :initform (c-in nil)) (roots :accessor roots :initarg :roots :initform nil) (print-fn :accessor print-fn :initarg :print-fn :initform #'identity) (children-fn :accessor children-fn :initarg :children-fn :initform #'(lambda (x) (declare (ignore x)) nil)) (selected-items-cache :cell nil :accessor selected-items-cache :initform nil) (selection-mode :accessor selection-mode :initarg :selection-mode :initform :single) (expand-all :accessor expand-all :initarg :expand-all :initform (c-in nil)) (on-select :accessor on-select :initarg :on-select :initform nil) (on-edit :accessor on-edit :initarg :on-edit :initform nil) (tree-model :owning t :accessor tree-model :initarg :tree-model :initform nil)) () ; gtk-slots () ; signal-slots :on-select (lambda (self widget event data) (declare (ignore widget event data)) (with-integrity (:change 'tree-view-select-cb) (setf (value self) (get-selection self))))) (defobserver tree-model ((self tree-view)) (when new-value (gtk-tree-view-set-model (id self) (id new-value)) (with-integrity (:change 'tv-tree-model) (setf (of-tree new-value) self)))) (defobserver expand-all ((self tree-view)) (when new-value (gtk-tree-view-expand-all (id self)))) ;;; Used by combo-box also, when it is using a tree model. (cffi:defcallback tree-view-items-selector :void ((model :pointer) (path :pointer) (iter :pointer) (data :pointer)) (declare (ignore path data)) (let ((tree (of-tree (gtk-object-find model)))) (push (item-from-path (children-fn tree) (roots tree) (read-from-string (gtk-tree-model-get-cell model iter (length (column-types tree)) :string))) (selected-items-cache tree))) 0) (defmethod get-selection ((self tree-view)) (let ((selection (gtk-tree-view-get-selection (id self))) (cb (cffi:get-callback 'tree-view-items-selector))) (setf (selected-items-cache self) nil) (gtk-tree-selection-selected-foreach selection cb +c-null+) (if (equal (gtk-tree-selection-get-mode selection) 3) ;;multiple (copy-list (selected-items-cache self)) (first (selected-items-cache self))))) (defobserver selection-mode ((self tree-view)) (when new-value (let ((sel (gtk-tree-view-get-selection (id self)))) (gtk-tree-selection-set-mode sel (ecase (selection-mode self) (:none 0) (:single 1) (:browse 2) (:multiple 3)))))) (cffi:defcallback tree-view-select-handler :void ((column-widget :pointer) (event :pointer) (data :pointer)) (if-bind (tree-view (gtk-object-find column-widget)) (let ((cb (callback-recover tree-view :on-select))) (funcall cb tree-view column-widget event data)) (trc "Clean up old widgets after runs" column-widget)) 0) ;;; The check that previously was performed here (for a clos object) caused the handler ;;; not to be registered (a problem of execution ordering?). Anyway, do we need such a check? (defobserver on-select ((self tree-view)) (when new-value (let ((selected-widget (gtk-tree-view-get-selection (id self)))) (gtk-object-store selected-widget self) ;; tie column widget to clos tree-view (callback-register self :on-select new-value) (let ((cb (cffi:get-callback 'tree-view-select-handler))) ;(trc nil "tree-view on-select pcb:" cb selected-widget "changed") (gtk-signal-connect selected-widget "changed" cb))))) ;;; ;;; Listbox submodel ;;; (defmodel listbox (tree-view) ((roots :initarg :items)) ; alternate initarg for inherited slot (:default-initargs :tree-model (c? (make-instance 'list-store :item-types (append (column-types self) (list :string)))))) (defmethod items ((self listbox)) (roots self)) (defmethod (setf items) (val (self listbox)) (setf (roots self) val)) (defun mk-listbox (&rest inits) (assert *parent*) (let ((self (apply 'make-instance 'listbox (append inits (list :fm-parent *parent*))))) (with-integrity (:change 'mk-listbox-of-tree) (setf (of-tree (tree-model self)) self)) self)) (defobserver select-if ((self listbox)) (when new-value (with-integrity (:change 'listbox-select-if-observer) (setf (value self) (remove-if-not new-value (roots self)))))) (defobserver roots ((self listbox)) (when old-value (gtk-list-store-clear (id (tree-model self)))) (when new-value (gtk-list-store-set-items (id (tree-model self)) (append (column-types self) (list :string)) (loop for item in new-value for index from 0 collect (let ((i (funcall (print-fn self) item))) ;(ukt:trc nil "items output: old,new" item i) (append i (list (format nil "(~d)" index)))))))) ;;; ;;; Treebox submodel ;;; (defmodel treebox (tree-view) () (:default-initargs :tree-model (c? (mk-tree-store :item-types (append (column-types self) (list :string)))))) (defun mk-treebox (&rest inits) (assert *parent*) (let ((self (apply 'make-instance 'treebox (append inits (list :fm-parent *parent*))))) (with-integrity (:change 'mk-treebox-of-tree) (setf (of-tree (tree-model self)) self)) self)) (defobserver select-if ((self treebox)) (when new-value (with-integrity (:change 'treebox-obs-select-if) (setf (value self) (mapcan (lambda (item) (fm-collect-if item new-value)) (roots self)))))) (defobserver roots ((self treebox)) (when old-value (gtk-tree-store-clear (id (tree-model self)))) (when new-value (loop for root in new-value for index from 0 do (gtk-tree-store-set-kids (id (tree-model self)) root +c-null+ index (append (column-types self) (list :string)) (print-fn self) (children-fn self))) (when (expand-all self) (gtk-tree-view-expand-all (id self))))) ;;; These look like ("Trimmed Text" "(0 0 )") for example where menu structure is "Text --> Trimmed Text" ;;; Column-types is a list of :string, :float etc. used to reference g-value-set-string etc. (defun gtk-tree-store-set-kids (model val-tree parent-iter index column-types print-fn children-fn &optional path) (with-tree-iter (iter) (gtk-tree-store-append model iter parent-iter) ; sets iter (gtk-tree-store-set model iter ; Not a gtk function! column-types (append (funcall print-fn val-tree) (list (format nil "(~{~d ~})" (reverse (cons index path)))))) (loop for sub-tree in (funcall children-fn val-tree) for pos from 0 do (gtk-tree-store-set-kids model sub-tree iter pos column-types print-fn children-fn (cons index path))))) ;;; ;;; Cell rendering ;;; (cffi:defcallback tree-view-render-cell-callback :int ((tree-column :pointer) (cell-renderer :pointer) (tree-model :pointer) (iter :pointer) (data :pointer)) (if-bind (self (gtk-object-find tree-column)) (let ((cb (callback-recover self :render-cell))) (assert cb nil "no :render-cell callback for ~a" self) (funcall cb tree-column cell-renderer tree-model iter data)) (trc nil "Clean up old widgets from prior runs." tree-column)) 1) (defun item-from-path (child-fn roots path) (loop for index in path for node = (nth index roots) then (nth index (if node (funcall child-fn node) (return nil))) finally (return node))) (declaim (optimize (debug 3))) (defun gtk-tree-view-render-cell (col col-type cell-attrib-f &optional node-attrib-f) (trc nil "gtv-render-cell> creating callback" col col-type cell-attrib-f) (flet ((node-from-iter (model iter) (when-bind* ((tree-model (gtk-object-find model)) (tree-view (of-tree tree-model)) (path (gtk-tree-model-get-cell model iter (length (column-types tree-view)) :string))) (item-from-path (children-fn tree-view) (roots tree-view) (read-from-string path))))) (lambda (tree-column cell-renderer model iter data) (DECLARE (ignorable tree-column data)) (trc nil "gtv-render-cell (callback)> entry" tree-column cell-renderer model iter data) (let ((item-value (gtk-tree-model-get-typed-item-value model iter col col-type)) (node (node-from-iter model iter))) (trc nil "gtv-render-cell (callback)> rendering value" col col-type ret$ item-value) (apply #'gtk-object-set-property cell-renderer (case col-type (:boolean (list "active" 'boolean item-value)) (:icon (list "stock-id" 'c-string (string-downcase (format nil "gtk-~a" item-value)))) (t (list "text" 'c-string (case col-type (:date (multiple-value-bind (sec min hour day month year) (decode-universal-time (truncate item-value)) (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" day month year hour min sec))) (:string (if item-value (get-gtk-string item-value) "")) (otherwise (format nil "~a" item-value))))))) (when cell-attrib-f (gtk-cell-renderer-set-attribs cell-renderer (funcall cell-attrib-f item-value))) (when (and node node-attrib-f) (gtk-cell-renderer-set-attribs cell-renderer (funcall node-attrib-f node)))) 1))) ;;; ;;; Editable cells ;;; (defstruct renderer tree-view col) ;;; a hash table to keep track of the renderer objects (let ((renderers (make-hash-table))) (defun register-renderer-data (renderer data) (setf (gethash (cffi-sys:pointer-address renderer) renderers) data)) (defun recover-renderer-data (renderer) (gethash (cffi-sys:pointer-address renderer) renderers))) ;;; generic callback -- update treestore and call on-edit func (defun gtk-path-to-list (path) "converts \"1:2\" to (1 2)" (read-from-string (format nil "(~a)" (map 'string #'(lambda (c) (if (eql c #\:) #\space c)) path)))) (defun tree-view-edit-cell-callback (renderer path new-value) (if-bind (data (recover-renderer-data renderer)) (let* ((tree (renderer-tree-view data)) (model (id (tree-model tree))) (col (renderer-col data)) (col-type (nth col (column-types tree))) (fn (on-edit tree)) (path (cffi:foreign-string-to-lisp path)) (node (item-from-path #'kids (roots tree) (gtk-path-to-list path)))) #+msg (format t "~&Edited path ~a --> node ~a~%" (gtk-path-to-list path) (when node (md-name node))) (when node (with-tree-iter (iter) (gtk-tree-model-get-iter-from-string (id (tree-model tree)) iter path) (let ((new-val (case col-type (:boolean (= 0 (gtk-tree-model-get-cell model iter col :boolean))) ; toggle boolean cell, (t new-value)))) #+msg (format t "~&Setting value for ~a to ~a ..." node new-val) (gtk-tree-store-set-cell model iter col col-type new-val) (funcall fn node col new-val))) ; call setf function #+msg (format t " done.~%") (force-output))) (warn (format nil "No callback registered ")))) ;;; a tribute to static typing (cffi:defcallback tree-view-edit-cell-callback-string :int ((renderer :pointer) (path :pointer) (new-value :gtk-string)) (tree-view-edit-cell-callback renderer path new-value) 1) [423 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/actions.lisp 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/actions.lisp 2008/04/13 10:59:18 1.1 [504 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/addon.lisp 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/addon.lisp 2008/04/13 10:59:18 1.1 [578 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/13 10:59:18 1.1 [681 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/13 10:59:18 1.1 [1459 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/callback.lisp 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/callback.lisp 2008/04/13 10:59:18 1.1 [1498 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/13 10:59:18 1.1 [1550 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.lpr 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.lpr 2008/04/13 10:59:19 1.1 [1597 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells3-porting-notes.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells3-porting-notes.lisp 2008/04/13 10:59:19 1.1 [1631 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/compat.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/compat.lisp 2008/04/13 10:59:19 1.1 [1675 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/conditions.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/conditions.lisp 2008/04/13 10:59:19 1.1 [1713 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/13 10:59:19 1.1 [1881 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/display.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/display.lisp 2008/04/13 10:59:19 1.1 [2036 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/13 10:59:19 1.1 [2168 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing.lisp 2008/04/13 10:59:19 1.1 [2389 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/entry.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/entry.lisp 2008/04/13 10:59:20 1.1 [2542 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/13 10:59:20 1.1 [2552 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/13 10:59:20 1.1 [2897 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/layout.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/layout.lisp 2008/04/13 10:59:20 1.1 [3205 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/menus.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/menus.lisp 2008/04/13 10:59:20 1.1 [3525 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/packages.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/packages.lisp 2008/04/13 10:59:20 1.1 [3670 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/textview.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/textview.lisp 2008/04/13 10:59:20 1.1 [3843 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/13 10:59:20 1.1 [4614 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/13 10:59:20 1.1 [5078 lines skipped] From phildebrandt at common-lisp.net Sun Apr 13 10:59:23 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:59:23 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk Message-ID: <20080413105923.0BC37751B6@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv5005/cells-gtk/test-gtk Added Files: test-addon.lisp test-buttons.lisp test-dialogs.lisp test-display.lisp test-drawing-old.lisp test-drawing.lisp test-drawing2.lisp test-entry.lisp test-gtk.asd test-gtk.lisp test-gtk.lpr test-layout.lisp test-menus.lisp test-textview.lisp test-tree-view.lisp Log Message: cells-gtk3 initial. --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-addon.lisp 2008/04/13 10:59:21 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-addon.lisp 2008/04/13 10:59:21 1.1 (in-package :test-gtk) (defmodel test-addon (notebook) () (:default-initargs :tab-labels (list "Calendar" "Arrows") :kids (kids-list? (mk-vbox :kids (kids-list? (mk-calendar :md-name :calendar :init (encode-universal-time 0 0 0 6 3 1971)) (mk-label :text (c? (when (value (fm^ :calendar)) (multiple-value-bind (sec min hour day month year) (decode-universal-time (value (fm^ :calendar))) (declare (ignorable sec min hour)) (format nil "Day selected ~a/~a/~a" day month year))))))) (mk-vbox :kids (kids-list? (mk-arrow :type (c? (value (fm^ :type)))) (mk-frame :label "Arrow type" :kids (kids-list? (mk-hbox :md-name :type :kids (kids-list? (mk-radio-button :md-name :up :label "Up") (mk-radio-button :md-name :down :label "Down") (mk-radio-button :md-name :left :label "Left") (mk-radio-button :md-name :right :label "Right" :init t)))))))))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/13 10:59:21 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/13 10:59:21 1.1 (in-package :test-gtk) (defmodel test-buttons (vbox) ((nclics :accessor nclics :initform (c-in 0))) (:default-initargs :kids (c? (the-kids (mk-label :text (c? (format nil "Toggled button active = ~a" (value (fm-other :toggled-button))))) (mk-hseparator) (mk-label :text (c? (format nil "Check button checked = ~a" (value (fm-other :check-button))))) (mk-hseparator) (mk-label :text (c? (format nil "Radio button selected = ~a" (value (fm-other :radio-group))))) (mk-hseparator) (mk-label :text (c? (format nil "Button clicked ~a times" (nclics (upper self test-buttons)))) :selectable t) (mk-hseparator) (mk-hbox :kids (c? (the-kids (mk-button :stock :apply :tooltip "Click ....." :on-clicked (callback (widget event data) (incf (nclics (upper self test-buttons))))) (mk-button :label "Continuable error" :on-clicked (callback (widget event data) (trc "issuing continuable error" widget event) (error 'gtk-continuable-error :text "Oops!"))) (mk-button :label "Lisp error (Div 0)" :on-clicked (callback (widget event data) (print (/ 3 0)))) (mk-toggle-button :md-name :toggled-button :markup (c? (with-markup (:foreground (if (value self) :red :blue)) "_Toggled Button"))) (mk-check-button :md-name :check-button :markup (with-markup (:foreground :green) "_Check Button"))))) (mk-hbox :md-name :radio-group :kids (c? (the-kids (mk-radio-button :md-name :radio-1 :label "Radio 1") (mk-radio-button :md-name :radio-2 :label "Radio 2" :init t) (mk-radio-button :md-name :radio-3 :label "Radio 3")))))))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-dialogs.lisp 2008/04/13 10:59:21 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-dialogs.lisp 2008/04/13 10:59:21 1.1 (in-package :test-gtk) (defmodel test-message (button) ((message-type :accessor message-type :initarg :message-type :initform nil)) (:default-initargs :label (c? (string-downcase (symbol-name (message-type self)))) :on-clicked (callback (widget signal data) (setf (text (fm^ :message-response)) (format nil "Dialog response ~a" (show-message (format nil "~a message" (label self)) :message-type (message-type self))))))) (defmodel test-file-chooser-dialog (button) ((action :accessor action :initarg :action :initform nil)) (:default-initargs :stock (c? (action self)) ; :label (c? (string-downcase (symbol-name (action self)))) :on-clicked (callback (widget signal data) (with-integrity (:change 'on-click-cb) (setf (text (fm^ :file-chooser-response)) (format nil "File chooser response ~a" (file-chooser :title (format nil "~a dialog" (action self)) :select-multiple (value (fm^ :select-multiple-files)) :action (action self)))))))) (defmodel test-dialogs (vbox) () (:default-initargs :kids (kids-list? (mk-hbox :kids (kids-list? (append #-libcellsgtk nil #+libcellsgtk (list (mk-button :label "Query for text" :on-clicked (callback (w e d) (with-integrity (:change 'q4text) (let ((dialog (show-message-dialog :md-name :rule-name-dialog :message "Type something:" :title "My Title" :message-type :question :buttons-type :ok-cancel :content-area (mk-entry :auto-update t)))) (setf (text (fm^ :message-response)) dialog)))))) (loop for message-type in '(:info :warning :question :error) collect (make-kid 'test-message :message-type message-type))))) (mk-label :md-name :message-response) (mk-hbox :kids (kids-list? (mk-check-button :md-name :select-multiple-files :label "Select multiple") (loop for action in '(:open :save :select-folder :create-folder) collect (make-kid 'test-file-chooser-dialog :action action)))) (mk-label :md-name :file-chooser-response) (mk-notebook :expand t :fill t :tab-labels (list "Open" "Save" "Select folder" "Create folder") :kids (kids-list? (loop for action in '(:open :save :select-folder :create-folder) collect (mk-vbox :kids (kids-list? (mk-file-chooser-widget :md-name action :action action :expand t :fill t :filters '(("All" "*") ("Text" "*.txt" "*.doc") ("Libraries" "*.so" "*.lib")) :select-multiple (c? (value (fm^ :multiple)))) (mk-check-button :label "Select multiple" :md-name :multiple) (mk-label :text (c? (string (value (psib (psib)))))))))))))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-display.lisp 2008/04/13 10:59:21 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-display.lisp 2008/04/13 10:59:21 1.1 (in-package :test-gtk) (defmodel test-display (vbox) () (:default-initargs ;; g_timeout_add a function that will move the bar until the "Pulse" toggle is false. :value (c? (when (value (fm-other :pulse)) (timeout-add (value (fm-other :timeout)) (lambda () (pulse (fm-other :pbar2)) (value (fm-other :pulse)))))) :expand t :fill t :kids (kids-list? (mk-hbox :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar :button :dnd :dialog) collect (mk-image :stock :harddisk :icon-size icon-size) collect (mk-image :stock :my-g :icon-size icon-size))) (mk-hseparator) (mk-aspect-frame :ratio 1 :kids (kids-list? (mk-image :width 200 :height 250 :filename (namestring *tst-image*)))) (mk-hseparator) (mk-hbox :kids (kids-list? (mk-progress-bar :md-name :pbar :fraction (c? (value (fm^ :fraction-value)))) (mk-hscale :md-name :fraction-value :value-type 'single-float :min 0 :max 1 :step 0.01 :init 0.5) (mk-button :label "Show in status bar" :on-clicked (callback (widget event data) (push-message (fm-other :statusbar) (format nil "~a" (fraction (fm-other :pbar)))))))) (mk-hbox :kids (kids-list? (mk-progress-bar :md-name :pbar2 :pulse-step (c? (value (fm^ :step))) :fraction (c-in .1)) (mk-toggle-button :md-name :pulse :label "Pulse") (mk-label :text "Interval") (mk-spin-button :md-name :timeout :sensitive (c? (not (value (fm^ :pulse)))) :min 10 :max 1000 :init 100) (mk-label :text "Pulse step") (mk-spin-button :md-name :step :value-type 'single-float :min 0.01 :max 1 :step 0.01 :init 0.1) (mk-image :md-name :pulse-image :stock (c? (if (value (fm^ :pulse)) :yes :no))))) (mk-alignment :expand t :fill t :xalign 0 :yalign 1 :xscale 1 :kids (c? (the-kids (mk-statusbar :md-name :statusbar))))))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing-old.lisp 2008/04/13 10:59:21 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing-old.lisp 2008/04/13 10:59:21 1.1 (in-package :test-gtk) ;;; ;;; auxiliary color funcs ;;; (defun highlight-col (rgb) (mapcar #'(lambda (val) (min 1 (+ val .3))) rgb)) (defun select-col (rgb) (mapcar #'(lambda (val) (max 0 (- val .3))) rgb)) (defmacro rgb? (rgb) (with-gensyms (col) `(c? (let ((,col ,rgb)) (cond ((mouse-over-p self) (highlight-col ,col)) ((selected-p self) (select-col ,col)) (t ,col)))))) (defmacro alpha? (alpha) (with-gensyms (a) `(c? (let ((,a ,alpha)) (cond ((dragged-p self) .3) (t ,a)))))) ;;; ;;; random generators ;;; (defun rnd (min max) (+ min (random max))) (defun random-point (min-x min-y max-x max-y) (2d:v (rnd min-x max-x) (rnd min-y max-y))) (defun random-color () (loop for i from 0 below 3 collect (random 1.0))) ;;; ;;; the dialog ;;; (defmodel test-cairo-drawing (vbox) ((new-prim :accessor new-prim :initform (c-in nil))) (:default-initargs :md-name :test-drawing :kids (kids-list? (mk-hbox :fill t :expand t :kids (kids-list? (make-instance 'cairo-drawing-area :md-name :draw :expand t :fill t :width 500 :height 500) (mk-vbox :kids (kids-list? (mk-button :label "Draw Box" :on-clicked (callback (w e d) (let* ((p1 (random-point 10 10 480 480)) (p2 (2d:v+ p1 (random-point 10 10 40 40))) (col1 (random-color)) (col2 (random-color))) (trcx "rect" p1 p2 col1 col2) (mk-primitive (fm-other :draw) :rectangle :p1 (c-in p1) :p2 (c-in p2) :rgb (rgb? col1) :fill-rgb (rgb? col2) :alpha (alpha? 1) :filled t :draggable t :selectable t)))) (mk-button :label "Draw Arc" :on-clicked (callback (w e d) (let* ((p (random-point 10 10 480 480)) (radius (rnd 10 40)) (col1 (random-color)) (col2 (random-color))) (mk-primitive (fm-other :draw) :arc :p (c-in p) :radius (c-in radius) :rgb (rgb? col1) :fill-rgb (rgb? col2) :alpha (alpha? 1) :filled t :draggable t :selectable t)))) ))))))) ;;; ;;; a test-drawing tab ;;; (defmodel test-drawing (notebook) () (:default-initargs :tab-labels (list "Cairo") :kids (kids-list? (make-instance 'test-cairo-drawing)))) (defparameter *da* nil) (defun test-cairo-drawing () (setf *da* (first (kids (first (kids (start-win 'test-cairo-drawing))))))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp 2008/04/13 10:59:21 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp 2008/04/13 10:59:21 1.1 (in-package :test-gtk) ;;; ;;; auxiliary color funcs ;;; (defun highlight-col (rgb) (mapcar #'(lambda (val) (min 1 (+ val .3))) rgb)) (defun select-col (rgb) (mapcar #'(lambda (val) (max 0 (- val .3))) rgb)) (defmacro rgb? (rgb) (with-gensyms (col) `(c? (let ((,col ,rgb)) (cond ((mouse-over-p self) (highlight-col ,col)) ((selected-p self) (select-col ,col)) (t ,col)))))) (defmacro alpha? (alpha) (with-gensyms (a) `(c? (let ((,a ,alpha)) (cond ((dragged-p self) .3) (t ,a)))))) ;;; ;;; random generators ;;; (defun rnd (min max) (+ min (random max))) (defun random-point (min-x min-y max-x max-y) (2d:v (rnd min-x max-x) (rnd min-y max-y))) (defun random-color () (loop for i from 0 below 3 collect (random 1.0))) ;;; ;;; drag'n'drop test ;;; (defmodel test-cairo-dragging (hbox) () (:default-initargs :fill t :expand t :kids (kids-list? (make-instance 'cairo-drawing-area :md-name :draw :expand t :fill t :fm-parent *parent* :width 500 :height 500) (mk-vbox :kids (kids-list? (list (mk-button :label "Draw Box" :on-clicked (callback (w e d) (let* ((p1 (random-point 10 10 480 480)) (p2 (2d:v+ p1 (random-point 10 10 40 40))) (col1 (random-color)) (col2 (random-color))) (trcx "rect" p1 p2 col1 col2) (mk-primitive (fm-other :draw) :rectangle :p1 (c-in p1) :p2 (c-in p2) :rgb (rgb? col1) :fill-rgb (rgb? col2) :alpha (alpha? 1) :filled t :draggable t :selectable t)))) (mk-button :label "Draw Arc" :on-clicked (callback (w e d) (let* ((p (random-point 10 10 480 480)) (radius (rnd 10 40)) (col1 (random-color)) (col2 (random-color))) (mk-primitive (fm-other :draw) :arc :p (c-in p) :radius (c-in radius) :rgb (rgb? col1) [88 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing2.lisp 2008/04/13 10:59:21 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing2.lisp 2008/04/13 10:59:21 1.1 [225 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-entry.lisp 2008/04/13 10:59:21 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-entry.lisp 2008/04/13 10:59:21 1.1 [294 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.asd 2008/04/13 10:59:21 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.asd 2008/04/13 10:59:21 1.1 [311 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lisp 2008/04/13 10:59:21 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lisp 2008/04/13 10:59:21 1.1 [386 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lpr 2008/04/13 10:59:21 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lpr 2008/04/13 10:59:21 1.1 [429 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-layout.lisp 2008/04/13 10:59:22 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-layout.lisp 2008/04/13 10:59:22 1.1 [494 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-menus.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-menus.lisp 2008/04/13 10:59:23 1.1 [669 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-textview.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-textview.lisp 2008/04/13 10:59:23 1.1 [751 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-tree-view.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-tree-view.lisp 2008/04/13 10:59:23 1.1 [1051 lines skipped] From phildebrandt at common-lisp.net Sun Apr 13 10:59:23 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:59:23 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/gtk-ffi Message-ID: <20080413105923.A385C751B6@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/gtk-ffi In directory clnet:/tmp/cvs-serv5005/gtk-ffi Added Files: Makefile Makefile.win32 gdk-other.lisp gtk-adds.c gtk-button.lisp gtk-core.lisp gtk-ffi-impl.lisp gtk-ffi.asd gtk-ffi.lisp gtk-ffi.lpr gtk-gl-ext.lisp gtk-list-tree.lisp gtk-menu.lisp gtk-other.lisp gtk-threads.lisp gtk-tool.lisp gtk-utilities.lisp libcellsgtk-solaris.so libcellsgtk.so package.lisp specs.new Log Message: cells-gtk3 initial. --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/Makefile 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/Makefile 2008/04/13 10:59:23 1.1 # # Purpose: build libcellsgtk.so # # NOTE THAT THERE IS A libcellsgtk.so FOR LINUX AT: # ftp://common-lisp.net/pub/project/cells-gtk/libcellsgtk.so # If you try it, I'd be interested to know if you have problems due to # version mismatch with your GTK+ installation # # You don't need libCellsGtk.so to run the demo, but you will to: # - add an entry text widget to a dialog # - add menu items using populate-popup (see GTK textview). # - Use a TreeModel (hierarchical arrangment of items) in a ComboBox. # - Use GTK text iters (used for marking text in text-buffers). # - Use the drawing function: setting colors, getting the window of a widget # # As of this writing, those are the only situations where it is needed. # But this list is getting longer with each release. # See FAQ.txt for more of the motivation. # # In order to compile the library you will need to have on hand the C header files # corresponding the libgtk.so you are using. # See http://developer.gnome.org/doc/API/2.4/gtk/gtk-building.html # On linux, it is a matter of installing 4 or 5 .rpms and typing "make" # Or at least that is how it worked for me. # # Once built, place the library in the directory containing libgtk. all: gcc -fPIC -c gtk-adds.c `pkg-config --cflags --libs gtk+-2.0` gcc -shared -o libcellsgtk.so gtk-adds.o `pkg-config --cflags --libs gtk+-2.0` solaris: gcc -fPIC -R/opt/csw/lib -L/opt/csw/lib -c gtk-adds.c `pkg-config --cflags --libs gtk+-2.0 glib-2.0` gcc -fPIC -R/opt/csw/lib -L/opt/csw/lib -shared -o libcellsgtk.so gtk-adds.o `pkg-config --cflags --libs gtk+-2.0 glib-2.0` --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/Makefile.win32 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/Makefile.win32 2008/04/13 10:59:23 1.1 # # Purpose: build libcellsgtk.so # # NOTE THAT THERE IS A libcellsgtk.dll FOR WIN32 AT: # ftp://common-lisp.net/pub/project/cells-gtk/libcellsgtk.dll # If you try it, I'd be interested to know if you have problems due to # version mismatch with your GTK+ installation # # You don't need libCellsGtk.so to run the demo, but you will to: # - add an entry text widget to a dialog # - add menu items using populate-popup (see GTK textview). # - Use a TreeModel (hierarchical arrangment of items) in a ComboBox. # - Use GTK text iters (used for marking text in text-buffers). # - Use the drawing function: setting colors, getting the window of a widget # # As of this writing, those are the only situations where it is needed. # But this list is getting longer with each release. # See FAQ.txt for more of the motivation. # # I build libcellsgtk.dll under cygwin. I use the win32 development directories from the site # ftp://ftp.gtk.org/pub/gtk/v2.8/win32 and also ftp://ftp.gtk.org/pub/gtk/v2.8/dependencies # I tried also the gtk-devel stuff you can get directly # with cygwin setup.exe, but it doesn't seem to have everything you need. When you get it all # downloaded, modify the '.pc' files in /local/win32/gtk/lib/pkgconfig so that prefix= # is set to wherever you placed the stuff. # Here is a list of the pc (package config) files.... # # -rwx------ 1 pdenno users 267 2005-11-13 15:02 atk.pc # -rwx------ 1 pdenno users 267 2005-11-13 15:02 cairo.pc # -rwx------ 1 pdenno users 336 2005-11-13 15:03 gdk-2.0.pc # -rwx------ 1 pdenno users 287 2005-11-13 15:03 gdk-pixbuf-2.0.pc # -rwx------ 1 pdenno users 336 2005-11-13 15:03 gdk-win32-2.0.pc # -rwx------ 1 pdenno users 355 2005-11-13 15:03 glib-2.0.pc # -rwx------ 1 pdenno users 260 2005-11-13 15:04 gmodule-2.0.pc # -rwx------ 1 pdenno users 259 2005-11-13 15:04 gmodule-no-export-2.0.pc # -rwx------ 1 pdenno users 251 2005-11-13 15:04 gobject-2.0.pc # -rwx------ 1 pdenno users 229 2005-11-13 15:05 gthread-2.0.pc # -rwx------ 1 pdenno users 362 2005-11-13 15:05 gtk+-2.0.pc # -rwx------ 1 pdenno users 362 2005-11-13 15:05 gtk+-win32-2.0.pc # -rwx------ 1 pdenno users 229 2005-11-13 15:07 libpng.pc # -rwx------ 1 pdenno users 229 2005-11-13 14:20 libpng12.pc # -rwx------ 1 pdenno users 229 2005-11-13 14:20 libpng13.pc # -rwx------ 1 pdenno users 322 2005-11-13 15:07 pango.pc # -rwx------ 1 pdenno users 315 2005-11-13 15:07 pangocairo.pc # -rwx------ 1 pdenno users 403 2005-11-13 15:08 pangoft2.pc # -rwx------ 1 pdenno users 276 2005-11-13 15:08 pangowin32.pc # # ...and where is what the first line of one looks like on my machine: # prefix=/local/win32/gtk # Some like libpng have prefix=/usr ... because that is where it is (cygwin default). # # Once built, place the library in the directory containing libgtk. all: gcc -mno-cygwin -c gtk-adds.c `pkg-config --cflags --libs gtk+-2.0` dlltool -e exports.o -z cellsgtk.def -l cellsgtk.lib gtk-adds.o gcc -mno-cygwin -mwindows -mdll -L/usr/lib/mingw gtk-adds.o exports.o -o libcellsgtk.dll `pkg-config --cflags --libs gtk+-2.0` -specs=specs.new --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gdk-other.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gdk-other.lisp 2008/04/13 10:59:23 1.1 (in-package :gtk-ffi) (def-gtk-lib-functions :gdk (gdk-gc-new ((drawable c-pointer)) c-pointer) (gdk-draw-line ((drawable c-pointer) (gc c-pointer) (x1 int) (y1 int) (x2 int) (y2 int))) (gdk-pixmap-new ((drawable c-pointer) (width int) (height int) (depth int)) c-pointer) (gdk-draw-drawable ((drawable c-pointer) (gc c-pointer) (src c-pointer) (xsrc int) (ysrc int) (xdest int) (ydest int) (width int) (height int))) (gdk-draw-rectangle ((drawable c-pointer) (gc c-pointer) (filled boolean) (x int) (y int) (width int) (height int))) (gdk-gc-set-rgb-fg-color ((gc c-pointer) (color c-pointer))) (gdk-gc-set-rgb-bg-color ((gc c-pointer) (color c-pointer))) (gdk-color-parse ((spec c-string) (color c-pointer)) int) (gdk-draw-layout ((drawable c-pointer) (gc c-pointer) (x int) (y int) (pango-layout c-pointer))) (gdk-gc-set-line-attributes ((gc c-pointer) (line-width int) (line-style int) (cap-style int) (join-style int)))) --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-adds.c 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-adds.c 2008/04/13 10:59:23 1.1 #include #include asm (".section .drectve"); asm (".ascii \"-export:gtk_adds_text_iter_new\""); asm (".ascii \" -export:gtk_adds_text_view_popup_menu\""); asm (".ascii \" -export:gtk_adds_dialog_vbox\""); asm (".ascii \" -export:gtk_adds_tree_iter_new\""); asm (".ascii \" -export:gtk_adds_widget_mapped_p\""); asm (".ascii \" -export:gtk_adds_widget_visible_p\""); asm (".ascii \" -export:gtk_adds_widget_window\""); asm (".ascii \" -export:gtk_adds_color_new\""); asm (".ascii \" -export:gtk_adds_color_set_rgb\""); asm (".ascii \" -export:gtk_adds_ok\""); asm (".ascii \" -export:gtk_adds_g_thread_supported\""); /* Return a pointer to the vbox of a dialog. * Useful for adding widgets to dialogs. For example, * if you need a dialog with text entry capability. */ GtkWidget * gtk_adds_dialog_vbox (GtkWidget *dialog) { return GTK_DIALOG(dialog)->vbox; } /* Return a pointer to the popup_menu of a textview. * Useful if you need to add to the default textview menu * on a populate-popup event. */ GtkWidget * gtk_adds_text_view_popup_menu (GtkWidget *text_view) { return GTK_TEXT_VIEW(text_view)->popup_menu; } /* C programmers allocate iters on the stack. We use this. Free it with gtk-text-iter-free */ GtkTextIter * gtk_adds_text_iter_new () { GtkTextIter example; return gtk_text_iter_copy(&example); } /* C programmers allocate iters on the stack. We use this. Free it with gtk-tree-iter-free */ GtkTreeIter * gtk_adds_tree_iter_new () { GtkTreeIter example; return gtk_tree_iter_copy(&example); } int gtk_adds_widget_mapped_p (GtkWidget *wid) { return ((GTK_WIDGET_FLAGS (wid) & GTK_MAPPED) != 0) ? 1 : 0; } int gtk_adds_widget_visible_p (GtkWidget *wid) { return ((GTK_WIDGET_FLAGS (wid) & GTK_VISIBLE) != 0) ? 1 : 0; } GdkWindow * gtk_adds_widget_window (GtkWidget *wid) { return wid->window; } GdkColor * gtk_adds_color_new () { return ((GdkColor *)malloc(sizeof(GdkColor))); } void gtk_adds_color_set_rgb (GdkColor* color, guint r, guint g, guint b) { color->red = r; color->green = g; color->blue = b; } /* You can run this one without having gtk running, to be sure the library was loaded. */ int gtk_adds_ok () { return 1; } /* This macro tells us whether g_thread_init has already been called from this session This is important to avoid double initialization, which kills the current lisp session */ int gtk_adds_g_thread_supported () { return g_thread_supported (); } --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-button.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-button.lisp 2008/04/13 10:59:23 1.1 #| Gtk ffi Copyright (c) 2004 by Vasilis Margioulas 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 :gtk-ffi) (def-gtk-lib-functions :gtk (gtk-button-new :pointer ()) (gtk-button-set-label :void ((button :pointer) (label :gtk-string))) (gtk-button-set-relief :void ((button :pointer) (style :int))) (gtk-button-set-use-stock :void ((button :pointer) (use-stock :gtk-boolean))) (gtk-toggle-button-new :pointer ()) (gtk-toggle-button-set-mode :void ((button :pointer) (draw-indicator :gtk-boolean))) (gtk-toggle-button-set-active :void ((button :pointer) (active :gtk-boolean))) (gtk-toggle-button-get-active :gtk-boolean ((button :pointer))) (gtk-check-button-new :pointer ()) (gtk-radio-button-new :pointer ((gslist :pointer))) (gtk-radio-button-new-from-widget :pointer ((radio-group :pointer))) (gtk-spin-button-new :pointer ((adjustment :pointer) (climb-rate :double) (digits :unsigned-int))) (gtk-spin-button-new-with-range :pointer ((minval :double) (maxval :double) (step :double))) (gtk-spin-button-set-value :void ((spin-button :pointer) (value :double))) (gtk-spin-button-get-value :double ((spin-button :pointer))) (gtk-spin-button-get-value-as-int :int ((spin-button :pointer))) (gtk-spin-button-set-wrap :void ((spin-button :pointer) (wrap :gtk-boolean)))) #+debugthis (gtk-toggle-button-get-active ((button c-pointer)) boolean) #+not (DEF-GTK-FUNCTION :GTK GTK-TOGGLE-BUTTON-GET-ACTIVE :ARGUMENTS ((BUTTON C-POINTER)) :RETURN-TYPE BOOLEAN :CALL-DIRECT T) --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-core.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-core.lisp 2008/04/13 10:59:23 1.1 #| Gtk ffi Copyright (c) 2004 by Vasilis Margioulas 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 :gtk-ffi) (def-gtk-lib-functions :glib (g-free :void ((data :pointer))) (g-slist-free :void ((lst :pointer))) (g-timeout-add :unsigned-int ((milliseconds :unsigned-int) (func :pointer) (data :pointer))) (g-locale-from-utf8 :gtk-string ((utf8-string :pointer) (len :int) (bytes-read :pointer) (bytes-written :pointer) (gerror :pointer))) (g-locale-to-utf8 :pointer ((local-string :gtk-string) (len :int) (bytes-read :pointer) (bytes-written :pointer) (gerror :pointer)))) (def-gtk-lib-functions :gthread (g-thread-init :void ((vtable :pointer)))) (def-gtk-lib-functions :gdk (gdk-threads-init :void ()) (gdk-threads-enter :void ()) (gdk-threads-leave :void ()) (gdk-flush :void ())) (uffi:def-union g-value-data (v-int :int) (v-uint :unsigned-int) (v-long :long) (v-ulong :unsigned-long) (v-int64-lo :int) (v-int64-hi :int) (v-uint64-lo :unsigned-int) (v-uint64-hi :unsigned-int) (v-float :float) (v-double :double) (v-pointer :pointer-void)) (uffi:def-struct g-value (g-type (:array :int 16))) (defmacro with-g-value ((var) &body body) [61 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi-impl.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi-impl.lisp 2008/04/13 10:59:23 1.1 [97 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.asd 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.asd 2008/04/13 10:59:23 1.1 [131 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.lisp 2008/04/13 10:59:23 1.1 [578 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.lpr 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.lpr 2008/04/13 10:59:23 1.1 [618 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-gl-ext.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-gl-ext.lisp 2008/04/13 10:59:23 1.1 [725 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-list-tree.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-list-tree.lisp 2008/04/13 10:59:23 1.1 [946 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-menu.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-menu.lisp 2008/04/13 10:59:23 1.1 [1052 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-other.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-other.lisp 2008/04/13 10:59:23 1.1 [1971 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-threads.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-threads.lisp 2008/04/13 10:59:23 1.1 [2022 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-tool.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-tool.lisp 2008/04/13 10:59:23 1.1 [2131 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-utilities.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-utilities.lisp 2008/04/13 10:59:23 1.1 [2388 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/libcellsgtk-solaris.so 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/libcellsgtk-solaris.so 2008/04/13 10:59:23 1.1 [2441 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/libcellsgtk.so 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/libcellsgtk.so 2008/04/13 10:59:23 1.1 [2486 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/package.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/package.lisp 2008/04/13 10:59:23 1.1 [2567 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/specs.new 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/specs.new 2008/04/13 10:59:23 1.1 [2654 lines skipped] From phildebrandt at common-lisp.net Sun Apr 13 10:59:25 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:59:25 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/ph-maths Message-ID: <20080413105925.E05A1751BF@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/ph-maths In directory clnet:/tmp/cvs-serv5005/ph-maths Added Files: ph-maths.asd ph-maths.lisp Log Message: cells-gtk3 initial. --- /project/cells/cvsroot/cells-gtk3/ph-maths/ph-maths.asd 2008/04/13 10:59:24 NONE +++ /project/cells/cvsroot/cells-gtk3/ph-maths/ph-maths.asd 2008/04/13 10:59:24 1.1 (asdf:defsystem :ph-maths :name "ph-maths" :components ((:file "ph-maths"))) --- /project/cells/cvsroot/cells-gtk3/ph-maths/ph-maths.lisp 2008/04/13 10:59:24 NONE +++ /project/cells/cvsroot/cells-gtk3/ph-maths/ph-maths.lisp 2008/04/13 10:59:24 1.1 ;;; ;;; Linear algebra 2d (defpackage :ph-maths-2d (:use :cl) (:nicknames :2d) (:export :v :x :y :v+ :v- :v* :min-abs :max-abs :v-polar :r :phi :polar-coords :polar-radius :polar-angle :cartesian-coords :abs-angle :deg->rad :rad->deg :v0 :vp :p :<> :intersect-line-circle :distance-point-line :point-in-box-p :to-decimal :to-rgb :to-rgb-vector :~=)) (in-package :ph-maths-2d) (declaim (optimize (speed 1) (debug 3) (space 0))) (defun denil (lst) (loop for val in lst if val collect val)) ;;; represent 2d vector as cons (declaim (inline v x y)) (defun v (x y) (cons x y)) (defun x (v) (car v)) (defun y (v) (cdr v)) ;;; basic linear algebra (declaim (inline v-reduce v+ v- v*)) (defun v-reduce (fn vectors) (declare (function fn)) (reduce #'(lambda (v1 v2) (v (funcall fn (x v1) (x v2)) (funcall fn (y v1) (y v2)))) (denil vectors))) (defun v+ (&rest vectors) (v-reduce #'+ vectors)) (defun v- (&rest vectors) (v-reduce #'- vectors)) (defun v* (lambda vector) (v (* (x vector) lambda) (* (y vector) lambda))) ;;; min/max (declaim (inline abs-reduce min-abs max-abs)) (defun abs-reduce (fn vals) (reduce fn (denil vals) :key #'abs)) (defun min-abs (&rest vals) (abs-reduce #'min vals)) (defun max-abs (&rest vals) (abs-reduce #'max vals)) ; polar coordinates (declaim (inline v-polar phi r polar-radius polar-angle polar-coords)) (defun v-polar (phi r) (cons phi r)) (defun phi (v) (car v)) (defun r (v) (cdr v)) (defun polar-radius (v) "return radius of cartesian vector v" (sqrt (+ (* (x v) (x v)) (* (y v) (y v))))) (defun polar-angle (v) "return angle of cartesian vector v" (if (zerop (x v)) (if (>= (y v) 0) #.(* pi -0.5) #.(* pi 0.5)) (atan (- (y v)) (x v)))) (defun polar-coords (v) "return a polar representation of cartesian vector v" (v-polar (polar-angle v) (polar-radius v))) ; cartesian coords (declaim (inline cartesian-coords)) (defun cartesian-coords (v-polar) "returns a cartesian representation of polar vector v-polar" (v (* (r v-polar) (cos (phi v-polar))) (* -1 (r v-polar) (sin (phi v-polar))))) ; degrees (declaim (inline deg->rad rad->deg abs-angle)) (defun deg->rad (degs) (/ (* degs pi) 180.0)) (defun rad->deg (rads) (* (/ rads pi) 180.0)) (defun abs-angle (phi) "returns a positive angle 0 <= phi <= 2pi" (cond ((or (= phi #.(* 2 pi)) (= phi #.(* -2 pi))) phi) (t (mod phi #.(* 2 pi))))) ; albegra -- 2d (declaim (inline v0 vp <> p)) (defun v0 (v) "returns a vector with the same direction as v and unit length" (let ((r (polar-radius v))) (if (plusp r) (v* (/ 1 r) v) (v 0 0)))) (defun vp (v) "returns a unit vector perpendicular to v" (let ((u (v0 v))) (v (- (y u)) (x u)))) (defun <> (v1 v2) "returns the scalar product " (+ (* (x v1) (x v2)) (* (y v1) (y v2)))) (defun p (v1 v2) "returns the projection of v1 onto v2. Second return value is the length of the projection." (let* ((v2_0 (v0 v2)) (len (<> v2_0 v1))) (values (v* len v2_0) len))) (declaim (inline distance-point-line intersect-line-circle point-in-box-p)) (defun distance-point-line (point p1 p2) "returns the shortest distance from point to the line p1,p2." (abs (second (multiple-value-list (p (v- p1 point) (vp (v- p2 p1))))))) (defun intersect-line-circle (p1 p2 r) "returns the intersection of a line through p1 and p2 and a circle around p2 with radius r" (v+ p2 (v* r (v0 (v- p1 p2))))) (defun point-in-box-p (p p1 p2 &key (tol 0)) "returns true if p is inside the box given by p1,p2" (and (< (- (min (x p1) (x p2)) tol) (x p) (+ (max (x p1) (x p2)) tol)) (< (- (min (y p1) (y p2)) tol) (y p) (+ (max (y p1) (y p2)) tol)))) ;; base conversion (defun to-decimal (val &key (base 16)) "converts val (a value in base base as a string) to an integer" (loop for p from 0 to (1- (length val)) for x downfrom (1- (length val)) summing (* (let ((c (char-code (char val p)))) (cond ((< 47 c 58) (- c 48)) ((< 64 c 91) (- c 55)) ((< 96 c 123) (- c 87)) (t (warn "Illegal character in hex argument to to-decimal") 0))) (expt base x)))) (defun to-rgb (html-color) "parses an html color code like #A204B2 to '(.8 .01 .7 4)" (loop for val from 0 to 2 for pos = (1+ (* val 2)) collecting (/ (to-decimal (subseq html-color pos (+ pos 2))) 256))) (defun to-rgb-vector (html-color) "parses an html color code like #A204B2 to #(.8 .01 .7 4)" (coerce (loop for val from 0 to 2 for pos = (1+ (* val 2)) collecting (/ (to-decimal (subseq html-color pos (+ pos 2))) 256)) 'vector)) ; fuzzy comparison (defun ~= (&rest params) (if (cdr params) (let ((max (apply #'max params)) (min (apply #'min params))) (> .05 (abs (/ (- max min) (max (abs max) (abs min) 1d-8))))) t)) From phildebrandt at common-lisp.net Sun Apr 13 10:59:26 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 06:59:26 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/pod-utils Message-ID: <20080413105926.107CC751B6@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/pod-utils In directory clnet:/tmp/cvs-serv5005/pod-utils Added Files: kt-trace.lisp pod-utils.asd utils.lisp Log Message: cells-gtk3 initial. --- /project/cells/cvsroot/cells-gtk3/pod-utils/kt-trace.lisp 2008/04/13 10:59:26 NONE +++ /project/cells/cvsroot/cells-gtk3/pod-utils/kt-trace.lisp 2008/04/13 10:59:26 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 ------------------------------------------- (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)) ; trc is now in cells--- /project/cells/cvsroot/cells-gtk3/pod-utils/pod-utils.asd 2008/04/13 10:59:26 NONE +++ /project/cells/cvsroot/cells-gtk3/pod-utils/pod-utils.asd 2008/04/13 10:59:26 1.1 (asdf:defsystem :pod-utils :name "pod-utils" :components ((:file "utils") (:file "kt-trace"))) --- /project/cells/cvsroot/cells-gtk3/pod-utils/utils.lisp 2008/04/13 10:59:26 NONE +++ /project/cells/cvsroot/cells-gtk3/pod-utils/utils.lisp 2008/04/13 10:59:26 1.1 ;;; Copyright (c) 2004 Peter Denno ;;; ;;; 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. ;;;----------------------------------------------------------------------- ;;; ;;; Peter Denno ;;; Date: 12/2/95 - on going. ;;; ;;; Generally applicable utilities. Some from Norvig's "Paradigms of ;;; Artificial Programming," Some from Kiczales et. al. "The Art of the ;;; Metaobject Protocol," some from Graham's "On Lisp," some from Sam Steingold. ;;; (in-package :cl-user) (defpackage pod-utils (:nicknames pod) (:use cl) (:export combinations flatten kintern sintern mapappend pairs memo debug-memo memoize clear-memoize defun-memoize VARS mac mac2 load-ht when-bind if-bind when-bind* substring remove-extra-spaces break-line-at read-string-to-list split name2initials c-name2lisp lisp-name2c single-p mklist longer group prune find2 before duplicate split-if mvb mvs dbind decode-time-interval strcat tree-search depth-first-search prepend breadth-first-search update with-stack-size pprint-without-strings chop setx reuse-cons intersect-predicates defmemo system-clear-memoized-fns system-add-memoized-fn system-list-memoized-fns system-forget-memoized-fns with-gensyms fail)) ; ph: removed last1 new-reslist reslist-pop reslist-push reslist-fillptr now (in-package :pod-utils) ;;; Purpose: Return the combinations possible when selecting one item ;;; from each of the argument sets. ;;; Example: (combinations '(a) '(b c) '(d e)) ;;; => ((A B D) (A B E) (A C D) (A C E)) ;;; Arg: sets - lists ;;; Value: a list of lists. If the argument is nil, it returns nil. (defun combinations (&rest sets) (cond ((null sets) nil) (t (flet ((combinations-aux (aset bset) (cond ((not aset) bset) ((not bset) aset) (t (loop for a in aset append (loop for b in bset collect (list a b))))))) (loop for set in (reduce #'combinations-aux sets) collect (flatten set)))))) (defun flatten (input &optional accumulator) "Return a flat list of the atoms in the input. Ex: (flatten '((a (b (c) d))) => (a b c d))" (cond ((null input) accumulator) ((atom input) (cons input accumulator)) (t (flatten (first input) (flatten (rest input) accumulator))))) (declaim (inline kintern)) (defun kintern (string &rest args) "Apply FORMAT to STRING and ARGS, upcase the resulting string and intern it into the KEYWORD package." (intern (string-upcase (apply #'format nil (string string) args)) (find-package "KEYWORD"))) (declaim (inline sintern)) (defun sintern (string &rest args) "Apply FORMAT to STRING and ARGS, upcase the resulting string and intern it into the current (*PACKAGE*) package." (intern (string-upcase (apply #'format nil (string string) args)))) (defun mapappend (fun &rest args) (loop until (some #'null args) append (apply fun (loop for largs on args collect (pop (first largs)))))) (defun mapnconc (fun &rest args) (loop until (some #'null args) nconc (apply fun (loop for largs on args collect (pop (first largs)))))) ;;; Purpose: Return a list of pairs of elements from the argument list: ;;; Ex: (pairs '(a b c d)) => ((a b) (a c) (a d) (b c) (b d) (c d)) ;;; ;;; Args: inlist - a list (defun pairs (inlist) (loop for sublist on inlist while (cdr sublist) append (loop for elem in (cdr sublist) collect `(,(first sublist) ,elem)))) ;;; Purpose: Called by memoize, below. This returns ;;; the memoized function. Norvig, Page 270. ;;; When you want to use this on &rest args use :test #'equal :key #'identity ;;; Args: fn - the function object. ;;; name - the function symbol. ;;; key - On what argument the result is indexed. ;;; test - Either eql or equal, the :test of the hash table. (defun memo (fn name key test) "Return a memo-function of fn." (let ((table (make-hash-table :test test))) (setf (get name 'memo) table) #'(lambda (&rest args) (let ((k (funcall key args))) (multiple-value-bind (val found-p) (gethash k table) (if found-p val (setf (gethash k table) (apply fn args)))))))) (defun debug-memo (fn name key test) "Like memo but prints *hit* on every hit." (let ((table (make-hash-table :test test))) (setf (get name 'memo) table) #'(lambda (&rest args) (let ((k (funcall key args))) (multiple-value-bind (val found-p) (gethash k table) (if found-p (progn (princ " *HIT*") val) (progn (princ " *miss*") (setf (gethash k table) (apply fn args))))))))) ;;; Purpose: memoize the argument function. ;;; Arguments as those in memo. (defun memoize (fn-name &key (key #'first) (test #'eql) (debug nil)) "Replace fn-name's global definition with a memoized version." #-Allegro-V4.3 (format t "~%;;; Memoizing (~a) ~a ****" test fn-name) #+Allegro-V4.3 (format t "~%;;; Memoizing ~a ****" fn-name) (if debug (setf (symbol-function fn-name) (debug-memo (symbol-function fn-name) fn-name key test)) (setf (symbol-function fn-name) (memo (symbol-function fn-name) fn-name key test)))) ;;; Clear the hash table from the function. (defun clear-memoize (fn-name) "Clear the hash table from a memo function." (let ((table (get fn-name 'memo))) (when table (clrhash table)))) ;;; Purpose: define a function and memoize it. ;;; Limitations: only useful for default arguments, i.e., ;;; key on first and test eql. In all other ;;; cases call (memoize :key :test ). (defmacro defun-memoize (fn args &body body) `(memoize (defun ,fn ,args ,body))) ;;; Stuff to use when you have a serious number of memoized functions, ;;; and you have a notion of "starting over." (defmacro defmemo (fname &body body) `(progn (defun ,fname , at body) (eval-when (:load-toplevel) (memoize ',fname) (system-add-memoized-fn ',fname)))) (let ((+memoized-fns+ nil)) (defun system-clear-memoized-fns () (mapcar #'(lambda (x) (warn "Clearing memoized ~A" x) (clear-memoize x)) +memoized-fns+)) (defun system-add-memoized-fn (fname) (pushnew fname +memoized-fns+)) (defun system-list-memoized-fns () +memoized-fns+) (defun system-forget-memoized-fns () (setf +memoized-fns+ nil)) ) ;;; Purpose: Diagnostic (From Howard Stearns) that does ;;; (vars a b c) => (FORMAT *TRACE-OUTPUT* "~&a = ~S b = ~S c = ~S ~%" A B C) (defmacro VARS (&rest variables) `(format *trace-output* ,(loop with result = "~&" for var in variables do (setf result (if (and (consp var) (eq (first var) 'quote)) (concatenate 'string result " ~S ") (concatenate 'string result (string-downcase var) " = ~S "))) finally (return (concatenate 'string result "~%"))) , at variables)) ;;; The most essential macro building tool. (defmacro mac (macro) `(pprint (macroexpand-1 ',macro))) ;;; Similar, but used on 'subtype' macros. (defmacro mac2 (macro) `(pprint (macroexpand-1 (macroexpand-1 ',macro)))) ;;; Dirk H.P. Gerrits' "Lisp Code Walker" slides, ALU Meeting, Amsterdam, 2003. ;;; With additional corrections (beyond that in his notes). (defvar *mea-hooks* (make-hash-table :test #'eq)) (defun macroexpand-all (form &optional env) "Macroexpand FORM recursively until none of its subforms can be further expanded." (multiple-value-bind (expansion macrop) (macroexpand-1 form env) (declare (ignore macrop)) (let* ((key (and (consp form) (car form))) (hook (gethash key *mea-hooks*))) (cond (hook (funcall hook form env)) ((and (consp form) (symbolp (car form)) (macro-function (car form))) (macroexpand-all expansion env)) ((consp form) (cons (car form) (mapcar #'(lambda (arg) (macroexpand-all arg env)) (cdr form)))) (t expansion))))) (defun load-ht (ht key-value-pairs) "Load the argument hash table with the argument values provided in a flat list of . " (loop while key-value-pairs do (setf (gethash (pop key-value-pairs) ht) (pop key-value-pairs))) ht) (defmacro when-bind ((var expr) &body body) "Paul Graham ON LISP pg 145. when+let" `(let ((,var ,expr)) (when ,var , at body))) (defmacro if-bind ((var expr) then else) `(let ((,var ,expr)) (if ,var ,then ,else))) (defmacro when-bind* (binds &body body) "Paul Graham ON LISP pg 145. when+let*" (if (null binds) `(progn , at body) `(let (,(car binds)) (if ,(caar binds) (when-bind* ,(cdr binds) , at body))))) (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)) (declaim (inline substring)) (defun substring (str1 str2) "Returns the place in str1 where str2 begins or nil if str2 is not in str1" (search str2 str1 :test #'string=)) (defun remove-extra-spaces (string) "Leave only one space between non-space characters of argument string." (let* ((len (length string)) (new-string (make-array len :element-type 'character :fill-pointer 0))) (vector-push (char string 0) new-string) (loop for i from 1 to (1- len) unless (and (char= #\Space (char string i)) (char= #\Space (char string (1- i)))) do (vector-push (char string i) new-string)) new-string)) (defun break-line-at (string break-bag position) "Return the argument STRING with linefeeds inserted at some position past POSITION where a character in the break-bag is encountered." (let* ((len (length string)) (new-string (make-array (* 2 len) :element-type 'character :fill-pointer 0))) (loop for ix from 0 to (1- (length string)) with count = 0 do (vector-push (char string ix) new-string) (incf count) when (and (> count position) (find (char string ix) break-bag)) do (vector-push #\Linefeed new-string) (setf count 0) finally (return new-string)))) (defun read-string-to-list (string) (loop with val = nil and start = 0 do (multiple-value-setq (val start) (read-from-string string nil :eof :start start)) until (eql val :eof) collect val)) [405 lines skipped] From phildebrandt at common-lisp.net Sun Apr 13 11:02:10 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 07:02:10 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk Message-ID: <20080413110210.0596B14104@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv6444/cells-gtk Added Files: .cvsignore Log Message: added .cvsignore --- /project/cells/cvsroot/cells-gtk3/cells-gtk/.cvsignore 2008/04/13 11:02:10 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/.cvsignore 2008/04/13 11:02:10 1.1 *.fasl From phildebrandt at common-lisp.net Sun Apr 13 11:02:11 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 07:02:11 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk Message-ID: <20080413110211.418D5743EB@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv6444/cells-gtk/test-gtk Added Files: .cvsignore Log Message: added .cvsignore --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/.cvsignore 2008/04/13 11:02:11 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/.cvsignore 2008/04/13 11:02:11 1.1 *.fasl From phildebrandt at common-lisp.net Sun Apr 13 11:03:03 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 07:03:03 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk Message-ID: <20080413110303.F3A5F743EB@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv6852 Removed Files: #cells-gtk.asd# #tree-view.lisp# Log Message: cleanup From phildebrandt at common-lisp.net Sun Apr 13 11:05:49 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 07:05:49 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk Message-ID: <20080413110549.3CA56743EC@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv8313/cells-gtk Modified Files: .cvsignore Removed Files: drawing.lisp Log Message: More cleanup --- /project/cells/cvsroot/cells-gtk3/cells-gtk/.cvsignore 2008/04/13 11:02:10 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/.cvsignore 2008/04/13 11:05:48 1.2 @@ -1,2 +1,5 @@ *.fasl +\#* +~* +*~ From phildebrandt at common-lisp.net Sun Apr 13 11:05:49 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 07:05:49 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk Message-ID: <20080413110549.861B5743EC@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv8313/cells-gtk/test-gtk Removed Files: test-drawing-old.lisp test-drawing2.lisp Log Message: More cleanup From phildebrandt at common-lisp.net Sun Apr 13 11:14:42 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 07:14:42 -0400 (EDT) Subject: [cells-cvs] CVS cells-ode Message-ID: <20080413111442.0E15F14104@common-lisp.net> Update of /project/cells/cvsroot/cells-ode In directory clnet:/tmp/cvs-serv9534 Added Files: cells-ode.lpr Log Message: added lpr --- /project/cells/cvsroot/cells-ode/cells-ode.lpr 2008/04/13 11:14:42 NONE +++ /project/cells/cvsroot/cells-ode/cells-ode.lpr 2008/04/13 11:14:42 1.1 ;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*- (in-package :cg-user) (define-project :name :cells-ode :modules (list (make-instance 'module :name "C:\\1-devtools\\cl-ode\\cl-ode.lisp") (make-instance 'module :name "package.lisp") (make-instance 'module :name "ode-compat.lisp") (make-instance 'module :name "types.lisp") (make-instance 'module :name "core.lisp") (make-instance 'module :name "objects.lisp") (make-instance 'module :name "mass.lisp") (make-instance 'module :name "world.lisp") (make-instance 'module :name "bodies.lisp") (make-instance 'module :name "geoms.lisp") (make-instance 'module :name "joints.lisp") (make-instance 'module :name "utility.lisp") (make-instance 'module :name "primitives.lisp") (make-instance 'module :name "collision.lisp") (make-instance 'module :name "simulate.lisp") (make-instance 'module :name "test-c-ode.lisp")) :projects (list (make-instance 'project-module :name "..\\Cells\\cells") (make-instance 'project-module :name "C:\\1-devtools\\cffi\\cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :common-graphics-user :main-form nil :compilation-unit t :verbose nil :runtime-modules (list :cg-dde-utils :cg.acache :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.chart-or-plot :cg.chart-widget :cg.check-box :cg.choice-list :cg.choose-printer :cg.class-grid :cg.class-slot-grid :cg.class-support :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.object-editor :cg.object-editor.layout :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate :cg.printing :cg.progress-indicator :cg.project-window :cg.property :cg.radio-button :cg.rich-edit :cg.rich-edit-pane :cg.rich-edit-pane.clipboard :cg.rich-edit-pane.printing :cg.sample-file-menu :cg.scaling-stream :cg.scroll-bar :cg.scroll-bar-mixin :cg.scrolling-static-text :cg.selected-object :cg.shortcut-menu :cg.static-text :cg.status-bar :cg.string-dialog :cg.tab-control :cg.template-string :cg.text-edit-pane :cg.text-edit-pane.file-io :cg.text-edit-pane.mark :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray :cg.up-down-control :cg.utility-dialog :cg.web-browser :cg.web-browser.dde :cg.wrap-string :cg.yes-no-list :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags (list :top-level :debugger) :build-flags (list :allow-runtime-debug) :autoload-warning nil :full-recompile-for-runtime-conditionalizations nil :include-manifest-file-for-visual-styles t :default-command-line-arguments "+M +t \"Console for Debugging\"" :additional-build-lisp-image-arguments (list :read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'default-init-function :on-restart 'do-default-restart) ;; End of Project Definition From phildebrandt at common-lisp.net Sun Apr 13 11:34:25 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 07:34:25 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk Message-ID: <20080413113425.604A4743F8@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv13538/cells-gtk Modified Files: gtk-app.lisp Log Message: Fixed start-app. --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/13 11:34:24 1.2 @@ -152,6 +152,8 @@ ;;; Helper functions convering the life cycle of an application ;;; +(defvar *using-thread* 'undecided) + ;;; Initialize GDK ;;; When we have libcellsgtk, we can use a glib function to check whether @@ -235,39 +237,38 @@ (defun main-loop () "Run GTK Main until user signal quit. Errors are caught and displayed in a dialog, providing the user with the option to \"recklessly continue\" -- not to be called directly" (unwind-protect - (loop until - (gtk-main) - - #+off-for-now - (restart-case - (handler-bind - ((gtk-continuable-error #'(lambda (condition) (invoke-restart 'continue-from-error condition ))) - (error #'(lambda (con) (invoke-restart 'report-error con)))) - #-lispworks - (gtk-main) - ;; Despite a workaround for Slime (see FAQ), the gtk-main-iteration-do loop, - ;; still appears to be necessary for LW. Otherwise, LW consumes 99% of CPU. - #+lispworks ; give slime a chance. - (loop - (loop while (gtk-events-pending) do - (gtk-main-iteration-do nil)) - (process-wait-with-timeout .01 "GTK event loop waiting")) - t) - ;; Restart cases - (continue-from-error (c1) - (trc "show message") - (show-message (format nil "Cells-GTK Error: ~a" c1) - :message-type :error :title "Cells-GTK Error") - (trc "showed the message")) - (report-error (c2) - (trc "show error message") - (when (eql (show-message (format nil "Lisp Error: ~a~%~%Recklessly continue?" c2) - :message-type :error - :title "Lisp Error" - :buttons-type :yes-no) - :no) - (trc ">>>> ERROR REPORTING -->" c2) - (error c2))))) + (if (eql *using-thread* 'yes) + (loop until + (restart-case + (handler-bind + ((gtk-continuable-error #'(lambda (condition) (invoke-restart 'continue-from-error condition ))) + (error #'(lambda (con) (invoke-restart 'report-error con)))) + #-lispworks + (gtk-main) + ;; Despite a workaround for Slime (see FAQ), the gtk-main-iteration-do loop, + ;; still appears to be necessary for LW. Otherwise, LW consumes 99% of CPU. + #+lispworks ; give slime a chance. + (loop + (loop while (gtk-events-pending) do + (gtk-main-iteration-do nil)) + (process-wait-with-timeout .01 "GTK event loop waiting")) + t) + ;; Restart cases + (continue-from-error (c1) + (trc "show message") + (show-message (format nil "Cells-GTK Error: ~a" c1) + :message-type :error :title "Cells-GTK Error") + (trc "showed the message")) + (report-error (c2) + (trc "show error message") + (when (eql (show-message (format nil "Lisp Error: ~a~%~%Recklessly continue?" c2) + :message-type :error + :title "Lisp Error" + :buttons-type :yes-no) + :no) + (trc ">>>> ERROR REPORTING -->" c2) + (error c2))))) + (gtk-main)) ;; clean-up forms -- application windows are taken down by gtk-quit-add callbacks (loop for i below (gtk-main-level) @@ -285,11 +286,15 @@ "Start in application within the main thread (only return when application window is closed. To run gtk in a background thread, use start-win instead." (let ((*gtk-debug* debug)) + (case *using-thread* + ('yes (error "Cannot mix start-win and start-app in one lisp session. Use start-win or restart lisp")) + (t (setf *using-thread* 'no))) (with-trcs (init-gtk) (show-win app-name :terminate-on-close t) (when *gtk-debug* (trc nil "STARTING GTK-MAIN") (force-output)) - (main-loop)))) + (main-loop))) + 0) ;;; @@ -340,6 +345,10 @@ (defun start-win (app-class &rest initargs) "Starts app-class with initargs in its own thread. Use :terminate-on-close t to close all other windows once this one is closed." + (case *using-thread* + ('no (error "Cannot mix start-win and start-app in one lisp session. Use start-app or restart lisp")) + (t (setf *using-thread* 'yes))) (start-gtk-main) - (apply #'show-win app-class initargs))) + (apply #'show-win app-class initargs) + 0)) From phildebrandt at common-lisp.net Sun Apr 13 11:34:25 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 07:34:25 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk Message-ID: <20080413113425.AC085743F4@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv13538/cells-gtk/test-gtk Modified Files: test-tree-view.lisp Log Message: Fixed start-app. --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-tree-view.lisp 2008/04/13 10:59:21 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-tree-view.lisp 2008/04/13 11:34:25 1.2 @@ -61,7 +61,7 @@ '(data (upper self test-tree-view))) (defmodel test-tree-view (notebook) - ((data :accessor data :initform (c-in (make-sample-tree "tree" 1))) + ((data :accessor data :initform (c-in (make-sample-tree "tree" 3))) (items :accessor items :initarg :items :initform (c? (and (value (fm-other :hscale)) (loop for i from 1 to (value (fm-other :hscale)) collect From phildebrandt at common-lisp.net Sun Apr 13 11:35:23 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 07:35:23 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/gtk-ffi Message-ID: <20080413113523.DA1F02B066@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/gtk-ffi In directory clnet:/tmp/cvs-serv13785/gtk-ffi Added Files: .cvsignore Log Message: added .cvsignores --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/.cvsignore 2008/04/13 11:35:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/.cvsignore 2008/04/13 11:35:23 1.1 *.fasl \#* ~* *~ From phildebrandt at common-lisp.net Sun Apr 13 11:35:24 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 07:35:24 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/ph-maths Message-ID: <20080413113524.19BF62B062@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/ph-maths In directory clnet:/tmp/cvs-serv13785/ph-maths Added Files: .cvsignore Log Message: added .cvsignores --- /project/cells/cvsroot/cells-gtk3/ph-maths/.cvsignore 2008/04/13 11:35:24 NONE +++ /project/cells/cvsroot/cells-gtk3/ph-maths/.cvsignore 2008/04/13 11:35:24 1.1 *.fasl \#* ~* *~ From phildebrandt at common-lisp.net Sun Apr 13 11:35:24 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 13 Apr 2008 07:35:24 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/pod-utils Message-ID: <20080413113524.4BB382B062@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/pod-utils In directory clnet:/tmp/cvs-serv13785/pod-utils Added Files: .cvsignore Log Message: added .cvsignores --- /project/cells/cvsroot/cells-gtk3/pod-utils/.cvsignore 2008/04/13 11:35:24 NONE +++ /project/cells/cvsroot/cells-gtk3/pod-utils/.cvsignore 2008/04/13 11:35:24 1.1 *.fasl \#* ~* *~ From ktilton at common-lisp.net Sun Apr 13 15:25:00 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 13 Apr 2008 11:25:00 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080413152500.55A093F014@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv8985 Modified Files: md-slot-value.lisp Log Message: minor refinement of *not-to-be* handling --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/13 10:22:03 1.43 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/13 15:25:00 1.44 @@ -77,13 +77,18 @@ (declare (ignorable debug-id ensurer)) (count-it :ensure-value-is-current) ;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer) - + (when *not-to-be* - (return-from ensure-value-is-current (c-value c))) - - (when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c)))) + (when (c-unboundp c) + (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c))) + (return-from ensure-value-is-current + (when (c-validp c) ;; probably accomplishes nothing + (c-value c)))) + + (when (and (not (symbolp (c-model c))) ;; damn, just here because of playing around with global vars and cells + (eq :eternal-rest (md-state (c-model c)))) (break "model ~a of cell ~a is dead" (c-model c) c)) - + (cond ((c-currentp c) (trc nil "EVIC yep: c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete @@ -94,7 +99,7 @@ (not (and (typep c 'c-dependent) (eq (cd-optimize c) :when-value-t) (null (c-value c)))))) - + ((or (not (c-validp c)) ;; ;; new for 2006-09-21: a cell ended up checking slots of a dead instance, which would have been @@ -112,26 +117,26 @@ (when (> (c-pulse-last-changed used)(c-pulse c)) #+slow (trc c "used changed and newer !!!!!!" c :oldpulse (c-pulse used) debug-id used :lastchg (c-pulse-last-changed used)) #+shhh (when (trcp c) - (describe used)) + (describe used)) t)))))) (assert (typep c 'c-dependent)) (check-reversed (cd-useds c)))) #+shhh (trc c "kicking off calc-set of" (c-state c) (c-validp c) (c-slot-name c) :vstate (c-value-state c) :stamped (c-pulse c) :current-pulse *data-pulse-id*) (calculate-and-set c)) - + ((mdead (c-value c)) (trc nil "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c)) (let ((new-v (calculate-and-set c))) (trc nil "ensure-value-is-current> GOT new value ~a to replace dead!!" new-v) new-v)) - + (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id) (c-pulse-update c :valid-uninfluenced))) - + (when (c-unboundp c) (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c))) - + (bwhen (v (c-value c)) (if (mdead v) (progn From phildebrandt at common-lisp.net Mon Apr 14 16:43:47 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Mon, 14 Apr 2008 12:43:47 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk Message-ID: <20080414164347.1FA0A6D369@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv13587/cells-gtk Modified Files: buttons.lisp cairo-drawing-area.lisp cells-gtk.asd drawing-area.lisp gl-drawing-area.lisp gtk-app.lisp packages.lisp widgets.lisp Log Message: Added OpenGL drawing area --- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/13 10:59:16 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/14 16:43:41 1.2 @@ -81,7 +81,7 @@ (def-widget radio-button (check-button) () () () - :new-tail (c? (and (upper self box) + :new-tail (c_1 (and (upper self box) (not (eql (first (kids (fm-parent self))) self)) '-from-widget)) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/13 10:59:16 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/14 16:43:41 1.2 @@ -216,19 +216,6 @@ (deb "done.")) -;;;; ----------------------------------------------------------- -;;;; redraw method (called to trigger a refresh) -;;;; ----------------------------------------------------------- - -;;; a handler if redraw called on nil -(defmethod redraw (self)) - -(defmethod redraw ((self cairo-drawing-area)) - "Queues a redraw with GTK. This is called whenever a primitve is modified" - (trc nil "queue redraw" self) - (gtk-ffi:gtk-widget-queue-draw (widget-id self))) - - (defobserver prims ((self cairo-drawing-area)) (redraw self)) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/13 10:59:16 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/14 16:43:42 1.2 @@ -17,7 +17,7 @@ (pushnew :cells-gtk-cairo *features*) ;;; drawing-area widget using OpenGL (requires libgtkglext1) -;(pushnew :cells-gtk-opengl *features*) +(pushnew :cells-gtk-opengl *features*) (asdf:defsystem :cells-gtk :name "cells-gtk" @@ -27,7 +27,10 @@ :gtk-ffi :ph-maths #+cells-gtk-cairo :cl-cairo2 - #+cells-gtk-threads :bordeaux-threads) + #+cells-gtk-threads :bordeaux-threads + #+cells-gtk-opengl :cl-opengl + #+cells-gtk-opengl :cl-glu + #+cells-gtk-opengl :cl-glut) :serial t :components ((:file "packages") --- /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/14 16:43:42 1.2 @@ -123,10 +123,26 @@ (declare (ignore rest)) (let ((widget (id self))) (trc "registering handlers for" widget) - (gtk-widget-add-events widget 772) ; 512 + 256 + 4 button_press, release, motion - (gtk-signal-connect-swap widget "button-press-event" (cffi:get-callback 'drawing-button-handler) :data widget) - (gtk-signal-connect-swap widget "button-release-event" (cffi:get-callback 'drawing-button-handler) :data widget) - (gtk-signal-connect-swap widget "motion-notify-event" (cffi:get-callback 'drawing-pointer-motion-handler) :data widget) - (gtk-signal-connect-swap widget "expose-event" (cffi:get-callback 'drawing-expose-handler) :data widget))) + (gtk-widget-add-events widget 772) ; 512 + 256 + 4 button_press, release, motion + (gtk-signal-connect-swap widget "button-press-event" (cffi:get-callback 'drawing-button-handler) :data widget) + (gtk-signal-connect-swap widget "button-release-event" (cffi:get-callback 'drawing-button-handler) :data widget) + (gtk-signal-connect-swap widget "motion-notify-event" (cffi:get-callback 'drawing-pointer-motion-handler) :data widget) + (gtk-signal-connect-swap widget "expose-event" (cffi:get-callback 'drawing-expose-handler) :data widget))) + + +;;; +;;; redraw method (called to trigger a refresh) +;;; + +;;; a handler if redraw called on nil +(export! redraw) + +(defmethod redraw (self)) + +(defmethod redraw ((self drawing-area)) + "Queues a redraw with GTK." + (trc nil "queue redraw" self) + (gtk-widget-queue-draw (id self))) + --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/14 16:43:42 1.2 @@ -2,9 +2,112 @@ (in-package :cgtk) +(defvar *gl-config* nil) + ;;; ;;; gl drawing area ;;; +;;; +;;; OpenGL interaction +;;; + +(defun get-gl-config () + (let ((cfg (gdk-gl-config-new-by-mode '(:gdk-gl-mode-rgba :gdk-gl-mode-depth :gdk-gl-mode-double)))) + (if (cffi-sys:null-pointer-p cfg) + (let ((cfg (gdk-gl-config-new-by-mode '(:gdk-gl-mode-rgba :gdk-gl-mode-depth :gdk-gl-mode-double)))) + (warn "No double buffered visual found. Trying single-buffered.") + (if (cffi-sys:null-pointer-p cfg) + (error "No OpenGL capable visual found.") + cfg)) + cfg))) + +(defun gl-init () + (gtk-gl-init +c-null+ +c-null+) + (setf *gl-config* (get-gl-config))) + + +(defmacro with-gl-context ((widget &key (swap-buffers-p t)) &rest body) + (with-gensyms (drawable context swap-p w wid) + `(let ((,swap-p ,swap-buffers-p) + (,w ,widget)) + (let ((,wid (id ,w))) + (let ((,context (gtk-widget-get-gl-context ,wid)) + (,drawable (gtk-widget-get-gl-window ,wid))) + (if (gdk-gl-drawable-gl-begin ,drawable ,context) + (progn + , at body + (when ,swap-p + (when (gdk-gl-drawable-is-double-buffered ,drawable) + (trc "swapping buffers") + (gdk-gl-drawable-swap-buffers ,drawable))) + (gdk-gl-drawable-gl-end ,drawable)) + (trc "gl-begin failed" ,w ,drawable ,context))))))) + +;;; +;;; Event handling +;;; + +(defun %gl-draw (self) + (bwhen (draw-fn (draw self)) + (with-gl-context (self) + (funcall draw-fn self)))) + +(cffi:defcallback realize-handler :void ((widget :pointer) (data :pointer)) + (declare (ignore data)) + (let ((self (gtk-object-find widget))) + (trc "gl realize" self widget (id self)) + (bwhen (init-fn (init self)) + (with-gl-context (self) + (funcall init-fn self))) + (trc "done gl realize" self))) + + +(defun %resize (self) + (let ((width (allocated-width self)) + (height (allocated-height self))) + (when (and (plusp width) (plusp height)) + (trc "%resize to" width height) + (with-gl-context (self) + (gl:viewport 0 0 width height) + (bwhen (resize-fn (resize self)) + (funcall resize-fn self)))))) + +;;; +;;; Widget +;;; + (defmodel gl-drawing-area (drawing-area) - ()) \ No newline at end of file + ((draw :accessor draw :initarg :draw :cell nil :initform nil) + (init :accessor init :initarg :init :cell nil :initform nil) + (resize :accessor resize :initarg :resize :cell nil :initform nil)) + (:default-initargs + :on-draw #'%gl-draw)) + +(defmethod initialize-instance :after ((self gl-drawing-area) &rest initargs) + (declare (ignore initargs)) + (trc "registering handlers for" self) + (gtk-signal-connect-swap (id self) "realize" (cffi:get-callback 'realize-handler) :data (id self)) + (trc "set gl capability" self) + (gtk-widget-set-gl-capability (id self) *gl-config* +c-null+ t :gdk-gl-rgba-type)) + +(defobserver allocated-width ((self gl-drawing-area)) + (%resize self)) + +(defobserver allocated-height ((self gl-drawing-area)) + (%resize self)) + + +;;; +;;; supporting macros +;;; + +(export! with-matrix-mode) + +(defmacro with-matrix-mode ((mode) &body body) + `(progn + (gl:matrix-mode ,mode) + (gl:load-identity) + , at body + (gl:matrix-mode :modelview) + (gl:load-identity))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/13 11:34:24 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/14 16:43:42 1.3 @@ -127,28 +127,6 @@ (with-trc (gtk-quit-remove (slot-value self 'cb-quit-id)))) ;;; -;;; callback table -;;; - -(defvar *gtk-global-callbacks* nil) - -(defun gtk-reset () - (cells-reset) - (gtk-objects-init) - (setf *gtk-global-callbacks* - (make-array 128 :adjustable t :fill-pointer 0))) - -(defun gtk-global-callback-register (callback) - (vector-push-extend callback *gtk-global-callbacks* 16)) - -(defun gtk-global-callback-funcall (n) - (trc nil "gtk-global-callback-funcall >" n - *gtk-global-callbacks* - (when n (aref *gtk-global-callbacks* n))) - (funcall (aref *gtk-global-callbacks* n))) - - -;;; ;;; Helper functions convering the life cycle of an application ;;; @@ -184,6 +162,7 @@ (gdk-threads-init) (assert (gtk-init-check +c-null+ +c-null+)) (gtk-init +c-null+ +c-null+) + #+cells-gtk-opengl (gl-init) (gtk-reset) #-libcellsgtk (setf threading-initialized t))))) @@ -349,6 +328,5 @@ ('no (error "Cannot mix start-win and start-app in one lisp session. Use start-app or restart lisp")) (t (setf *using-thread* 'yes))) (start-gtk-main) - (apply #'show-win app-class initargs) - 0)) + (apply #'show-win app-class initargs))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/packages.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/packages.lisp 2008/04/14 16:43:42 1.2 @@ -44,11 +44,15 @@ #:cells-tree-node #:cells-tree-store #:cells-gtk-init + #:title #:icon #:tooltips #:tooltips-enable #:tooltips-delay + #:allocated-width + #:allocated-height + #:start-app #:start-win #:stop-gtk-main @@ -142,4 +146,9 @@ #:on-dragged ; (on-dragged [widget] [button] [primitive] [start-pos] [end-pos]) #:hover ; the primitive the mouse is currently over #:dragging ; the primitive currently being dragged + + #:gl-drawing-area + #:with-gl-context + #:init + #:draw )) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/14 16:43:44 1.2 @@ -24,9 +24,9 @@ (def-gtk-class-name :accessor def-gtk-class-name :initarg :def-gtk-class-name :initform nil) (new-function-name :accessor new-function-name :initarg :new-function-name :initform (c_1 (intern (format nil "GTK-~a-NEW~a" - (def-gtk-class-name self) - (or (new-tail self) "")) - :gtk-ffi))) + (def-gtk-class-name self) + (or (new-tail self) "")) + :gtk-ffi))) (new-args :accessor new-args :initarg :new-args :initform nil) (new-tail :accessor new-tail :initarg :new-tail :initform nil) (id :initarg :id :accessor id @@ -36,6 +36,7 @@ (let ((id (apply (symbol-function (new-function-name self)) (new-args self)))) (gtk-object-store id self) + (gtk-signal-connect-swap id "configure-event" (cffi:get-callback 'reshape-widget-handler) :data id) id)))) (callbacks :cell nil :accessor callbacks @@ -47,14 +48,19 @@ ;; --------- provide id-to-clos lookup ------ -(defvar *gtk-objects* nil) +;;; +;;; gtk object registry +;;; +(defvar *gtk-objects* nil) (defvar *widgets* nil) (defun gtk-objects-init () (setf *gtk-objects* (make-hash-table :size 100 :rehash-size 100) *widgets* (make-hash-table :test #'equal))) +;;; id lookup + (defun gtk-object-store (gtk-id gtk-object &aux (hash-id (cffi:pointer-address gtk-id))) (unless *gtk-objects* (gtk-objects-init)) @@ -88,10 +94,11 @@ (gtk-report-error gtk-object-id-error "gtk.object.find ID not found ~a" hash-id)) clos-widget))) +;;; name lookup + (defun find-widget (name &optional default) (gethash name *widgets* default)) - (defmacro with-widget ((widget name &optional alternative) &body body) `(bif (,widget (find-widget ,name)) (progn , at body) @@ -104,12 +111,13 @@ (progn , at body) ,alternative)))) -(defun widget-value (name default &key (accessor 'value)) +(defun widget-value (name &optional default (accessor 'value)) (with-widget-value (val name :accessor accessor :alternative default) val)) - - +;;; +;;; callbacks +;;; ;; ----- fake callbackable closures ------------ @@ -121,8 +129,6 @@ (defun callback-recover (self callback-key) (cdr (assoc callback-key (callbacks self)))) -; ------------------------------------------ - ;;; ;;; callback table ;;; @@ -145,7 +151,6 @@ (funcall (aref *gtk-global-callbacks* n))) - (defmethod configure ((self gtk-object) gtk-function value) (apply gtk-function (id self) @@ -321,15 +326,36 @@ (x-pad :accessor x-pad :initarg :x-pad :initform (c? (padding? self))) (y-pad :accessor y-pad :initarg :y-pad :initform (c? (padding? self))) (width :accessor width :initarg :width :initform nil) - (height :accessor height :initarg :height :initform nil)) + (height :accessor height :initarg :height :initform nil) + (allocated-width :accessor allocated-width :initform (c-in 0)) + (allocated-height :accessor allocated-height :initform (c-in 0)) + ) () (focus show hide delete-event destroy-event) ;; this is called unless the user overwrites this routine :on-delete-event (c-in #'(lambda (self widget event data) (declare (ignore widget event data)) + (trc "on-delete") (gtk-object-forget (id self) self) 0))) +#+libcellsgtk +(cffi:defcallback reshape-widget-handler :int ((widget :pointer) (event :pointer) (data :pointer)) + (declare (ignore data event)) + (bwhen (self (gtk-object-find widget)) + (let ((new-width (gtk-adds-widget-width widget)) + (new-height (gtk-adds-widget-height widget))) + (trc "reshape widget to new size" self widget new-width new-height) + (with-integrity (:change :adjust-widget-size) + (setf (allocated-width self) new-width + (allocated-height self) new-height)))) + 0) + +(defmethod initialize-instance :after ((self widget) &rest initargs) + (declare (ignore initargs)) + #+libcellsgtk- + ) + (defmethod focus ((self widget)) (gtk-widget-grab-focus (id self))) From phildebrandt at common-lisp.net Mon Apr 14 16:43:55 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Mon, 14 Apr 2008 12:43:55 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk Message-ID: <20080414164355.184B46D36B@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv13587/cells-gtk/test-gtk Modified Files: test-buttons.lisp test-display.lisp test-drawing.lisp test-gtk.asd test-gtk.lisp test-tree-view.lisp Log Message: Added OpenGL drawing area --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/13 10:59:20 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/14 16:43:48 1.2 @@ -5,13 +5,13 @@ (:default-initargs :kids (c? (the-kids (mk-label :text (c? (format nil "Toggled button active = ~a" - (value (fm-other :toggled-button))))) + (widget-value :toggled-button)))) (mk-hseparator) (mk-label :text (c? (format nil "Check button checked = ~a" - (value (fm-other :check-button))))) + (widget-value :check-button)))) (mk-hseparator) (mk-label :text (c? (format nil "Radio button selected = ~a" - (value (fm-other :radio-group))))) + (widget-value :radio-group)))) (mk-hseparator) (mk-label :text (c? (format nil "Button clicked ~a times" (nclics (upper self test-buttons)))) @@ -39,10 +39,10 @@ "_Check Button"))))) (mk-hbox :md-name :radio-group - :kids (c? (the-kids - (mk-radio-button :md-name :radio-1 - :label "Radio 1") - (mk-radio-button :md-name :radio-2 - :label "Radio 2" :init t) - (mk-radio-button :md-name :radio-3 - :label "Radio 3")))))))) + :kids (kids-list? + (mk-radio-button :md-name :radio-1 + :label "Radio 1") + (mk-radio-button :md-name :radio-2 + :label "Radio 2" :init t) + (mk-radio-button :md-name :radio-3 + :label "Radio 3"))))))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-display.lisp 2008/04/13 10:59:20 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-display.lisp 2008/04/14 16:43:48 1.2 @@ -4,11 +4,13 @@ (defmodel test-display (vbox) () (:default-initargs ;; g_timeout_add a function that will move the bar until the "Pulse" toggle is false. - :value (c? (when (value (fm-other :pulse)) - (timeout-add (value (fm-other :timeout)) - (lambda () - (pulse (fm-other :pbar2)) - (value (fm-other :pulse)))))) + :value (c? (with-widget-value (val :pulse) + (with-widget-value (timeout :timeout) + (timeout-add timeout + (lambda () + (with-widget (pbar :pbar2) + (pulse pbar)) + (widget-value :pulse)))))) :expand t :fill t :kids (kids-list? (mk-hbox @@ -25,7 +27,7 @@ (mk-hbox :kids (kids-list? (mk-progress-bar :md-name :pbar - :fraction (c? (value (fm^ :fraction-value)))) + :fraction (c? (widget-value :fraction-value 1))) (mk-hscale :md-name :fraction-value :value-type 'single-float :min 0 :max 1 @@ -34,17 +36,17 @@ (mk-button :label "Show in status bar" :on-clicked (callback (widget event data) - (push-message (fm-other :statusbar) - (format nil "~a" (fraction (fm-other :pbar)))))))) + (with-widget (w :statusbar) + (push-message w (format nil "~a" (fraction (fm-other :pbar))))))))) (mk-hbox :kids (kids-list? (mk-progress-bar :md-name :pbar2 - :pulse-step (c? (value (fm^ :step))) + :pulse-step (c? (widget-value :step .1)) :fraction (c-in .1)) (mk-toggle-button :md-name :pulse :label "Pulse") (mk-label :text "Interval") (mk-spin-button :md-name :timeout - :sensitive (c? (not (value (fm^ :pulse)))) + :sensitive (c? (not (widget-value :pulse))) :min 10 :max 1000 :init 100) (mk-label :text "Pulse step") @@ -53,7 +55,7 @@ :min 0.01 :max 1 :step 0.01 :init 0.1) (mk-image :md-name :pulse-image - :stock (c? (if (value (fm^ :pulse)) :yes :no))))) + :stock (c? (if (widget-value :pulse) :yes :no))))) (mk-alignment :expand t :fill t :xalign 0 :yalign 1 --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp 2008/04/13 10:59:20 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp 2008/04/14 16:43:48 1.2 @@ -164,7 +164,63 @@ :kids (kids-list? (make-instance 'test-cairo-drawing :fm-parent *parent*)))) +;;; +;;; GL drawing +;;; + (defparameter *da* nil) +(defmodel teapot (gl-drawing-area) + () + (:default-initargs + :width (c-in 200) :height (c-in 200) :expand t :fill t + :init #'(lambda (self) + (declare (ignorable self)) + (gl:clear-color 0 0 0 0) + (gl:cull-face :back) + (gl:depth-func :less) + (gl:disable :dither) + (gl:shade-model :smooth) + (gl:light-model :light-model-local-viewer 1) + (gl:color-material :front :ambient-and-diffuse) + (gl:enable :light0 :lighting :cull-face :depth-test)) + :resize #'(lambda (self) + (with-matrix-mode (:projection) + (glu:perspective 50 (/ (allocated-width self) (allocated-height self)) 0.5 20))) + :draw #'(lambda (self) + (declare (ignore self)) + (gl:load-identity) + (gl:translate 0 0 -5) + (gl:rotate 30 1 1 0) + (gl:light :light0 :position '(0 1 1 0)) + (gl:light :light0 :diffuse '(0.2 0.4 0.6 0)) + (gl:clear :color-buffer-bit :depth-buffer-bit) + (gl:color 1 1 1) + (gl:front-face :cw) + (trc "drawing teapot with size" (/ (with-widget (w :teapot-size 130) + (trc "found widget teapot-size" w (value w)) + (value w)) 100)) + (glut:solid-teapot (/ (widget-value :teapot-size 130) 100)) + (gl:front-face :ccw) + (gl:flush)))) + +(defmodel test-gl-drawing (gtk-app) + () + (:default-initargs + :kids (kids-list? + (make-kid 'hbox + :kids (kids-list? + (make-kid 'vbox + :kids (kids-list? + (mk-spin-button :md-name :teapot-size + :min 1 :max 200 :step 1 :init 130 + :on-value-changed (callback (w e d) + (with-widget (teapot :teapot) + (trc "redrawing teapot") + (redraw teapot)))))) + (make-kid 'teapot :md-name :teapot)))))) + + (defun test-drawing () - (setf *da* (first (kids (first (kids (start-win 'test-cairo-drawing))))))) + ; (setf *da* (first (kids (first (kids (start-app 'test-gl-drawing)))))) + (start-app 'test-gl-drawing)) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.asd 2008/04/13 10:59:20 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.asd 2008/04/14 16:43:48 1.2 @@ -1,6 +1,21 @@ + + +;;; run gtk in its own thread (requires bordeaux-threads) +(pushnew :cells-gtk-threads *features*) + +;;; drawing-area widget using cairo (requires cl-cairo2) +(pushnew :cells-gtk-cairo *features*) + +;;; drawing-area widget using OpenGL (requires libgtkglext1) +(pushnew :cells-gtk-opengl *features*) + + (asdf:defsystem :test-gtk :name "test-gtk" - :depends-on (:cells-gtk) + :depends-on (:cells-gtk + #+cells-gtk-opengl :cl-opengl + #+cells-gtk-opengl :cl-glu + #+cells-gtk-opengl :cl-glut) :serial t :components ((:file "test-gtk") @@ -12,6 +27,6 @@ (:file "test-menus") (:file "test-dialogs") (:file "test-textview") - (:file "test-drawing") + #+(or cells-gtk-opengl cells-gtk-cairo) (:file "test-drawing") (:file "test-addon") )) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lisp 2008/04/13 10:59:21 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lisp 2008/04/14 16:43:48 1.2 @@ -48,7 +48,7 @@ "Addon" "Entry" "Tree-view" - "Drawing"))) + #+(or cells-gtk-cairo cells-gtk-opengl) "Drawing"))) (list (mk-notebook :tab-labels tabs :kids (c? (the-kids --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-tree-view.lisp 2008/04/13 11:34:25 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-tree-view.lisp 2008/04/14 16:43:48 1.3 @@ -63,16 +63,16 @@ (defmodel test-tree-view (notebook) ((data :accessor data :initform (c-in (make-sample-tree "tree" 3))) (items :accessor items :initarg :items - :initform (c? (and (value (fm-other :hscale)) - (loop for i from 1 to (value (fm-other :hscale)) collect - (make-be 'listbox-test-item - :string (format nil "Item ~d" i) - :icon (nth (random 5) (list "home" "open" "save" "ok" "cancel")) - :int i - :float (coerce (* (+ i 1) (/ 1 (1+ (random 100)))) 'single-float) - :double (coerce (* (+ i 2) (/ 1 (1+ (random 1000)))) 'double-float) - :boolean (oddp i) - :date (- (get-universal-time) (random 10000000)))))))) + :initform (c? (with-widget-value (hscale :hscale) + (loop for i from 1 to hscale collect + (make-be 'listbox-test-item + :string (format nil "Item ~d" i) + :icon (nth (random 5) (list "home" "open" "save" "ok" "cancel")) + :int i + :float (coerce (* (+ i 1) (/ 1 (1+ (random 100)))) 'single-float) + :double (coerce (* (+ i 2) (/ 1 (1+ (random 1000)))) 'double-float) + :boolean (oddp i) + :date (- (get-universal-time) (random 10000000)))))))) (:default-initargs :tab-labels (list "Listbox" "Treebox" "Cells-Tree-View") :kids (kids-list? @@ -84,7 +84,7 @@ (mk-listbox :columns (def-columns (:string (:title "Selection"))) - :items (c? (let ((sel (value (fm-other :listbox)))) + :items (c? (with-widget-value (sel :listbox) (if (listp sel) sel (list sel)))) :print-fn (lambda (item) (list (format nil "~a" item)))))) @@ -142,7 +142,7 @@ :kids (kids-list? (mk-listbox :md-name :listbox - :selection-mode (c? (value (fm-other :selection-mode))) + :selection-mode (c? (widget-value :selection-mode)) :columns (def-columns (:string (:title "String") #'(lambda (val) @@ -160,7 +160,7 @@ '(:foreground "navy" :strikethrough t)))) (:boolean (:title "Boolean")) (:date (:title "Date"))) - :select-if (c? (value (fm^ :selection-predicate))) + :select-if (c? (widget-value :selection-predicate)) :items (c? (items (upper self test-tree-view))) :print-fn (lambda (item) (list (string$ item) (icon$ item) (int$ item) (float$ item) @@ -172,7 +172,7 @@ :kids (kids-list? (mk-listbox :columns (def-columns (:string (:title "Selection"))) - :items (c? (let ((sel (value (fm-other :treebox)))) + :items (c? (with-widget-value (sel :treebox) (mapcar #'(lambda (item) (list (format nil "~a" (class-name (class-of item))))) (if (listp sel) sel (list sel)))))))) @@ -209,8 +209,8 @@ :kids (kids-list? (mk-treebox :md-name :treebox - :selection-mode (c? (value (fm^ :tree-selection-mode))) - :select-if (c? (value (fm^ :tree-selection-predicate))) + :selection-mode (c? (widget-value :tree-selection-mode)) + :select-if (c? (widget-value :tree-selection-predicate)) :columns (def-columns (:string (:title "Widget class") #'(lambda (val) From phildebrandt at common-lisp.net Mon Apr 14 16:44:03 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Mon, 14 Apr 2008 12:44:03 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/gtk-ffi Message-ID: <20080414164403.4949231033@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/gtk-ffi In directory clnet:/tmp/cvs-serv13587/gtk-ffi Modified Files: gtk-adds.c gtk-ffi.asd gtk-gl-ext.lisp gtk-other.lisp gtk-utilities.lisp libcellsgtk.so package.lisp Log Message: Added OpenGL drawing area --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-adds.c 2008/04/13 10:59:23 1.1 +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-adds.c 2008/04/14 16:43:55 1.2 @@ -14,7 +14,8 @@ asm (".ascii \" -export:gtk_adds_color_set_rgb\""); asm (".ascii \" -export:gtk_adds_ok\""); asm (".ascii \" -export:gtk_adds_g_thread_supported\""); - +asm (".ascii \" -export:gtk_adds_widget_height\""); +asm (".ascii \" -export:gtk_adds_widget_width\""); /* Return a pointer to the vbox of a dialog. * Useful for adding widgets to dialogs. For example, * if you need a dialog with text entry capability. @@ -101,3 +102,16 @@ return g_thread_supported (); } +/* This is to return the new allocated height/width after the user reshapes a widget */ +int +gtk_adds_widget_height (GtkWidget *wid) +{ + return wid->allocation.height; +} + +int +gtk_adds_widget_width (GtkWidget *wid) +{ + return wid->allocation.width; +} + --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.asd 2008/04/13 10:59:23 1.1 +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.asd 2008/04/14 16:43:55 1.2 @@ -17,6 +17,7 @@ :pod-utils :cffi :cffi-uffi-compat + :utils-kt #+cells-gtk-threads :bordeaux-threads ) :components --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-gl-ext.lisp 2008/04/13 10:59:23 1.1 +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-gl-ext.lisp 2008/04/14 16:43:55 1.2 @@ -15,7 +15,7 @@ (in-package :gtk-ffi) -(export '(with-gl-drawable with-swap-buffers)) +;(export '(with-gl-drawable with-swap-buffers)) (cffi:define-foreign-library libgtkglext (:unix "libgtkglext-x11-1.0.so") @@ -104,4 +104,6 @@ (progn , at body) (if (gdk-gl-drawable-is-double-buffered ,drawable) (gdk-gl-drawable-swap-buffers ,drawable)) - (gdk-gl-drawable-gl-end ,drawable)))) \ No newline at end of file + (gdk-gl-drawable-gl-end ,drawable)))) + + --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-other.lisp 2008/04/13 10:59:23 1.1 +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-other.lisp 2008/04/14 16:43:55 1.2 @@ -892,7 +892,9 @@ (green :unsigned-int) (blue :unsigned-int))) (gtk-adds-ok :int ()) - (gtk-adds-g-thread-supported :int ())) + (gtk-adds-g-thread-supported :int ()) + (gtk-adds-widget-width :int ((widget :pointer))) + (gtk-adds-widget-height :int ((widget :pointer)))) #-libcellsgtk --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-utilities.lisp 2008/04/13 10:59:23 1.1 +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-utilities.lisp 2008/04/14 16:43:55 1.2 @@ -43,7 +43,6 @@ (defun wrap-func (func-address) ;; vestigial. func would never be nil. i think. (or func-address 0)) - (defun gtk-signal-connect-swap (widget signal fun &key (after t) (data +c-null+) (destroy-data +c-null+)) ; pod 0216 (g-signal-connect-closure widget signal (g-cclosure-new-swap (wrap-func fun) data destroy-data) after)) Binary files /project/cells/cvsroot/cells-gtk3/gtk-ffi/libcellsgtk.so 2008/04/13 10:59:23 1.1 and /project/cells/cvsroot/cells-gtk3/gtk-ffi/libcellsgtk.so 2008/04/14 16:43:55 1.2 differ --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/package.lisp 2008/04/13 10:59:23 1.1 +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/package.lisp 2008/04/14 16:43:55 1.2 @@ -77,5 +77,6 @@ #:gdk-event-button-state #:gdk-event-motion-x #:gdk-event-motion-y - #:event-type)) + #:event-type + #:gl-init)) From phildebrandt at common-lisp.net Wed Apr 16 14:41:29 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Wed, 16 Apr 2008 10:41:29 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk Message-ID: <20080416144129.0C02F14160@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv26095/cells-gtk Modified Files: buttons.lisp gtk-app.lisp tree-view.lisp widgets.lisp Log Message: Testing with-widget. --- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/14 16:43:41 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/16 14:41:28 1.3 @@ -54,12 +54,16 @@ (toggled) :active (c-in nil) :on-toggled (callback (widget event data) - ;;(print (list :toggle-button :on-toggled-cb widget)) + (trc "toggle-button toggled" widget) (with-integrity (:change 'tggle-button-on-toggled-cb) (let ((state (gtk-toggle-button-get-active widget))) - ;;(print (list :toggledstate state)) (setf (value self) state))))) +(defobserver .value ((self toggle-button)) + (trc "observing toggle-button .value" self (value self)) + (with-integrity (:change 'toggle-button-value) + (trc "with integrity"))) + #+test (DEF-GTK WIDGET TOGGLE-BUTTON (BUTTON) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL)) (MODE ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/14 16:43:42 1.3 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/16 14:41:28 1.4 @@ -111,7 +111,8 @@ (cffi:defcallback cb-quit :unsigned-int ((data :pointer)) - (when-bind (self (with-trc (gtk-object-find data))) + (trc "cb quit" data (gtk-object-find data)) + (bwhen (self (gtk-object-find data)) (setf *system* (delete self *system*)) (not-to-be self)) 0) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/16 14:41:28 1.2 @@ -53,6 +53,7 @@ (when (fourth col-def) (list pos (fourth col-def)))))) (columns :accessor columns + :owning t :initform (c? (mapcar #'(lambda (col-init) (apply #'make-be 'tree-view-column :container self @@ -478,7 +479,7 @@ (progn #+msg(print (list "CALCULATE KIDS for family observer" self "on" (^value) "-- parent" (upper self))) (bwhen (val (^value)) ;; not sure why not (unless (deadp val) - (trcx "creating kids" val (slot-value val 'cells::.md-state) (kids val)) + (trcx nil "creating kids" val (slot-value val 'cells::.md-state) (kids val)) (mapcar #'(lambda (src) (mk-observer self src)) (kids val)))))))) ;;; here do cleanup work, children get called before parents --- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/14 16:43:44 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/16 14:41:28 1.3 @@ -36,7 +36,7 @@ (let ((id (apply (symbol-function (new-function-name self)) (new-args self)))) (gtk-object-store id self) - (gtk-signal-connect-swap id "configure-event" (cffi:get-callback 'reshape-widget-handler) :data id) + #+libcellsgtk (gtk-signal-connect-swap id "configure-event" (cffi:get-callback 'reshape-widget-handler) :data id) id)))) (callbacks :cell nil :accessor callbacks @@ -75,13 +75,16 @@ (defun gtk-object-forget (gtk-id gtk-object) - (remhash (md-name gtk-object) *widgets*) - (when gtk-id - (assert *gtk-objects*) - (remhash (cffi:pointer-address gtk-id) *gtk-objects*) - (mapc (lambda (k) - (gtk-object-forget (slot-value k 'id) k)) - (slot-value gtk-object '.kids)))) + (when (and gtk-id gtk-object) + (trc nil " forgetting id/obj" gtk-id gtk-object) + (let ((ptr (cffi:pointer-address gtk-id))) + (assert *widgets*) + (when (eql (gethash (md-name gtk-object) *widgets*) gtk-object) + (remhash (md-name gtk-object) *widgets*)) + (assert *gtk-objects*) + (remhash ptr *gtk-objects*) + (mapc (lambda (k) (gtk-object-forget (slot-value k 'id) k)) + (slot-value gtk-object '.kids))))) (defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (cffi:pointer-address gtk-id))) (when *gtk-objects* @@ -101,7 +104,9 @@ (defmacro with-widget ((widget name &optional alternative) &body body) `(bif (,widget (find-widget ,name)) - (progn , at body) + (progn + (trc "with widget" ,widget ',body) + , at body) ,alternative)) (defmacro with-widget-value ((val name &key (accessor '(quote value)) (alternative nil)) &body body) @@ -333,15 +338,12 @@ () (focus show hide delete-event destroy-event) ;; this is called unless the user overwrites this routine - :on-delete-event (c-in #'(lambda (self widget event data) - (declare (ignore widget event data)) - (trc "on-delete") - (gtk-object-forget (id self) self) - 0))) + ) #+libcellsgtk (cffi:defcallback reshape-widget-handler :int ((widget :pointer) (event :pointer) (data :pointer)) (declare (ignore data event)) + (trc "reshape" widget) (bwhen (self (gtk-object-find widget)) (let ((new-width (gtk-adds-widget-width widget)) (new-height (gtk-adds-widget-height widget))) @@ -351,10 +353,6 @@ (allocated-height self) new-height)))) 0) -(defmethod initialize-instance :after ((self widget) &rest initargs) - (declare (ignore initargs)) - #+libcellsgtk- - ) (defmethod focus ((self widget)) (gtk-widget-grab-focus (id self))) @@ -389,7 +387,9 @@ (trc "WIDGET DESTROY" (md-name self) (type-of self) self) (force-output)) (gtk-object-forget (slot-value self 'id) self) - (gtk-widget-destroy (slot-value self 'id))) + (trc nil "not-to-be destroys" self (slot-value self 'id)) + (gtk-widget-destroy (slot-value self 'id)) + (trc nil " done")) (defun assert-bin (container) (assert (null (rest (kids container))) From phildebrandt at common-lisp.net Wed Apr 16 14:41:30 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Wed, 16 Apr 2008 10:41:30 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk Message-ID: <20080416144130.667003001A@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv26095/cells-gtk/test-gtk Modified Files: test-buttons.lisp test-display.lisp Log Message: Testing with-widget. --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/14 16:43:48 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/16 14:41:30 1.3 @@ -5,13 +5,16 @@ (:default-initargs :kids (c? (the-kids (mk-label :text (c? (format nil "Toggled button active = ~a" - (widget-value :toggled-button)))) + (with-widget (w :toggled-button) + (trc "calculating toggled button" w (value w)) + (value w))))) (mk-hseparator) (mk-label :text (c? (format nil "Check button checked = ~a" (widget-value :check-button)))) (mk-hseparator) (mk-label :text (c? (format nil "Radio button selected = ~a" - (widget-value :radio-group)))) + (with-widget (w :radio-group) + (value w))))) (mk-hseparator) (mk-label :text (c? (format nil "Button clicked ~a times" (nclics (upper self test-buttons)))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-display.lisp 2008/04/14 16:43:48 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-display.lisp 2008/04/16 14:41:30 1.3 @@ -6,56 +6,57 @@ (:default-initargs ;; g_timeout_add a function that will move the bar until the "Pulse" toggle is false. :value (c? (with-widget-value (val :pulse) (with-widget-value (timeout :timeout) - (timeout-add timeout - (lambda () - (with-widget (pbar :pbar2) - (pulse pbar)) - (widget-value :pulse)))))) + (trc "ADDING TIMEOUT") + (timeout-add timeout + (lambda () + (with-widget (pbar :pbar2) + (pulse pbar)) + (widget-value :pulse)))))) :expand t :fill t :kids (kids-list? (mk-hbox :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar :button :dnd :dialog) - collect (mk-image :stock :harddisk :icon-size icon-size) - collect (mk-image :stock :my-g :icon-size icon-size))) + collect (mk-image :stock :harddisk :icon-size icon-size) + collect (mk-image :stock :my-g :icon-size icon-size))) (mk-hseparator) (mk-aspect-frame :ratio 1 :kids (kids-list? (mk-image :width 200 :height 250 - :filename (namestring *tst-image*)))) + :filename (namestring *tst-image*)))) (mk-hseparator) (mk-hbox :kids (kids-list? (mk-progress-bar :md-name :pbar - :fraction (c? (widget-value :fraction-value 1))) + :fraction (c? (widget-value :fraction-value 1))) (mk-hscale :md-name :fraction-value - :value-type 'single-float - :min 0 :max 1 - :step 0.01 - :init 0.5) + :value-type 'single-float + :min 0 :max 1 + :step 0.01 + :init 0.5) (mk-button :label "Show in status bar" - :on-clicked - (callback (widget event data) - (with-widget (w :statusbar) - (push-message w (format nil "~a" (fraction (fm-other :pbar))))))))) + :on-clicked + (callback (widget event data) + (with-widget (w :statusbar) + (push-message w (format nil "~a" (fraction (fm-other :pbar))))))))) (mk-hbox :kids (kids-list? (mk-progress-bar :md-name :pbar2 - :pulse-step (c? (widget-value :step .1)) - :fraction (c-in .1)) + :pulse-step (c? (widget-value :step .1)) + :fraction (c-in .1)) (mk-toggle-button :md-name :pulse :label "Pulse") (mk-label :text "Interval") (mk-spin-button :md-name :timeout - :sensitive (c? (not (widget-value :pulse))) - :min 10 :max 1000 - :init 100) + :sensitive (c? (not (widget-value :pulse))) + :min 10 :max 1000 + :init 100) (mk-label :text "Pulse step") (mk-spin-button :md-name :step - :value-type 'single-float - :min 0.01 :max 1 :step 0.01 - :init 0.1) + :value-type 'single-float + :min 0.01 :max 1 :step 0.01 + :init 0.1) (mk-image :md-name :pulse-image - :stock (c? (if (widget-value :pulse) :yes :no))))) + :stock (c? (if (widget-value :pulse) :yes :no))))) (mk-alignment :expand t :fill t :xalign 0 :yalign 1 From phildebrandt at common-lisp.net Thu Apr 17 13:39:01 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Thu, 17 Apr 2008 09:39:01 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080417133901.296AF1D146@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv1592 Modified Files: md-utilities.lisp Log Message: Added a cells-store. --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/12 22:53:26 1.15 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 13:39:00 1.16 @@ -86,3 +86,143 @@ , at initargs :fm-parent (progn (assert self) self))) + +;;; +;;; cells store stuff +;;; (w) Peter Hildebrandt + +(export! cells-store c?-with-stored with-store-item store-add store-lookup store-remove) + +(defmacro c?-with-stored ((var key store &optional default) &body body) + `(c? (let ((something (value (get-listener ,key ,store)))) + (declare (ignorable something)) + (trc nil "executing c?-bwhen" self :something something :lookup (store-lookup ,key ,store)) + (bif (,var (store-lookup ,key ,store)) + (progn + , at body) + ,default)))) + +(defmodel cells-store (family) + ((data :accessor data :initarg :data :cell nil) + (listeners :accessor listeners :initarg :listeners :cell nil)) + (:default-initargs + :data (make-hash-table) + :listeners (make-hash-table) + :kids (c-in nil))) + +;;; infrastructure for manipulating the store and kicking rules + +(defmethod get-listener (key (store cells-store)) + (or (gethash key (listeners store)) + (let ((new-listener (make-instance 'family :fm-parent store :value (c-in 0)))) + (with-integrity (:change) + (push new-listener (kids store)) + (setf (gethash key (listeners store)) new-listener)) + new-listener))) + +(defmethod kick-listener (key (store cells-store)) + (bwhen (listener (gethash key (listeners store))) + (incf (value listener)))) + +(defmacro with-store-item ((key store) &body body) + `(prog1 + (progn , at body) + (kick-listener ,key ,store))) + +;;; item management + +(defmethod store-add (key (store cells-store) object) + (with-store-item (key store) + (setf (gethash key (data store)) object))) + +(defmethod store-lookup (key (store cells-store) &optional default) + (gethash key (data store) default)) + +(defmethod store-remove (key (store cells-hash-store)) + (with-store-item (key store) + (remhash key (data store)))) + + +;;; unit test + +(export! test-cells-store) + +(defmodel test-store-item (family) + ()) + +(defvar *observers*) + +(defobserver .value ((self test-store-item)) + (trc " changed value" :self self :to (value self)) + (when (boundp '*observers*) + (push self *observers*))) + +(defmacro with-assert-observers ((desc &rest asserted-observers) &body body) + `(let ((*observers* nil)) + (trc ,desc " -- checking observers") + , at body + (let ((superflous-observers (loop for run in *observers* if (not (member run (list , at asserted-observers))) collect run)) + (failed-observers (loop for asserted in (list , at asserted-observers) if (not (member asserted *observers*)) collect asserted))) + (trc "called observers on" *observers* :superflous superflous-observers :failed failed-observers) + (assert (not superflous-observers)) + (assert (not failed-observers))))) + +(defmacro assert-values ((desc) &body objects-and-values) + `(progn + (trc ,desc) + ,@(loop for (obj val) in objects-and-values + collect `(assert (eql (value ,obj) ,val))))) + +(defun test-cells-store () + (trc "testing cells-store -- making objects") + (let* ((store (make-instance 'cells-store)) + (foo (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing) + (bwhen (val (value v)) val)))) + (foo+1 (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing) + (bwhen (val (value v)) (1+ val))))) + (bar (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) + (bwhen (val (value v)) val)))) + (bar-1 (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) + (bwhen (val (value v)) (1- val)))))) + + (assert-values ("assert fresh initialization") + (foo 'nothing) + (foo+1 'nothing) + (bar 'nothing) + (bar-1 'nothing)) + + (with-assert-observers ("adding foo" foo foo+1) + (store-add :foo store (make-instance 'family :value (c-in nil)))) + + (assert-values ("added foo = nil") + (foo nil) + (foo+1 nil) + (bar 'nothing) + (bar-1 'nothing)) + + (with-assert-observers ("changing foo" foo foo+1) + (setf (value (store-lookup :foo store)) 1)) + + (assert-values ("changed foo = 1") + (foo 1) + (foo+1 2) + (bar 'nothing) + (bar-1 'nothing)) + + (with-assert-observers ("adding bar = 42" bar bar-1) + (store-add :bar store (make-instance 'family :value (c-in 42)))) + + (assert-values ("changed foo = 1") + (foo 1) + (foo+1 2) + (bar 42) + (bar-1 41)) + + (with-assert-observers ("changing bar to 2" bar bar-1) + (setf (value (store-lookup :bar store)) 2)) + + (assert-values ("changed foo = 1") + (foo 1) + (foo+1 2) + (bar 2) + (bar-1 1)))) \ No newline at end of file From phildebrandt at common-lisp.net Thu Apr 17 13:53:01 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Thu, 17 Apr 2008 09:53:01 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080417135301.E7F4042052@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv5160 Modified Files: md-utilities.lisp Log Message: v1.1 --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 13:39:00 1.16 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 13:52:57 1.17 @@ -138,7 +138,7 @@ (defmethod store-lookup (key (store cells-store) &optional default) (gethash key (data store) default)) -(defmethod store-remove (key (store cells-hash-store)) +(defmethod store-remove (key (store cells-store)) (with-store-item (key store) (remhash key (data store)))) @@ -225,4 +225,22 @@ (foo 1) (foo+1 2) (bar 2) - (bar-1 1)))) \ No newline at end of file + (bar-1 1)) + + (with-assert-observers ("deleting foo" foo foo+1) + (store-remove :foo store)) + + (assert-values ("deleted foo") + (foo 'nothing) + (foo+1 'nothing) + (bar 2) + (bar-1 1)) + + (with-assert-observers ("deleting bar" bar bar-1) + (store-remove :bar store)) + + (assert-values ("deleted bar") + (foo 'nothing) + (foo+1 'nothing) + (bar 'nothing) + (bar-1 'nothing)))) \ No newline at end of file From phildebrandt at common-lisp.net Thu Apr 17 15:50:37 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Thu, 17 Apr 2008 11:50:37 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080417155037.027783612F@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv32577 Modified Files: md-utilities.lisp Log Message: added bwhen-gethash --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 13:52:57 1.17 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 15:50:37 1.18 @@ -91,16 +91,28 @@ ;;; cells store stuff ;;; (w) Peter Hildebrandt -(export! cells-store c?-with-stored with-store-item store-add store-lookup store-remove) +(export! cells-store bwhen-gethash c?-with-stored with-store-item store-add store-lookup store-remove) (defmacro c?-with-stored ((var key store &optional default) &body body) - `(c? (let ((something (value (get-listener ,key ,store)))) - (declare (ignorable something)) - (trc nil "executing c?-bwhen" self :something something :lookup (store-lookup ,key ,store)) - (bif (,var (store-lookup ,key ,store)) - (progn - , at body) - ,default)))) + `(c? (bwhen-gethash (,var ,key ,store ,default) + , at body))) + +(defmacro with-uniqs ((&rest symbols) &body body) + `(let ,(mapcar #'(lambda (sym) `(,sym (gensym ,(string sym)))) symbols) + , at body)) + +(defmacro bwhen-gethash ((var key store &optional if-not) &body body) + (with-uniqs (gkey gstore gupdate gifnot) + `(let ((,gkey ,key) + (,gstore ,store) + (,gifnot ,if-not)) + (let ((,gupdate (value (get-listener ,gkey ,gstore)))) + (declare (ignorable ,gupdate)) + (trc nil "executing bwhen-gethash" self :update-tick ,gupdate :lookup (store-lookup ,gkey ,gstore)) + (bif (,var (store-lookup ,gkey ,gstore)) + (progn + , at body) + ,gifnot))))) (defmodel cells-store (family) ((data :accessor data :initarg :data :cell nil) @@ -183,7 +195,12 @@ (bar (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) (bwhen (val (value v)) val)))) (bar-1 (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) - (bwhen (val (value v)) (1- val)))))) + (bwhen (val (value v)) (1- val))))) + (bypass-lookup? (make-instance 'family :value (c-in t))) + (baz (make-instance 'test-store-item :value (c? (if (value bypass-lookup?) + 'no-lookup + (bwhen-gethash (v :bar store 'nothing) + (value v))))))) (assert-values ("assert fresh initialization") (foo 'nothing) @@ -227,6 +244,15 @@ (bar 2) (bar-1 1)) + (assert-values ("baz w/o lookup") + (baz 'no-lookup)) + + (with-assert-observers ("activating lookup" baz) + (setf (value bypass-lookup?) nil)) + + (assert-values ("baz w/lookup") + (baz 2)) + (with-assert-observers ("deleting foo" foo foo+1) (store-remove :foo store)) @@ -236,11 +262,18 @@ (bar 2) (bar-1 1)) - (with-assert-observers ("deleting bar" bar bar-1) + (with-assert-observers ("deleting bar" bar bar-1 baz) (store-remove :bar store)) (assert-values ("deleted bar") (foo 'nothing) (foo+1 'nothing) (bar 'nothing) - (bar-1 'nothing)))) \ No newline at end of file + (bar-1 'nothing) + (baz 'nothing)) + + (with-assert-observers ("de-activating lookup" baz) + (setf (value bypass-lookup?) t)) + + (assert-values ("baz w/o lookup") + (baz 'no-lookup)))) \ No newline at end of file From fgoenninger at common-lisp.net Thu Apr 17 16:11:48 2008 From: fgoenninger at common-lisp.net (fgoenninger) Date: Thu, 17 Apr 2008 12:11:48 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20080417161148.00F762804F@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv7688 Modified Files: Celtk.asd Log Message: Changed: Updated .asd file to reflect .lpr file. --- /project/cells/cvsroot/Celtk/Celtk.asd 2007/01/29 23:06:35 1.12 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2008/04/17 16:11:48 1.13 @@ -38,6 +38,5 @@ (:file "fileevent") (:file "togl") (:file "run") - (:file "ltktest-ci") - (:file "lotsa-widgets") - (:file "demos"))) + (:file "movie") + (:file "tk-file"))) From fgoenninger at common-lisp.net Thu Apr 17 16:13:05 2008 From: fgoenninger at common-lisp.net (fgoenninger) Date: Thu, 17 Apr 2008 12:13:05 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20080417161305.B9FD646180@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv7782 Modified Files: fileevent.lisp Log Message: Changed: handle tile? for fileevent. --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/11/04 20:53:08 1.9 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2008/04/17 16:13:05 1.10 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.9 2006/11/04 20:53:08 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.10 2008/04/17 16:13:05 fgoenninger Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== @@ -44,8 +44,7 @@ ;;; TK-FILEEVENT MODEL ;;; =========================================================================== -(defmodel tk-fileevent (widget) - +(defmodel tk-fileevent (window) ((.md-name :accessor id :initarg :id :initform (c-in nil) @@ -145,8 +144,8 @@ (:default-initargs :id (gensym "tk-fileevent-") - :eof-fn 'default-eof-fn)) - + :eof-fn 'default-eof-fn + :tile? nil)) ;;; =========================================================================== ;;; CELL RULE: FILE-EVENT/OPCODE @@ -564,7 +563,7 @@ (mk-fileevent :id :fileevent-test :read-fn 'USRF :iostream (c-in - (open "/Users/frgo/dribble.lisp" + (open "/dev/cu.usbserial" ;;; Adapt here !!! ^^^^^^^^^^^^^^^^^^^^^^^^^^^ :direction :input))))))) @@ -574,5 +573,4 @@ (test-window 'fileevent-test-window) (trc "-----------------------------------------------------------------------------")) -#+test -(test-window 'fileevent-test-window) \ No newline at end of file +#+test (test-window 'fileevent-test-window) \ No newline at end of file From fgoenninger at common-lisp.net Thu Apr 17 16:16:44 2008 From: fgoenninger at common-lisp.net (fgoenninger) Date: Thu, 17 Apr 2008 12:16:44 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20080417161644.6DADA4C005@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv8038 Added Files: tk-file.lisp Log Message: First Check-In. --- /project/cells/cvsroot/Celtk/tk-file.lisp 2008/04/17 16:16:44 NONE +++ /project/cells/cvsroot/Celtk/tk-file.lisp 2008/04/17 16:16:44 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| Celtk -- Cells, Tcl, and Tk Copyright (C) 2006, 2007 by Kenneth Tilton This file: Copyright (C) 2007 by Frank Goenninger This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :Celtk) (defun do-tk-get-open-file (self args) (tk-open-file self args)) (defmacro tk-get-open-file (self args) `(tk-format-now "Tk_getOpenFile")) From phildebrandt at common-lisp.net Sun Apr 20 13:04:40 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 20 Apr 2008 09:04:40 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080420130440.8B1734C00C@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv29075 Modified Files: md-slot-value.lisp md-utilities.lisp Log Message: Newer version of the cells-store --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/13 15:25:00 1.44 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/20 13:04:40 1.45 @@ -24,7 +24,7 @@ (when (and (not *not-to-be*) (mdead self)) (trc "md-slot-value passed dead self, returning NIL" self slot-name c) - (inspect self) + #-sbcl (inspect self) (break "see inspector for dead ~a" self) (return-from md-slot-value nil)) (tagbody --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 15:50:37 1.18 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/20 13:04:40 1.19 @@ -91,68 +91,109 @@ ;;; cells store stuff ;;; (w) Peter Hildebrandt -(export! cells-store bwhen-gethash c?-with-stored with-store-item store-add store-lookup store-remove) +(export! cells-store bwhen-c-stored c?-with-stored with-store-item store-add store-lookup store-remove) (defmacro c?-with-stored ((var key store &optional default) &body body) - `(c? (bwhen-gethash (,var ,key ,store ,default) + `(c? (bwhen-c-stored (,var ,key ,store ,default) , at body))) (defmacro with-uniqs ((&rest symbols) &body body) `(let ,(mapcar #'(lambda (sym) `(,sym (gensym ,(string sym)))) symbols) , at body)) -(defmacro bwhen-gethash ((var key store &optional if-not) &body body) - (with-uniqs (gkey gstore gupdate gifnot) +(defmacro bwhen-c-stored ((var key store &optional if-not) &body body) + (with-uniqs (gkey gstore glink gifnot) `(let ((,gkey ,key) (,gstore ,store) (,gifnot ,if-not)) - (let ((,gupdate (value (get-listener ,gkey ,gstore)))) - (declare (ignorable ,gupdate)) - (trc nil "executing bwhen-gethash" self :update-tick ,gupdate :lookup (store-lookup ,gkey ,gstore)) + (let ((,glink (query-c-link ,gkey ,gstore))) + (declare (ignorable ,glink)) + (trc nil "executing bwhen-c-stored" self :update-tick ,glink :lookup (store-lookup ,gkey ,gstore)) (bif (,var (store-lookup ,gkey ,gstore)) (progn , at body) ,gifnot))))) (defmodel cells-store (family) - ((data :accessor data :initarg :data :cell nil) - (listeners :accessor listeners :initarg :listeners :cell nil)) + ((data :accessor data :initarg :data :cell nil)) (:default-initargs - :data (make-hash-table) - :listeners (make-hash-table) - :kids (c-in nil))) + :data (make-hash-table))) ;;; infrastructure for manipulating the store and kicking rules -(defmethod get-listener (key (store cells-store)) - (or (gethash key (listeners store)) - (let ((new-listener (make-instance 'family :fm-parent store :value (c-in 0)))) - (with-integrity (:change) - (push new-listener (kids store)) - (setf (gethash key (listeners store)) new-listener)) - new-listener))) - -(defmethod kick-listener (key (store cells-store)) - (bwhen (listener (gethash key (listeners store))) - (incf (value listener)))) +(defmethod entry (key (store cells-store)) + (gethash key (data store))) -(defmacro with-store-item ((key store) &body body) +(defmethod (setf entry) (new-data key (store cells-store)) + (setf (gethash key (data store)) new-data)) + +(defmethod c-link (key (store cells-store)) + (car (entry key store))) + +(defmethod (setf c-link) (new-c-link key (store cells-store)) + (if (consp (entry key store)) + (setf (car (entry key store)) new-c-link) + (setf (entry key store) (cons new-c-link nil))) + new-c-link) + +(defmethod item (key (store cells-store)) + (cdr (entry key store))) + +(defmethod (setf item) (new-item key (store cells-store)) + (if (consp (entry key store)) + (setf (cdr (entry key store)) new-item) + (setf (entry key store) (cons nil new-item))) + new-item) + +;;; c-links + +(defmodel c-link () + ((value :accessor value :initform (c-in 0) :initarg :value))) + +(defmethod query-c-link (key (store cells-store)) + (trc "c-link> query link" key store (c-link key store)) + (value (or (c-link key store) + (setf (c-link key store) (make-instance 'c-link))))) + +(defmethod kick-c-link (key (store cells-store)) + (bwhen (link (c-link key store)) + (trc "c-link> kick link" key store link) + (with-integrity (:change :kick-c-link) + (incf (value link))))) + +(defmacro with-store-item ((item key store) &body body) `(prog1 - (progn , at body) - (kick-listener ,key ,store))) + (symbol-macrolet ((,item '(item key store))) + (progn + , at body)) + (kick-c-link ,key ,store))) + + +(defmacro with-store-entry ((key store &key quiet) &body body) + `(prog1 + (progn + , at body) + (unless ,quiet + (kick-c-link ,key ,store)))) ;;; item management -(defmethod store-add (key (store cells-store) object) - (with-store-item (key store) - (setf (gethash key (data store)) object))) +(defmethod store-add (key (store cells-store) object &key quiet) + (with-store-entry (key store :quiet quiet) + (when (item key store) + (trc "overwriting item" key (item key store))) + (setf (item key store) object))) (defmethod store-lookup (key (store cells-store) &optional default) - (gethash key (data store) default)) - -(defmethod store-remove (key (store cells-store)) - (with-store-item (key store) - (remhash key (data store)))) + (when (mdead (item key store)) + (with-store-entry (key store) + (trc "looked up dead item -- resetting to nil" key store) + (setf (item key store) nil))) + (or (item key store) default)) + +(defmethod store-remove (key (store cells-store) &key quiet) + (with-store-entry (key store :quiet quiet) + (setf (item key store) nil))) ;;; unit test @@ -199,7 +240,7 @@ (bypass-lookup? (make-instance 'family :value (c-in t))) (baz (make-instance 'test-store-item :value (c? (if (value bypass-lookup?) 'no-lookup - (bwhen-gethash (v :bar store 'nothing) + (bwhen-c-stored (v :bar store 'nothing) (value v))))))) (assert-values ("assert fresh initialization") From phildebrandt at common-lisp.net Sun Apr 20 13:05:02 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 20 Apr 2008 09:05:02 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk Message-ID: <20080420130502.E42F15204D@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv29136/cells-gtk Modified Files: buttons.lisp cairo-drawing-area.lisp dialogs.lisp drawing-area.lisp gtk-app.lisp tree-view.lisp widgets.lisp Log Message: now runs with the cells-store inside --- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/16 14:41:28 1.3 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/20 13:05:02 1.4 @@ -59,11 +59,6 @@ (let ((state (gtk-toggle-button-get-active widget))) (setf (value self) state))))) -(defobserver .value ((self toggle-button)) - (trc "observing toggle-button .value" self (value self)) - (with-integrity (:change 'toggle-button-value) - (trc "with integrity"))) - #+test (DEF-GTK WIDGET TOGGLE-BUTTON (BUTTON) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL)) (MODE ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/14 16:43:41 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/20 13:05:02 1.3 @@ -110,10 +110,10 @@ (defmodel cairo-drawing-area (drawing-area) ((cairo-context :accessor cairo-context :cell nil :initform nil) - (canvas :accessor canvas :cell t :initform (c-in nil) :initarg :canvas) - (.canvas :accessor .canvas :initform (c-in nil)) + (canvas :accessor canvas :initform (c-in nil) :initarg :canvas :owning t) + (.canvas :accessor .canvas :initform (c-in nil) :owning t) (prims :reader prims :initform (c? (append (canvas self) (.canvas self)))) - (widget :reader widget :cell t :initform (c? self)) + (widget :reader widget :initform (c? self)) ;; the primitive the mouse is currently hovering over (hover :accessor hover :cell nil :initform nil) (hover-history :accessor hover-history :cell nil :initform nil) @@ -122,7 +122,7 @@ ;; callback (on-dragged [widget] [button] [primtitive] [start] [end]) (on-dragged :accessor on-dragged :cell nil :initform nil :initarg :on-dragged) - (dragging :accessor dragging :cell t :initform (c-in nil)) + (dragging :accessor dragging :initform (c-in nil)) (drag-start :accessor drag-start :cell nil :initform nil) (drag-offset :accessor drag-offset :cell nil :initform nil) @@ -131,7 +131,7 @@ (selection-color :accessor selection-color :cell nil :initform '(1 1 .27)) (drag-threshold :accessor drag-threshold :cell nil :initform 3 :initarg :drag-threshold) - (selection :accessor selection :cell t :initform (c-in nil))) + (selection :accessor selection :initform (c-in nil))) (:default-initargs :on-pressed #'cairo-drawing-area-button-press :on-released #'cairo-drawing-area-button-release @@ -312,6 +312,11 @@ ;;;; ------ destroy methods ---------------------------------------------- +(defmethod not-to-be :before ((self cairo-drawing-area)) + (trc "not-to-be cairo-drawing area erasing everything" self) + (setf (canvas self) nil + (.canvas self) nil)) + (defgeneric remove-primitive (primitive) (:documentation "Removes primitive")) @@ -479,8 +484,12 @@ ((polar (2d:polar-coords (^delta))) (mouse-over-p (when (^widget) (with-accessors ((mouse mouse-pos)) (widget self) - (and (2d:point-in-box-p mouse (^p1) (^p2) :tol (line-width self)) - (< (2d:distance-point-line mouse (^p1) (^p2)) (* (^line-width) 2))))))) + (when-bind* ((p1 (^p1)) + (p2 (^p2)) + (line-width (^line-width))) + (and mouse + (2d:point-in-box-p mouse p1 p2 :tol line-width) + (< (2d:distance-point-line mouse p1 p2) (* line-width 2)))))))) :no-redraw (polar mouse-over-p))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/20 13:05:02 1.2 @@ -60,18 +60,23 @@ (defun show-dialog (dlg-class &rest inits) (let ((self (apply #'make-instance dlg-class :awaken-on-init-p t inits))) (wtrc (0 100 "processing dlg") - (let* ((response (gtk-dialog-run (id self))) - (result (funcall (fn-response self) self response))) + (let* ((response (wtrc (0 100 "running dialog") + (gtk-dialog-run (id self)))) + (result (funcall (fn-response self) self response))) + (trc "showed dialog" response result) (with-slots (content-area) self (when content-area (trc "reading content area" (value content-area)) (setf result (value content-area)) (trc "forgetting content-area") - (gtk-object-forget (id content-area) content-area))) - (trc "destroying self") - (gtk-widget-destroy (id self)) - (trc "forgetting self") - (gtk-object-forget (id self) self) + (not-to-be content-area) + #+not-necessary (gtk-object-forget (id content-area) content-area))) + (trc "destroying self (not-to-be)") + (not-to-be self) + #+not-necessary (progn + (gtk-widget-destroy (id self)) + (trc "forgetting self") + (gtk-object-forget (id self) self)) result)))) (defun show-message (text &rest inits) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/14 16:43:42 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/20 13:05:02 1.3 @@ -27,7 +27,7 @@ (def-widget drawing-area () ((mouse-pos :accessor mouse-pos :cell t :initform (c-in (2d:v 0 0))) - (canvas :accessor canvas :cell t :initform (c-in nil) :initarg :canvas) + (canvas :accessor canvas :cell t :initform (c-in nil) :initarg :canvas :owning t) ; (on-draw self) (on-draw :accessor on-draw :cell nil :initarg :on-draw :initform nil) ;n/a @@ -142,7 +142,8 @@ (defmethod redraw ((self drawing-area)) "Queues a redraw with GTK." (trc nil "queue redraw" self) - (gtk-widget-queue-draw (id self))) + (unless (mdead self) + (gtk-widget-queue-draw (id self)))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/16 14:41:28 1.4 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/20 13:05:02 1.5 @@ -187,7 +187,8 @@ :visible (c-in nil))) (gtk-window-set-auto-startup-notification nil) (to-be splash) - (setf (visible splash) t) + (with-integrity (:change :make-splash-visible) + (setf (visible splash) t)) (not-to-be (make-instance 'window)) ; kick gtk ... ugly (loop while (gtk-events-pending) do (gtk-main-iteration))))) @@ -205,8 +206,9 @@ (when splash (not-to-be splash) (gtk-window-set-auto-startup-notification t)) - - (setf (visible app) t) + + (with-integrity (:change :make-app-visible) + (setf (visible app) t)) (not-to-be (make-instance 'window :visible nil)) ; ph: kick gtk ... ugly app)) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/16 14:41:28 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/20 13:05:02 1.3 @@ -363,7 +363,7 @@ (when old-value (loop for col in old-value do (gtk-tree-view-remove-column (id self) (id col)) - (gtk-object-forget (id col) col))) + #+not-necessary (gtk-object-forget (id col) col))) ; ph 042008 (when new-value (loop for col in new-value for pos from 0 --- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/16 14:41:28 1.3 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/20 13:05:02 1.4 @@ -57,34 +57,33 @@ (defun gtk-objects-init () (setf *gtk-objects* (make-hash-table :size 100 :rehash-size 100) - *widgets* (make-hash-table :test #'equal))) + *widgets* (make-instance 'cells-store))) ;;; id lookup (defun gtk-object-store (gtk-id gtk-object &aux (hash-id (cffi:pointer-address gtk-id))) (unless *gtk-objects* (gtk-objects-init)) - (setf (gethash (md-name gtk-object) *widgets*) gtk-object) + (bwhen (name (md-name gtk-object)) + (store-add name *widgets* gtk-object)) (let ((known (gethash hash-id *gtk-objects*))) (cond ((eql known gtk-object)) (t - (when known + #+ssh (when known (warn (format nil "Object ~a has been reclaimed by GTK. Cells-gtk might have stale references" known))) (setf (gethash hash-id *gtk-objects*) gtk-object))))) (defun gtk-object-forget (gtk-id gtk-object) (when (and gtk-id gtk-object) - (trc nil " forgetting id/obj" gtk-id gtk-object) + (trc " forgetting id/obj" gtk-id gtk-object) (let ((ptr (cffi:pointer-address gtk-id))) - (assert *widgets*) - (when (eql (gethash (md-name gtk-object) *widgets*) gtk-object) - (remhash (md-name gtk-object) *widgets*)) (assert *gtk-objects*) (remhash ptr *gtk-objects*) - (mapc (lambda (k) (gtk-object-forget (slot-value k 'id) k)) - (slot-value gtk-object '.kids))))) + #+unnecessary (mapc (lambda (k) (gtk-object-forget (slot-value k 'id) k)) + (slot-value gtk-object '.kids))) ; unnecessary, ph + (trc " done" gtk-id gtk-object))) (defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (cffi:pointer-address gtk-id))) (when *gtk-objects* @@ -99,15 +98,13 @@ ;;; name lookup -(defun find-widget (name &optional default) - (gethash name *widgets* default)) - (defmacro with-widget ((widget name &optional alternative) &body body) - `(bif (,widget (find-widget ,name)) - (progn - (trc "with widget" ,widget ',body) - , at body) - ,alternative)) + `(bwhen-c-stored (,widget ,name *widgets* ,alternative) + , at body)) + +(defun find-widget (name &optional default) + (with-widget (w name default) + w)) (defmacro with-widget-value ((val name &key (accessor '(quote value)) (alternative nil)) &body body) (with-gensyms (widget) @@ -382,14 +379,24 @@ (gtk-widget-show (id self)) (gtk-widget-hide (id self)))) -(defmethod not-to-be :after ((self widget)) +(defmethod not-to-be :around ((self gtk-object)) + (trc "gtk-object not-to-be :around" (md-name self) self) + (trc " store-remove") + (when (eql (store-lookup (md-name self) *widgets*) self) + (store-remove (md-name self) *widgets*)) + (trc " object-forget") + (gtk-object-forget (id self) self) + + (trc " call-next-method") + (call-next-method) + + (trc " widget-destroy") (when *gtk-debug* - (trc "WIDGET DESTROY" (md-name self) (type-of self) self) + (trc "WIDGET DESTROY" (slot-value self '.md-name) (type-of self) self) (force-output)) - (gtk-object-forget (slot-value self 'id) self) - (trc nil "not-to-be destroys" self (slot-value self 'id)) (gtk-widget-destroy (slot-value self 'id)) - (trc nil " done")) + (trc " done")) + (defun assert-bin (container) (assert (null (rest (kids container))) From phildebrandt at common-lisp.net Sun Apr 20 13:05:03 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sun, 20 Apr 2008 09:05:03 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk Message-ID: <20080420130503.299C45202E@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv29136/cells-gtk/test-gtk Modified Files: test-buttons.lisp test-drawing.lisp Log Message: now runs with the cells-store inside --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/16 14:41:30 1.3 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/20 13:05:03 1.4 @@ -4,42 +4,45 @@ ((nclics :accessor nclics :initform (c-in 0))) (:default-initargs :kids (c? (the-kids - (mk-label :text (c? (format nil "Toggled button active = ~a" - (with-widget (w :toggled-button) - (trc "calculating toggled button" w (value w)) - (value w))))) + (mk-label :text (c? (trc "### executing toggled button rule") + (format nil "Toggled button active = ~a" + (with-widget (w :toggled-button) + (trc " FOUND WIDGET" w (value w)) + (value w))))) (mk-hseparator) (mk-label :text (c? (format nil "Check button checked = ~a" - (widget-value :check-button)))) + (widget-value :check-button)))) (mk-hseparator) - (mk-label :text (c? (format nil "Radio button selected = ~a" - (with-widget (w :radio-group) - (value w))))) + (mk-label :text (c? (trc "### executing radio button rule") + (format nil "Radio button selected = ~a" + (with-widget (w :radio-group) + (trc " FOUND WIDGET") + (value w))))) (mk-hseparator) (mk-label :text (c? (format nil "Button clicked ~a times" - (nclics (upper self test-buttons)))) - :selectable t) + (nclics (upper self test-buttons)))) + :selectable t) (mk-hseparator) (mk-hbox :kids (c? (the-kids (mk-button :stock :apply - :tooltip "Click ....." - :on-clicked (callback (widget event data) - (incf (nclics (upper self test-buttons))))) + :tooltip "Click ....." + :on-clicked (callback (widget event data) + (incf (nclics (upper self test-buttons))))) (mk-button :label "Continuable error" - :on-clicked (callback (widget event data) - (trc "issuing continuable error" widget event) - (error 'gtk-continuable-error :text "Oops!"))) + :on-clicked (callback (widget event data) + (trc "issuing continuable error" widget event) + (error 'gtk-continuable-error :text "Oops!"))) (mk-button :label "Lisp error (Div 0)" - :on-clicked (callback (widget event data) + :on-clicked (callback (widget event data) (print (/ 3 0)))) (mk-toggle-button :md-name :toggled-button - :markup (c? (with-markup (:foreground (if (value self) :red :blue)) - "_Toggled Button"))) + :markup (c? (with-markup (:foreground (if (value self) :red :blue)) + "_Toggled Button"))) (mk-check-button :md-name :check-button - :markup (with-markup (:foreground :green) - "_Check Button"))))) + :markup (with-markup (:foreground :green) + "_Check Button"))))) (mk-hbox :md-name :radio-group :kids (kids-list? @@ -48,4 +51,11 @@ (mk-radio-button :md-name :radio-2 :label "Radio 2" :init t) (mk-radio-button :md-name :radio-3 - :label "Radio 3"))))))) + :label "Radio 3"))) + (mk-hbox + :kids (kids-list? + (mk-label :text (c? (trc "### executing toggled button rule 2") + (format nil "Toggled button active = ~a" + (with-widget (w :toggled-button) + (trc " FOUND WIDGET 2" w (value w)) + (value w))))))))))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp 2008/04/14 16:43:48 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp 2008/04/20 13:05:03 1.3 @@ -61,7 +61,7 @@ (col1 (random-color)) (col2 (random-color))) (trcx "rect" p1 p2 col1 col2) - (mk-primitive (fm-other :draw) :rectangle + (mk-primitive (find-widget :draw) :rectangle :p1 (c-in p1) :p2 (c-in p2) :rgb (rgb? col1) @@ -76,7 +76,7 @@ (radius (rnd 10 40)) (col1 (random-color)) (col2 (random-color))) - (mk-primitive (fm-other :draw) :arc + (mk-primitive (find-widget :draw) :arc :p (c-in p) :radius (c-in radius) :rgb (rgb? col1) @@ -99,7 +99,7 @@ 'cairo-drawing-area :md-name :draw-sun :expand t :fill t :width 500 :height 500 :fm-parent *parent* - :canvas (c? (let ((draw self)) + :canvas (c?n (let ((draw self)) (declare (ignorable draw)) (list (make-instance From ktilton at common-lisp.net Tue Apr 22 10:11:50 2008 From: ktilton at common-lisp.net (ktilton) Date: Tue, 22 Apr 2008 06:11:50 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080422101150.DC31A340A4@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv31764 Modified Files: defmodel.lisp family.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp propagate.lisp Log Message: --- /project/cells/cvsroot/cells/defmodel.lisp 2008/03/17 20:34:45 1.18 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/04/22 10:11:50 1.19 @@ -103,7 +103,7 @@ `(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) ; ph -- prevent sbcl warning (setf (md-slot-cell-type ',class ',slotname) ,cell) ,(when owning - `(setf (md-slot-owning ',class ',slotname) ,owning)) + `(setf (md-slot-owning? ',class ',slotname) ,owning)) ,(when reader-fn `(defmethod ,reader-fn ((self ,class)) (md-slot-value self ',slotname))) --- /project/cells/cvsroot/cells/family.lisp 2008/04/11 14:00:14 1.26 +++ /project/cells/cvsroot/cells/family.lisp 2008/04/22 10:11:50 1.27 @@ -19,7 +19,7 @@ (in-package :cells) (eval-when (:compile-toplevel :execute :load-toplevel) - (export '(model value family dbg + (export '(model value family dbg .pa kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable))) (defmodel model () @@ -47,6 +47,7 @@ (or (md-name self) (type-of self)))) (define-symbol-macro .parent (fm-parent self)) +(define-symbol-macro .pa (fm-parent self)) (defmethod md-name (other) (trc "yep other md-name" other (type-of other)) @@ -180,11 +181,7 @@ (defmethod kids ((other model-object)) nil) -(defmethod not-to-be :before ((fm family)) - (let ((sv-kids (slot-value fm '.kids))) - (when (listp sv-kids) - (dolist ( kid sv-kids) - (not-to-be kid))))) + ;------------------ kid slotting ---------------------------- ; --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/20 13:04:40 1.45 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/22 10:11:50 1.46 @@ -69,12 +69,13 @@ (defvar *trc-ensure* nil) -(defun ensure-value-is-current (c debug-id ensurer) +(defmethod ensure-value-is-current (c debug-id ensurer) ; ; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure ; dependencies are up-to-date before deciding if it itself is up-to-date ; (declare (ignorable debug-id ensurer)) + (count-it :ensure-value-is-current) ;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer) --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/20 13:04:40 1.19 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/22 10:11:50 1.20 @@ -40,26 +40,52 @@ nil)) (defgeneric not-to-be (self) + (:method ((self list)) + (dolist (s self) + (not-to-be s))) + (:method ((self array)) + (loop for s across self + do (not-to-be s))) + (:method ((self hash-table)) + (maphash (lambda (k v) + (declare (ignorable k)) + (not-to-be v)) self)) + (:method ((self model-object)) (md-quiesce self)) + + (:method :before ((self model-object)) + (loop for (slot-name . owning?) in (get (type-of self) :ownings) + when owning? + do (not-to-be (slot-value self slot-name)))) (:method :around ((self model-object)) (declare (ignorable self)) - (let ((*not-to-be* t)) - (trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver)) - "not.to-be nailing" self) - (unless (eq (md-state self) :eternal-rest) - (call-next-method) - - (setf (fm-parent self) nil - (md-state self) :eternal-rest) - - (md-map-cells self nil - (lambda (c) - (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not.to-be with primary method (use :before etc) - - (trc nil "not.to-be cleared 2 fm-parent, eternal-rest" self))))) - + (let ((*not-to-be* t) + (dbg nil #+not (or (eq (md-name self) :eclm-owner) + (typep self '(or mathx::eclm-2008 clo:ix-form mathx::a1-panel mathx::edit-caret ctk:window))))) + + (flet ((gok () + (unless (eq (md-state self) :eternal-rest) + (call-next-method) + + (setf (fm-parent self) nil + (md-state self) :eternal-rest) + + (md-map-cells self nil + (lambda (c) + (c-assert (eq :quiesced (c-state c)) () + "Cell ~a of dead model ~a not quiesced. Was not-to-be shadowed by + a primary method? Use :before instead."))) ;; fails if user obstructs not.to-be with primary method (use :before etc) + + ))) + (if (not dbg) + (gok) + (wtrc (0 100 "not.to-be nailing" self (when (typep self 'family) + (mapcar 'type-of (slot-value self '.kids)))) + (gok) + (when dbg (trc "finished nailing" self)))))))) + (defun md-quiesce (self) (trc nil "md-quiesce nailing cells" self (type-of self)) (md-map-cells self nil (lambda (c) --- /project/cells/cvsroot/cells/model-object.lisp 2008/02/02 00:09:28 1.19 +++ /project/cells/cvsroot/cells/model-object.lisp 2008/04/22 10:11:50 1.20 @@ -216,7 +216,7 @@ do (setf (md-slot-cell-type (class-name c) slot-name) new-type))) (cdar (push (cons slot-name new-type) (get class-name :cell-types))))))) -(defun md-slot-owning (class-name slot-name) +(defun md-slot-owning? (class-name slot-name) (assert class-name) (if (eq class-name 'null) (get slot-name :owning) @@ -224,9 +224,9 @@ (cdr entry) (dolist (super (class-precedence-list (find-class class-name))) (bwhen (entry (assoc slot-name (get (c-class-name super) :ownings))) - (return (setf (md-slot-owning class-name slot-name) (cdr entry)))))))) + (return (setf (md-slot-owning? class-name slot-name) (cdr entry)))))))) -(defun (setf md-slot-owning) (value class-name slot-name) +(defun (setf md-slot-owning?) (value class-name slot-name) (assert class-name) (if (eq class-name 'null) (setf (get slot-name :owning) value) @@ -236,7 +236,7 @@ (progn (setf (cdr entry) value) (loop for c in (class-direct-subclasses (find-class class-name)) - do (setf (md-slot-owning (class-name c) slot-name) value))) + do (setf (md-slot-owning? (class-name c) slot-name) value))) (push (cons slot-name value) (get class-name :ownings)))))) (defun md-slot-value-store (self slot-name new-value) --- /project/cells/cvsroot/cells/propagate.lisp 2008/03/15 15:18:34 1.34 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/04/22 10:11:50 1.35 @@ -105,7 +105,7 @@ ; (when (and prior-value-supplied prior-value - (md-slot-owning (type-of (c-model c)) (c-slot-name c))) + (md-slot-owning? (type-of (c-model c)) (c-slot-name c))) (trc nil "c.propagate> contemplating lost") (flet ((listify (x) (if (listp x) x (list x)))) (bif (lost (set-difference (listify prior-value) (listify (c-value c)))) From ktilton at common-lisp.net Tue Apr 22 10:11:51 2008 From: ktilton at common-lisp.net (ktilton) Date: Tue, 22 Apr 2008 06:11:51 -0400 (EDT) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20080422101151.24F5236115@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv31764/gui-geometry Modified Files: geometer.lisp Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2008/04/11 09:19:41 1.14 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2008/04/22 10:11:50 1.15 @@ -46,6 +46,7 @@ (mk-kid-slot (py :if-missing t) (c? (py-maintain-pt 0)))))) +(export! geo-kid-sized) (defmodel geo-kid-sized (family) () (:default-initargs From ktilton at common-lisp.net Tue Apr 22 11:03:44 2008 From: ktilton at common-lisp.net (ktilton) Date: Tue, 22 Apr 2008 07:03:44 -0400 (EDT) Subject: [cells-cvs] CVS cells/cells-test Message-ID: <20080422110344.EB3062E1BD@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv11478/cells-test Modified Files: cells-test.lpr Log Message: --- /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2007/11/30 22:29:06 1.8 +++ /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2008/04/22 11:03:44 1.9 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Oct 30, 2007 12:37)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Apr 3, 2008 23:47)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -16,7 +16,8 @@ (make-instance 'module :name "test-cycle.lisp") (make-instance 'module :name "test-ephemeral.lisp") (make-instance 'module :name "test-synapse.lisp") - (make-instance 'module :name "deep-cells.lisp")) + (make-instance 'module :name "deep-cells.lisp") + (make-instance 'module :name "cells-store.lisp")) :projects (list (make-instance 'project-module :name "..\\cells")) :libraries nil :distributed-files nil From ktilton at common-lisp.net Tue Apr 22 11:03:45 2008 From: ktilton at common-lisp.net (ktilton) Date: Tue, 22 Apr 2008 07:03:45 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080422110345.34AE82E1BD@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv11478 Modified Files: md-utilities.lisp Log Message: --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/22 10:11:50 1.20 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/22 11:03:44 1.21 @@ -112,235 +112,3 @@ , at initargs :fm-parent (progn (assert self) self))) - -;;; -;;; cells store stuff -;;; (w) Peter Hildebrandt - -(export! cells-store bwhen-c-stored c?-with-stored with-store-item store-add store-lookup store-remove) - -(defmacro c?-with-stored ((var key store &optional default) &body body) - `(c? (bwhen-c-stored (,var ,key ,store ,default) - , at body))) - -(defmacro with-uniqs ((&rest symbols) &body body) - `(let ,(mapcar #'(lambda (sym) `(,sym (gensym ,(string sym)))) symbols) - , at body)) - -(defmacro bwhen-c-stored ((var key store &optional if-not) &body body) - (with-uniqs (gkey gstore glink gifnot) - `(let ((,gkey ,key) - (,gstore ,store) - (,gifnot ,if-not)) - (let ((,glink (query-c-link ,gkey ,gstore))) - (declare (ignorable ,glink)) - (trc nil "executing bwhen-c-stored" self :update-tick ,glink :lookup (store-lookup ,gkey ,gstore)) - (bif (,var (store-lookup ,gkey ,gstore)) - (progn - , at body) - ,gifnot))))) - -(defmodel cells-store (family) - ((data :accessor data :initarg :data :cell nil)) - (:default-initargs - :data (make-hash-table))) - -;;; infrastructure for manipulating the store and kicking rules - -(defmethod entry (key (store cells-store)) - (gethash key (data store))) - -(defmethod (setf entry) (new-data key (store cells-store)) - (setf (gethash key (data store)) new-data)) - -(defmethod c-link (key (store cells-store)) - (car (entry key store))) - -(defmethod (setf c-link) (new-c-link key (store cells-store)) - (if (consp (entry key store)) - (setf (car (entry key store)) new-c-link) - (setf (entry key store) (cons new-c-link nil))) - new-c-link) - -(defmethod item (key (store cells-store)) - (cdr (entry key store))) - -(defmethod (setf item) (new-item key (store cells-store)) - (if (consp (entry key store)) - (setf (cdr (entry key store)) new-item) - (setf (entry key store) (cons nil new-item))) - new-item) - -;;; c-links - -(defmodel c-link () - ((value :accessor value :initform (c-in 0) :initarg :value))) - -(defmethod query-c-link (key (store cells-store)) - (trc "c-link> query link" key store (c-link key store)) - (value (or (c-link key store) - (setf (c-link key store) (make-instance 'c-link))))) - -(defmethod kick-c-link (key (store cells-store)) - (bwhen (link (c-link key store)) - (trc "c-link> kick link" key store link) - (with-integrity (:change :kick-c-link) - (incf (value link))))) - -(defmacro with-store-item ((item key store) &body body) - `(prog1 - (symbol-macrolet ((,item '(item key store))) - (progn - , at body)) - (kick-c-link ,key ,store))) - - -(defmacro with-store-entry ((key store &key quiet) &body body) - `(prog1 - (progn - , at body) - (unless ,quiet - (kick-c-link ,key ,store)))) - -;;; item management - -(defmethod store-add (key (store cells-store) object &key quiet) - (with-store-entry (key store :quiet quiet) - (when (item key store) - (trc "overwriting item" key (item key store))) - (setf (item key store) object))) - -(defmethod store-lookup (key (store cells-store) &optional default) - (when (mdead (item key store)) - (with-store-entry (key store) - (trc "looked up dead item -- resetting to nil" key store) - (setf (item key store) nil))) - (or (item key store) default)) - -(defmethod store-remove (key (store cells-store) &key quiet) - (with-store-entry (key store :quiet quiet) - (setf (item key store) nil))) - - -;;; unit test - -(export! test-cells-store) - -(defmodel test-store-item (family) - ()) - -(defvar *observers*) - -(defobserver .value ((self test-store-item)) - (trc " changed value" :self self :to (value self)) - (when (boundp '*observers*) - (push self *observers*))) - -(defmacro with-assert-observers ((desc &rest asserted-observers) &body body) - `(let ((*observers* nil)) - (trc ,desc " -- checking observers") - , at body - (let ((superflous-observers (loop for run in *observers* if (not (member run (list , at asserted-observers))) collect run)) - (failed-observers (loop for asserted in (list , at asserted-observers) if (not (member asserted *observers*)) collect asserted))) - (trc "called observers on" *observers* :superflous superflous-observers :failed failed-observers) - (assert (not superflous-observers)) - (assert (not failed-observers))))) - -(defmacro assert-values ((desc) &body objects-and-values) - `(progn - (trc ,desc) - ,@(loop for (obj val) in objects-and-values - collect `(assert (eql (value ,obj) ,val))))) - -(defun test-cells-store () - (trc "testing cells-store -- making objects") - (let* ((store (make-instance 'cells-store)) - (foo (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing) - (bwhen (val (value v)) val)))) - (foo+1 (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing) - (bwhen (val (value v)) (1+ val))))) - (bar (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) - (bwhen (val (value v)) val)))) - (bar-1 (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) - (bwhen (val (value v)) (1- val))))) - (bypass-lookup? (make-instance 'family :value (c-in t))) - (baz (make-instance 'test-store-item :value (c? (if (value bypass-lookup?) - 'no-lookup - (bwhen-c-stored (v :bar store 'nothing) - (value v))))))) - - (assert-values ("assert fresh initialization") - (foo 'nothing) - (foo+1 'nothing) - (bar 'nothing) - (bar-1 'nothing)) - - (with-assert-observers ("adding foo" foo foo+1) - (store-add :foo store (make-instance 'family :value (c-in nil)))) - - (assert-values ("added foo = nil") - (foo nil) - (foo+1 nil) - (bar 'nothing) - (bar-1 'nothing)) - - (with-assert-observers ("changing foo" foo foo+1) - (setf (value (store-lookup :foo store)) 1)) - - (assert-values ("changed foo = 1") - (foo 1) - (foo+1 2) - (bar 'nothing) - (bar-1 'nothing)) - - (with-assert-observers ("adding bar = 42" bar bar-1) - (store-add :bar store (make-instance 'family :value (c-in 42)))) - - (assert-values ("changed foo = 1") - (foo 1) - (foo+1 2) - (bar 42) - (bar-1 41)) - - (with-assert-observers ("changing bar to 2" bar bar-1) - (setf (value (store-lookup :bar store)) 2)) - - (assert-values ("changed foo = 1") - (foo 1) - (foo+1 2) - (bar 2) - (bar-1 1)) - - (assert-values ("baz w/o lookup") - (baz 'no-lookup)) - - (with-assert-observers ("activating lookup" baz) - (setf (value bypass-lookup?) nil)) - - (assert-values ("baz w/lookup") - (baz 2)) - - (with-assert-observers ("deleting foo" foo foo+1) - (store-remove :foo store)) - - (assert-values ("deleted foo") - (foo 'nothing) - (foo+1 'nothing) - (bar 2) - (bar-1 1)) - - (with-assert-observers ("deleting bar" bar bar-1 baz) - (store-remove :bar store)) - - (assert-values ("deleted bar") - (foo 'nothing) - (foo+1 'nothing) - (bar 'nothing) - (bar-1 'nothing) - (baz 'nothing)) - - (with-assert-observers ("de-activating lookup" baz) - (setf (value bypass-lookup?) t)) - - (assert-values ("baz w/o lookup") - (baz 'no-lookup)))) \ No newline at end of file From ktilton at common-lisp.net Tue Apr 22 11:03:45 2008 From: ktilton at common-lisp.net (ktilton) Date: Tue, 22 Apr 2008 07:03:45 -0400 (EDT) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20080422110345.69D1D2E1BD@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv11478/utils-kt Modified Files: core.lisp defpackage.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/02/11 14:47:31 1.7 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/04/22 11:03:45 1.8 @@ -17,6 +17,10 @@ (in-package :utils-kt) +(defmacro with-gensyms ((&rest symbols) &body body) + `(let ,(mapcar #'(lambda (sym) `(,sym (gensym ,(string sym)))) symbols) + , at body)) + (defmacro eval-now! (&body body) `(eval-when (:compile-toplevel :load-toplevel :execute) , at body)) --- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2007/12/03 12:21:34 1.9 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2008/04/22 11:03:45 1.10 @@ -38,6 +38,7 @@ #:intern$ #:define-constant #:*count* #:*stop* #:*dbg* + #:with-gensyms #:make-fifo-queue #:fifo-queue #:fifo-add #:fifo-delete #:fifo-empty #:fifo-pop #:fifo-clear #:fifo-map #:fifo-peek #:fifo-data #:with-fifo-map #:fifo-length @@ -45,4 +46,3 @@ #-(or lispworks mcl) #:true #+(and mcl (not openmcl-partial-mop)) #:class-slots )) - From ktilton at common-lisp.net Tue Apr 22 14:50:56 2008 From: ktilton at common-lisp.net (ktilton) Date: Tue, 22 Apr 2008 10:50:56 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080422145056.DC5D64C002@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv28246 Modified Files: cells.lpr Added Files: cells-store.lisp Log Message: --- /project/cells/cvsroot/cells/cells.lpr 2008/02/02 00:09:28 1.30 +++ /project/cells/cvsroot/cells/cells.lpr 2008/04/22 14:50:56 1.31 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Apr 3, 2008 23:47)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -24,7 +24,8 @@ (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") (make-instance 'module :name "family-values.lisp") - (make-instance 'module :name "test-propagation.lisp")) + (make-instance 'module :name "test-propagation.lisp") + (make-instance 'module :name "cells-store.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/cells-store.lisp 2008/04/22 14:50:56 NONE +++ /project/cells/cvsroot/cells/cells-store.lisp 2008/04/22 14:50:56 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| Cells Store -- Dependence on a Hash-Table Copyright (C) 2008 by Peter Hildebrandt This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cells) (export! cells-store bwhen-c-stored c?-with-stored with-store-item store-add store-lookup store-remove) (defmacro c?-with-stored ((var key store &optional default) &body body) `(c? (bwhen-c-stored (,var ,key ,store ,default) , at body))) (defmacro bwhen-c-stored ((var key store &optional if-not) &body body) (with-gensyms (gkey gstore glink gifnot) `(let ((,gkey ,key) (,gstore ,store) (,gifnot ,if-not)) (let ((,glink (query-c-link ,gkey ,gstore))) (declare (ignorable ,glink)) (trc nil "executing bwhen-c-stored" self :update-tick ,glink :lookup (store-lookup ,gkey ,gstore)) (bif (,var (store-lookup ,gkey ,gstore)) (progn , at body) ,gifnot))))) (defmodel cells-store (family) ((data :accessor data :initarg :data :cell nil)) (:default-initargs :data (make-hash-table))) ;;; infrastructure for manipulating the store and kicking rules (defmethod entry (key (store cells-store)) (gethash key (data store))) (defmethod (setf entry) (new-data key (store cells-store)) (setf (gethash key (data store)) new-data)) (defmethod c-link (key (store cells-store)) (car (entry key store))) (defmethod (setf c-link) (new-c-link key (store cells-store)) (if (consp (entry key store)) (setf (car (entry key store)) new-c-link) (setf (entry key store) (cons new-c-link nil))) new-c-link) (defmethod item (key (store cells-store)) (cdr (entry key store))) (defmethod (setf item) (new-item key (store cells-store)) (if (consp (entry key store)) (setf (cdr (entry key store)) new-item) (setf (entry key store) (cons nil new-item))) new-item) ;;; c-links (defmodel c-link () ((value :accessor value :initform (c-in 0) :initarg :value))) (defmethod query-c-link (key (store cells-store)) (trc "c-link> query link" key store (c-link key store)) (value (or (c-link key store) (setf (c-link key store) (make-instance 'c-link))))) (defmethod kick-c-link (key (store cells-store)) (bwhen (link (c-link key store)) (trc "c-link> kick link" key store link) (with-integrity (:change :kick-c-link) (incf (value link))))) (defmacro with-store-item ((item key store) &body body) `(prog1 (symbol-macrolet ((,item '(item key store))) (progn , at body)) (kick-c-link ,key ,store))) (defmacro with-store-entry ((key store &key quiet) &body body) `(prog1 (progn , at body) (unless ,quiet (kick-c-link ,key ,store)))) ;;; item management (defmethod store-add (key (store cells-store) object &key quiet) (with-store-entry (key store :quiet quiet) (when (item key store) (trc "overwriting item" key (item key store))) (setf (item key store) object))) (defmethod store-lookup (key (store cells-store) &optional default) (when (mdead (item key store)) (with-store-entry (key store) (trc "looked up dead item -- resetting to nil" key store) (setf (item key store) nil))) (or (item key store) default)) (defmethod store-remove (key (store cells-store) &key quiet) (with-store-entry (key store :quiet quiet) (setf (item key store) nil))) ;;; unit test (export! test-cells-store) (defmodel test-store-item (family) ()) (defvar *observers*) (defobserver .value ((self test-store-item)) (trc " changed value" :self self :to (value self)) (when (boundp '*observers*) (push self *observers*))) (defmacro with-assert-observers ((desc &rest asserted-observers) &body body) `(let ((*observers* nil)) (trc ,desc " -- checking observers") , at body (let ((superfluous-observers (loop for run in *observers* if (not (member run (list , at asserted-observers))) collect run)) (failed-observers (loop for asserted in (list , at asserted-observers) if (not (member asserted *observers*)) collect asserted))) (trc "called observers on" *observers* :superflous superfluous-observers :failed failed-observers) (assert (not superfluous-observers)) (assert (not failed-observers))))) (defmacro assert-values ((desc) &body objects-and-values) `(progn (trc ,desc) ,@(loop for (obj val) in objects-and-values collect `(assert (eql (value ,obj) ,val))))) (defun test-cells-store () (trc "testing cells-store -- making objects") (let* ((store (make-instance 'cells-store)) (foo (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing) (bwhen (val (value v)) val)))) (foo+1 (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing) (bwhen (val (value v)) (1+ val))))) (bar (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) (bwhen (val (value v)) val)))) (bar-1 (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) (bwhen (val (value v)) (1- val))))) (bypass-lookup? (make-instance 'family :value (c-in t))) (baz (make-instance 'test-store-item :value (c? (if (value bypass-lookup?) 'no-lookup (bwhen-c-stored (v :bar store 'nothing) (value v))))))) (assert-values ("assert fresh initialization") (foo 'nothing) (foo+1 'nothing) (bar 'nothing) (bar-1 'nothing)) (with-assert-observers ("adding foo" foo foo+1) (store-add :foo store (make-instance 'family :value (c-in nil)))) (assert-values ("added foo = nil") (foo nil) (foo+1 nil) (bar 'nothing) (bar-1 'nothing)) (with-assert-observers ("changing foo" foo foo+1) (setf (value (store-lookup :foo store)) 1)) (assert-values ("changed foo = 1") (foo 1) (foo+1 2) (bar 'nothing) (bar-1 'nothing)) (with-assert-observers ("adding bar = 42" bar bar-1) (store-add :bar store (make-instance 'family :value (c-in 42)))) (assert-values ("changed foo = 1") (foo 1) (foo+1 2) (bar 42) (bar-1 41)) (with-assert-observers ("changing bar to 2" bar bar-1) (setf (value (store-lookup :bar store)) 2)) (assert-values ("changed foo = 1") (foo 1) (foo+1 2) (bar 2) (bar-1 1)) (assert-values ("baz w/o lookup") (baz 'no-lookup)) (with-assert-observers ("activating lookup" baz) (setf (value bypass-lookup?) nil)) (assert-values ("baz w/lookup") (baz 2)) (with-assert-observers ("deleting foo" foo foo+1) (store-remove :foo store)) (assert-values ("deleted foo") (foo 'nothing) (foo+1 'nothing) (bar 2) (bar-1 1)) (with-assert-observers ("deleting bar" bar bar-1 baz) (store-remove :bar store)) (assert-values ("deleted bar") (foo 'nothing) (foo+1 'nothing) (bar 'nothing) (bar-1 'nothing) (baz 'nothing)) (with-assert-observers ("de-activating lookup" baz) (setf (value bypass-lookup?) t)) (assert-values ("baz w/o lookup") (baz 'no-lookup)))) From ktilton at common-lisp.net Tue Apr 22 14:50:56 2008 From: ktilton at common-lisp.net (ktilton) Date: Tue, 22 Apr 2008 10:50:56 -0400 (EDT) Subject: [cells-cvs] CVS cells/cells-test Message-ID: <20080422145056.96F5148152@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv28246/cells-test Modified Files: cells-test.lpr Log Message: --- /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2008/04/22 11:03:44 1.9 +++ /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2008/04/22 14:50:56 1.10 @@ -16,8 +16,7 @@ (make-instance 'module :name "test-cycle.lisp") (make-instance 'module :name "test-ephemeral.lisp") (make-instance 'module :name "test-synapse.lisp") - (make-instance 'module :name "deep-cells.lisp") - (make-instance 'module :name "cells-store.lisp")) + (make-instance 'module :name "deep-cells.lisp")) :projects (list (make-instance 'project-module :name "..\\cells")) :libraries nil :distributed-files nil From phildebrandt at common-lisp.net Tue Apr 22 21:13:56 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Tue, 22 Apr 2008 17:13:56 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080422211356.8BC157113E@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv18982 Modified Files: cells.asd Log Message: added cells-store to cells.asd --- /project/cells/cvsroot/cells/cells.asd 2008/02/16 09:34:28 1.10 +++ /project/cells/cvsroot/cells/cells.asd 2008/04/22 21:13:56 1.11 @@ -33,7 +33,8 @@ (:file "family") (:file "fm-utilities") (:file "family-values") - (:file "test-propagation"))) + (:file "test-propagation") + (:file "cells-store"))) (defmethod perform ((o load-op) (c (eql (find-system :cells)))) (pushnew :cells *features*)) From ktilton at common-lisp.net Wed Apr 23 03:20:10 2008 From: ktilton at common-lisp.net (ktilton) Date: Tue, 22 Apr 2008 23:20:10 -0400 (EDT) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20080423032010.5B0541C003@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv1212/utils-kt Modified Files: core.lisp Log Message: Oops. Major repairs to handling of the owning property of cell slots. --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/04/22 11:03:45 1.8 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/04/23 03:20:10 1.9 @@ -18,7 +18,8 @@ (in-package :utils-kt) (defmacro with-gensyms ((&rest symbols) &body body) - `(let ,(mapcar #'(lambda (sym) `(,sym (gensym ,(string sym)))) symbols) + `(let ,(loop for sym in symbols + collecting `(,sym (gensym ,(string sym)))) , at body)) (defmacro eval-now! (&body body) From ktilton at common-lisp.net Wed Apr 23 03:20:10 2008 From: ktilton at common-lisp.net (ktilton) Date: Tue, 22 Apr 2008 23:20:10 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20080423032010.2D0D21A0E4@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv1212 Modified Files: cell-types.lisp cells.lisp defmodel.lisp family.lisp integrity.lisp md-utilities.lisp model-object.lisp propagate.lisp Log Message: Oops. Major repairs to handling of the owning property of cell slots. --- /project/cells/cvsroot/cells/cell-types.lisp 2008/01/31 03:30:17 1.29 +++ /project/cells/cvsroot/cells/cell-types.lisp 2008/04/23 03:20:09 1.30 @@ -67,11 +67,12 @@ (call-next-method) (progn (c-print-value c stream) - (format stream "=~d/~a/~a/~a]" + (format stream "<~d:~a ~a/~a = ~a>" (c-pulse c) - (c-state c) + (subseq (string (c-state c)) 0 1) (symbol-name (or (c-slot-name c) :anoncell)) - (print-cell-model (c-model c)))))))) + (print-cell-model (c-model c)) + (c-value c))))))) (export! print-cell-model) --- /project/cells/cvsroot/cells/cells.lisp 2008/04/12 22:53:26 1.27 +++ /project/cells/cvsroot/cells/cells.lisp 2008/04/23 03:20:09 1.28 @@ -45,6 +45,7 @@ (defparameter *c-debug* nil) (defparameter *defer-changes* nil) (defparameter *within-integrity* nil) +(defvar *istack*) (defparameter *client-queue-handler* nil) (defparameter *unfinished-business* nil) (defparameter *not-to-be* nil) --- /project/cells/cvsroot/cells/defmodel.lisp 2008/04/22 10:11:50 1.19 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/04/23 03:20:09 1.20 @@ -103,7 +103,7 @@ `(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) ; ph -- prevent sbcl warning (setf (md-slot-cell-type ',class ',slotname) ,cell) ,(when owning - `(setf (md-slot-owning? ',class ',slotname) ,owning)) + `(setf (md-slot-owning-direct? ',class ',slotname) ,owning)) ,(when reader-fn `(defmethod ,reader-fn ((self ,class)) (md-slot-value self ',slotname))) --- /project/cells/cvsroot/cells/family.lisp 2008/04/22 10:11:50 1.27 +++ /project/cells/cvsroot/cells/family.lisp 2008/04/23 03:20:09 1.28 @@ -94,6 +94,11 @@ :accessor kids :initarg :kids))) +#+test +(let ((c (find-class 'family))) + (mop::finalize-inheritance c) + (class-precedence-list c)) + (defmacro the-kids (&rest kids) `(let ((*parent* self)) (packed-flat! , at kids))) --- /project/cells/cvsroot/cells/integrity.lisp 2008/04/11 09:19:32 1.21 +++ /project/cells/cvsroot/cells/integrity.lisp 2008/04/23 03:20:09 1.22 @@ -28,11 +28,14 @@ (when opcode (assert (find opcode *ufb-opcodes*) () "Invalid opcode for with-integrity: ~a. Allowed values: ~a" opcode *ufb-opcodes*)) - `(call-with-integrity ,opcode ,defer-info (lambda (opcode defer-info) - (declare (ignorable opcode defer-info)) - ,(when debug - `(trc "integrity action entry" opcode defer-info ',body)) - , at body))) + `(call-with-integrity ,opcode ,defer-info + (lambda (opcode defer-info) + (declare (ignorable opcode defer-info)) + ,(when debug + `(trc "integrity action entry" opcode defer-info ',body)) + , at body) + (when *c-debug* + ',body))) (export! with-cc) @@ -43,7 +46,7 @@ (defun integrity-managed-p () *within-integrity*) -(defun call-with-integrity (opcode defer-info action) +(defun call-with-integrity (opcode defer-info action code) (when *stop* (return-from call-with-integrity)) (if *within-integrity* @@ -58,17 +61,32 @@ ; :deferred-to-ufb-1) (funcall action opcode defer-info)) - (let ((*within-integrity* t) - *unfinished-business* - *defer-changes*) - (trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info) - (when (or (zerop *data-pulse-id*) - (eq opcode :change)) - (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) - (data-pulse-next (cons opcode defer-info)))) - (prog1 - (funcall action opcode defer-info) - (finish-business))))) + (flet ((go-go () + (let ((*within-integrity* t) + *unfinished-business* + *defer-changes*) + (trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info) + (when (or (zerop *data-pulse-id*) + (eq opcode :change)) + (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) + (data-pulse-next (cons opcode defer-info)))) + (prog1 + (funcall action opcode defer-info) + (finish-business))))) + (if *c-debug* + (let ((*istack* (list (list opcode defer-info) + (list :trigger code) + (list :start-dp *data-pulse-id*)))) + (handler-case + (go-go) + (t (c) + (if (functionp *c-debug*) + (funcall *c-debug* c (nreverse *istack*)) + (loop for f in (nreverse *istack*) + do (format t "~&istk> ~(~a~) " f) + finally (describe c) + (break "integ backtrace: see listener for deets")))))) + (go-go))))) (defun ufb-queue (opcode) (cdr (assoc opcode *unfinished-business*))) @@ -85,14 +103,17 @@ (trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation))) (fifo-add (ufb-queue-ensure opcode) continuation)) -(defun just-do-it (op-or-q &aux (q (if (keywordp op-or-q) - (ufb-queue op-or-q) - op-or-q))) +(defun just-do-it (op-or-q &optional (op-code op-or-q) ;; make-better + &aux (q (if (keywordp op-or-q) + (ufb-queue op-or-q) + op-or-q))) (trc nil "----------------------------just do it doing---------------------" op-or-q) (loop for (defer-info . task) = (fifo-pop q) while task do (trc nil "unfin task is" opcode task) - (funcall task op-or-q defer-info))) + (when *c-debug* + (push (list op-code defer-info) *istack*)) + (funcall task op-or-q defer-info))) (defun finish-business () (when *stop* (return-from finish-business)) @@ -153,7 +174,7 @@ (bwhen (clientq (ufb-queue :client)) (if *client-queue-handler* (funcall *client-queue-handler* clientq) ;; might be empty/not exist, so handlers must check - (just-do-it clientq)) + (just-do-it clientq :client)) (when (fifo-peek (ufb-queue :client)) #+shhh (ukt::fifo-browse (ufb-queue :client) (lambda (entry) (trc "surprise client" entry))) --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/22 11:03:44 1.21 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/23 03:20:09 1.22 @@ -39,6 +39,7 @@ (declare (ignore self)) nil)) + (defgeneric not-to-be (self) (:method ((self list)) (dolist (s self) @@ -55,8 +56,7 @@ (md-quiesce self)) (:method :before ((self model-object)) - (loop for (slot-name . owning?) in (get (type-of self) :ownings) - when owning? + (loop for slot-name in (md-owning-slots self) do (not-to-be (slot-value self slot-name)))) (:method :around ((self model-object)) --- /project/cells/cvsroot/cells/model-object.lisp 2008/04/22 10:11:50 1.20 +++ /project/cells/cvsroot/cells/model-object.lisp 2008/04/23 03:20:09 1.21 @@ -216,28 +216,55 @@ do (setf (md-slot-cell-type (class-name c) slot-name) new-type))) (cdar (push (cons slot-name new-type) (get class-name :cell-types))))))) +#+hunh +(md-slot-owning? 'mathx::prb-solver '.kids) + +#+hunh +(cdr (assoc '.value (get 'm-index :indirect-ownings))) + +#+test +(md-slot-owning? 'm-index '.value) + (defun md-slot-owning? (class-name slot-name) (assert class-name) (if (eq class-name 'null) - (get slot-name :owning) - (bif (entry (assoc slot-name (get class-name :ownings))) + (get slot-name :owning) ;; might be wrong -- support for specials is unfinished w.i.p. + (bif (entry (assoc slot-name (get class-name :direct-ownings))) (cdr entry) - (dolist (super (class-precedence-list (find-class class-name))) - (bwhen (entry (assoc slot-name (get (c-class-name super) :ownings))) - (return (setf (md-slot-owning? class-name slot-name) (cdr entry)))))))) + (bif (entry (assoc slot-name (get class-name :indirect-ownings))) + (cdr entry) + (cdar + (push (cons slot-name + (cdr (loop for super in (cdr (class-precedence-list (find-class class-name))) + thereis (assoc slot-name (get (c-class-name super) :direct-ownings))))) + (get class-name :indirect-ownings))))))) -(defun (setf md-slot-owning?) (value class-name slot-name) +(defun (setf md-slot-owning-direct?) (value class-name slot-name) (assert class-name) - (if (eq class-name 'null) + (if (eq class-name 'null) ;; global variables (setf (get slot-name :owning) value) - - (let ((entry (assoc slot-name (get class-name :ownings)))) - (if entry - (progn - (setf (cdr entry) value) - (loop for c in (class-direct-subclasses (find-class class-name)) - do (setf (md-slot-owning? (class-name c) slot-name) value))) - (push (cons slot-name value) (get class-name :ownings)))))) + (progn + (bif (entry (assoc slot-name (get class-name :direct-ownings))) + (setf (cdr entry) value) + (push (cons slot-name value) (get class-name :direct-ownings))) + ; -- propagate to derivatives ... + (labels ((clear-subclass-ownings (c) + (loop for sub-c in (class-direct-subclasses c) + for sub-c-name = (c-class-name sub-c) + do (setf (get sub-c-name :indirect-ownings) + (delete slot-name (get sub-c-name :indirect-ownings) :key 'car)) ;; forces redecide + (setf (get sub-c-name :model-ownings) nil) ;; too much forcing full recalc like this? + (clear-subclass-ownings sub-c)))) + (clear-subclass-ownings (find-class class-name)))))) + +(defun md-owning-slots (self &aux (st (type-of self))) + (or (get st :model-ownings) + (setf (get st :model-ownings) + (loop for s in (class-slots (class-of self)) + for sn = (slot-definition-name s) + when (and (md-slot-cell-type st sn) + (md-slot-owning? st sn)) + collect sn)))) (defun md-slot-value-store (self slot-name new-value) (trc nil "md-slot-value-store" self slot-name new-value) --- /project/cells/cvsroot/cells/propagate.lisp 2008/04/22 10:11:50 1.35 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/04/23 03:20:09 1.36 @@ -42,6 +42,8 @@ (declare (ignorable pulse-info)) (unless *one-pulse?* (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) + (when *c-debug* + (push (list :data-pulse-next pulse-info) *istack*)) (incf *data-pulse-id*))) (defun c-currentp (c) @@ -106,11 +108,15 @@ (when (and prior-value-supplied prior-value (md-slot-owning? (type-of (c-model c)) (c-slot-name c))) - (trc nil "c.propagate> contemplating lost") + (trc nil "c.propagate> contemplating lost" c) (flet ((listify (x) (if (listp x) x (list x)))) (bif (lost (set-difference (listify prior-value) (listify (c-value c)))) (progn (trc nil "prop nailing owned!!!!!!!!!!!" c :lost lost :leaving (c-value c)) + (loop for l in lost + when (numberp l) + do (break "got num ~a" (list l (type-of (c-model c))(c-slot-name c) + (md-slot-owning? (type-of (c-model c)) (c-slot-name c))))) (mapcar 'not-to-be lost)) (trc nil "no owned lost!!!!!")))) From phildebrandt at common-lisp.net Wed Apr 23 06:34:25 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Wed, 23 Apr 2008 02:34:25 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/pod-utils Message-ID: <20080423063425.2634E702F9@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/pod-utils In directory clnet:/tmp/cvs-serv11350/pod-utils Modified Files: utils.lisp Log Message: Fixed library names for ubuntu. resolved conflict with utils-kt. --- /project/cells/cvsroot/cells-gtk3/pod-utils/utils.lisp 2008/04/13 10:59:26 1.1 +++ /project/cells/cvsroot/cells-gtk3/pod-utils/utils.lisp 2008/04/23 06:34:24 1.2 @@ -42,8 +42,8 @@ prepend breadth-first-search update with-stack-size pprint-without-strings chop setx reuse-cons intersect-predicates defmemo system-clear-memoized-fns system-add-memoized-fn system-list-memoized-fns - system-forget-memoized-fns with-gensyms fail)) -; ph: removed last1 new-reslist reslist-pop reslist-push reslist-fillptr now + system-forget-memoized-fns fail)) +; ph: removed last1 new-reslist reslist-pop reslist-push reslist-fillptr now with-gensyms (in-package :pod-utils) From phildebrandt at common-lisp.net Wed Apr 23 06:34:24 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Wed, 23 Apr 2008 02:34:24 -0400 (EDT) Subject: [cells-cvs] CVS cells-gtk3/gtk-ffi Message-ID: <20080423063424.1684364046@common-lisp.net> Update of /project/cells/cvsroot/cells-gtk3/gtk-ffi In directory clnet:/tmp/cvs-serv11350/gtk-ffi Modified Files: gtk-ffi.lisp Log Message: Fixed library names for ubuntu. resolved conflict with utils-kt. --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.lisp 2008/04/13 10:59:23 1.1 +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.lisp 2008/04/23 06:34:24 1.2 @@ -85,27 +85,27 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (cffi:define-foreign-library :gobject - (cffi-features:unix "libgobject-2.0.so") + (cffi-features:unix (:or "libgobject-2.0.so" "libgobject-2.0.so.0")) (cffi-features:windows "libgobject-2.0-0.dll") (cffi-features:darwin "libgobject-2.0-0.dylib")) (cffi:define-foreign-library :glib - (cffi-features:unix "libglib-2.0.so") + (cffi-features:unix (:or "libglib-2.0.so" "libglib-2.0.so.0")) (cffi-features:windows "libglib-2.0-0.dll") (cffi-features:darwin "libglib-2.0-0.dylib")) (cffi:define-foreign-library :gthread - (cffi-features:unix "libgthread-2.0.so") + (cffi-features:unix (:or "libgthread-2.0.so" "libgthread-2.0.so.0")) (cffi-features:windows "libgthread-2.0-0.dll") (cffi-features:darwin "libgthread-2.0-0.dylib")) (cffi:define-foreign-library :gdk - (cffi-features:unix "libgdk-x11-2.0.so") + (cffi-features:unix (:or "libgdk-x11-2.0.so" "libgdk-x11-2.0.so.0")) (cffi-features:windows "libgdk-win32-2.0-0.dll") (cffi-features:darwin "libgdk-win32-2.0-0.dylib")) ; pod ??? (cffi:define-foreign-library :gtk - (cffi-features:unix "libgtk-x11-2.0.so") + (cffi-features:unix (:or "libgtk-x11-2.0.so" "libgtk-x11-2.0.so.0")) (cffi-features:windows "libgtk-win32-2.0-0.dll") (cffi-features:darwin "libgtk-win32-2.0-0.dylib")) ; pod ??? From gxag at common-lisp.net Fri Apr 25 10:45:54 2008 From: gxag at common-lisp.net (Noreen) Date: Fri, 25 Apr 2008 11:45:54 +0100 Subject: [cells-cvs] penetrate deeper Message-ID: <4811A852.2080403@common-lisp.net> GAIN YOUR PENIS 2 INCH - SIMPLE AS NEVER. NATURAL HERBAL PRODUCT 100% SATISFACTION GUARANTEE! http://babbuyae.com