From 5db89605a2fb43bc476774091bc1248ba3d51ffd Mon Sep 17 00:00:00 2001 From: ktilton Date: Sat, 4 Nov 2006 20:52:01 +0000 Subject: [PATCH] md-value -> value --- cells-test/test-family.lisp | 12 ++++++------ cells-test/test.lisp | 12 ++++++------ cells.lpr | 6 +----- defpackage.lisp | 2 +- doc/01-Cell-basics.lisp | 18 +++++++++--------- family-values.lisp | 2 +- family.lisp | 9 +++++++-- fm-utilities.lisp | 6 +++--- integrity.lisp | 12 ++++++++++-- test.lisp | 8 ++++---- utils-kt/flow-control.lisp | 18 +++++++++++++++++- 11 files changed, 65 insertions(+), 40 deletions(-) diff --git a/cells-test/test-family.lisp b/cells-test/test-family.lisp index cda9101..cd11d5e 100644 --- a/cells-test/test-family.lisp +++ b/cells-test/test-family.lisp @@ -129,26 +129,26 @@ (eko ("kidnos")(when (numberp mdv) (loop for kn from 1 to (floor mdv) collecting kn)))) - :md-value (c-in 5) - :kv-key #'md-value + :value (c-in 5) + :kv-key #'value :kid-factory (lambda (f kv) (incf kf-calls) (trc "making kid" kv) (make-instance 'bottle :fm-parent f - :md-value kv + :value kv :label (c? (format nil "bottle ~d out of ~d on the wall" - (^md-value) + (^value) (length (kids f))))))))) (ct-assert (eql 5 kf-calls)) (setq kf-calls 0) - (decf (md-value wall)) + (decf (value wall)) (ct-assert (eql 4 (length (kids wall)))) (ct-assert (zerop kf-calls)) (setq kf-calls 0) - (incf (md-value wall)) + (incf (value wall)) (ct-assert (eql 5 (length (kids wall)))) (ct-assert (eql 1 kf-calls)) diff --git a/cells-test/test.lisp b/cells-test/test.lisp index f7aacf4..264ebb5 100644 --- a/cells-test/test.lisp +++ b/cells-test/test.lisp @@ -99,19 +99,19 @@ subclass for them?) ;; test huge number of useds by one rule (defmd m-index (family) - :md-value (c? (bwhen (ks (^kids)) - ;(trc "chya" (mapcar 'md-value ks)) - (apply '+ (mapcar 'md-value ks))))) + :value (c? (bwhen (ks (^kids)) + ;(trc "chya" (mapcar 'value ks)) + (apply '+ (mapcar 'value ks))))) (def-cell-test many-useds (let ((i (make-instance 'm-index))) (loop for n below 100 do (push (make-instance 'model :fm-parent i - :md-value (c-in n)) + :value (c-in n)) (kids i))) - (trc "index total" (md-value i)) - (ct-assert (= 4950 (md-value i))))) + (trc "index total" (value i)) + (ct-assert (= 4950 (value i))))) #+test (many-useds) diff --git a/cells.lpr b/cells.lpr index 7973194..28c3d72 100644 --- a/cells.lpr +++ b/cells.lpr @@ -23,11 +23,7 @@ (make-instance 'module :name "md-utilities.lisp") (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") - (make-instance 'module :name "family-values.lisp") - (make-instance 'module :name - "doc\\01-Cell-basics.lisp") - (make-instance 'module :name - "doc\\motor-control.lisp")) + (make-instance 'module :name "family-values.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil diff --git a/defpackage.lisp b/defpackage.lisp index b112391..4718997 100644 --- a/defpackage.lisp +++ b/defpackage.lisp @@ -52,7 +52,7 @@ #:defmodel #:defmd #:defobserver #:slot-value-observe #:def-c-unchanged-test #:new-value #:old-value #:old-value-boundp #:c... #:md-awaken - #:mkpart #:make-kid #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids + #:mkpart #:make-kid #:the-kids #:nsib #:value #:^value #:.value #:kids #:^kids #:.kids #:cells-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot #:def-kid-slots #:find-prior #:fm-pos #:kid-no #:fm-includes #:fm-ascendant-common #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib diff --git a/doc/01-Cell-basics.lisp b/doc/01-Cell-basics.lisp index 5a61c7e..ea4badb 100644 --- a/doc/01-Cell-basics.lisp +++ b/doc/01-Cell-basics.lisp @@ -309,10 +309,10 @@ the family class and its slot kids. every model-object has a parent slot, which gets used along with a family's kids slot to form simple trees navigable up and down. -model-objects also have slots for md-name and md-value (don't +model-objects also have slots for md-name and value (don't worry camelcase-haters, that is a declining feature of my code). md-name lets the family trees we build be treated as namespaces. -md-value just turns out to be very handy for a lot of things. for +value just turns out to be very handy for a lot of things. for example, a check-box instance needs some place to indicate its boolean state. @@ -323,7 +323,7 @@ it happens transparently, following the dataflow implicit in the rules we write, and the side-effects we specify via observer functions. the silly example below just shows the summer (that which sums) getting -a new md-value as the kids change, along with some observer output. in real-world +a new value as the kids change, along with some observer output. in real-world applications, where kids represent gui elements often dependent on each other, vastly more can transpire before a simple push into a kids slot has run its course. @@ -335,15 +335,15 @@ evaluate: () (:default-initargs :kids (c-in nil) ;; or we cannot add any addend kids later - :md-value (c? (reduce #'+ (kids self) + :value (c? (reduce #'+ (kids self) :initial-value 0 - :key #'md-value)))) + :key #'value)))) -(defobserver md-value ((self summer)) +(defobserver value ((self summer)) (trc "the sum of the values of the kids is" new-value)) (defobserver .kids ((self summer)) - (trc "the values of the kids are" (mapcar #'md-value new-value))) + (trc "the values of the kids are" (mapcar #'value new-value))) ;----------------------------------------------------------- ; now just evaluate each of the following forms one by one, @@ -364,7 +364,7 @@ observe: (push (make-instance 'model :fm-parent *f1* - :md-value 1) (kids *f1*)) + :value 1) (kids *f1*)) #| observe: 0> the values of the kids are (1) @@ -376,7 +376,7 @@ observe: (push (make-instance 'model :fm-parent *f1* - :md-value 2) (kids *f1*)) + :value 2) (kids *f1*)) #| observe: 0> the values of the kids are (2 1) diff --git a/family-values.lisp b/family-values.lisp index ff507d3..3f7be46 100644 --- a/family-values.lisp +++ b/family-values.lisp @@ -30,7 +30,7 @@ See the Lisp Lesser GNU Public License for more details. :reader kv-collector) (kid-values :initform (c? (when (kv-collector self) - (funcall (kv-collector self) (^md-value)))) + (funcall (kv-collector self) (^value)))) :accessor kid-values :initarg :kid-values) diff --git a/family.lisp b/family.lisp index dc04647..9fdb19e 100644 --- a/family.lisp +++ b/family.lisp @@ -19,12 +19,12 @@ See the Lisp Lesser GNU Public License for more details. (in-package :cells) (eval-when (:compile-toplevel :execute :load-toplevel) - (export '(model md-value family kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable))) + (export '(model value family kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable))) (defmodel model () ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name) (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent) - (.md-value :initform nil :accessor md-value :initarg :md-value))) + (.value :initform nil :accessor value :initarg :value))) (defmethod fm-parent (other) @@ -90,6 +90,11 @@ See the Lisp Lesser GNU Public License for more details. (if (typep ,self ',type) ,self (upper ,self ,type))))) (defun kid1 (self) (car (kids self))) + +(export! first-born-p) +(defun first-born-p (self) + (eq self (kid1 .parent))) + (defun kid2 (self) (cadr (kids self))) (defmacro ^k1 () `(kid1 self)) (defmacro ^k2 () `(kid2 self)) diff --git a/fm-utilities.lisp b/fm-utilities.lisp index 776f68b..7408890 100644 --- a/fm-utilities.lisp +++ b/fm-utilities.lisp @@ -403,7 +403,7 @@ See the Lisp Lesser GNU Public License for more details. (export! fmv) (defmacro fmv (name) - `(md-value (fm-other ,name))) + `(value (fm-other ,name))) (defmacro fm-otherx (md-name &key (starting 'self) skip-tree) (if (eql starting 'self) @@ -448,7 +448,7 @@ See the Lisp Lesser GNU Public License for more details. :global-search t))) (defmacro fm^v (id) - `(md-value (fm^ ,id))) + `(value (fm^ ,id))) (defmacro fm? (md-name &optional (starting 'self) (global-search t)) `(fm-find-one ,starting ,(if (consp md-name) @@ -466,7 +466,7 @@ See the Lisp Lesser GNU Public License for more details. :global-search nil))) (defmacro fm!v (id) - `(md-value (fm! ,id))) + `(value (fm! ,id))) (defmacro fm-other?! (md-name &optional (starting 'self)) `(fm-find-one ,starting ,(if (consp md-name) diff --git a/integrity.lisp b/integrity.lisp index 1b39bc9..4631511 100644 --- a/integrity.lisp +++ b/integrity.lisp @@ -30,12 +30,18 @@ See the Lisp Lesser GNU Public License for more details. "Invalid second value to with-integrity: ~a" opcode)) `(call-with-integrity ,opcode ,defer-info (lambda () ,@body))) -(export! with-c-change) +(export! with-c-change with-c-changes) (defmacro with-c-change (id &body body) `(with-integrity (:change ,id) ,@body)) +(defmacro with-c-changes (id &rest change-forms) + `(with-c-change ,id + ,(car change-forms) + ,(when (cdr change-forms) + `(with-c-changes ,id ,@(cdr change-forms))))) + (defun integrity-managed-p () *within-integrity*) @@ -68,6 +74,8 @@ See the Lisp Lesser GNU Public License for more details. (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*)) (when (and *no-tell* (eq opcode :tell-dependents)) @@ -83,7 +91,7 @@ See the Lisp Lesser GNU Public License for more details. while task do (trc nil "unfin task is" opcode task) (funcall task))) -(defparameter *no-tell* nil) + (defun finish-business () (when *stop* (return-from finish-business)) (tagbody diff --git a/test.lisp b/test.lisp index 5999713..fd6abaf 100644 --- a/test.lisp +++ b/test.lisp @@ -97,16 +97,16 @@ subclass for them?) (defmodel m-index (family) () (:default-initargs - :md-value (c? (bwhen (ks (^kids)) - (apply '+ (mapcar 'md-value ks)))))) + :value (c? (bwhen (ks (^kids)) + (apply '+ (mapcar 'value ks)))))) (def-cell-test many-useds (let ((i (make-instance 'm-index))) (loop for n below 100 do (push (make-instance 'model - :md-value (c-in n)) + :value (c-in n)) (kids i))) - (trc "index total" (md-value i)))) + (trc "index total" (value i)))) (defmodel m-null () ((aa :initform nil :cell nil :initarg :aa :accessor aa))) diff --git a/utils-kt/flow-control.lisp b/utils-kt/flow-control.lisp index d1ff1e6..f6f5b9d 100644 --- a/utils-kt/flow-control.lisp +++ b/utils-kt/flow-control.lisp @@ -31,7 +31,7 @@ See the Lisp Lesser GNU Public License for more details. (defun min-if (v1 v2) (if v1 (if v2 (min v1 v2) v1) v2)) -(export! list-flatten! tree-flatten) +(export! list-flatten! tree-flatten list-insertf subseq-contiguous-p) (defun list-flatten! (&rest list) (if (consp list) @@ -67,6 +67,22 @@ See the Lisp Lesser GNU Public License for more details. (declare (dynamic-extent ,fn-name)) ,@body)) +(defmacro list-insertf (place item &key after) + (let ((list (gensym)) + (afterv (gensym)) + (afters (gensym))) + `(let* ((,list ,place) + (,afterv ,after) + (,afters (when ,afterv (member ,after ,list)))) + (assert (or (null ,afterv) ,afters) () "list-insertf after ~a not in list ~a" ,afterv ,list) + (setf ,place + (if ,afterv + (append (ldiff ,list ,afters) + (list ,afterv) + (list ,item) + (cdr ,afters)) + (append ,list (list ,item))))))) + (defun intern$ (&rest strings) (intern (apply #'concatenate 'string strings)))