cells-cvs

cells-cvs@common-lisp.net

721 discussions

[cells-cvs] Research has revealed!
by Frieda 13 Apr '08

13 Apr '08

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/

1 0

[cells-cvs] CVS cells/cells-test
by ktilton 12 Apr '08

12 Apr '08

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

1 0

[cells-cvs] CVS cells
by ktilton 12 Apr '08

12 Apr '08

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

1 0

[cells-cvs] CVS cells-gtk
by phildebrandt 11 Apr '08

11 Apr '08

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:

1 0

[cells-cvs] CVS cells
by phildebrandt 11 Apr '08

11 Apr '08

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)

1 0

[cells-cvs] CVS cells
by phildebrandt 11 Apr '08

11 Apr '08

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)

1 0

[cells-cvs] CVS triple-cells
by ktilton 11 Apr '08

11 Apr '08

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

1 0

[cells-cvs] CVS Celtk
by ktilton 11 Apr '08

11 Apr '08

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)

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 11 Apr '08

11 Apr '08

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@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@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

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 11 Apr '08

11 Apr '08

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)

1 0

← Newer
1
...
7
8
9
10
11
12
13
...
73
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs