steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

new accessors

db4
Doug Coleman 2008-08-29 16:03:37 -05:00
parent 5da65cf7fd
commit fb27f066b1
1 changed files with 18 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
basis/models/models.factor
View File

@ -20,10 +20,10 @@ value connections dependencies ref locked? ;
M: model hashcode* drop model hashcode* ; M: model hashcode* drop model hashcode* ;
: add-dependency ( dep model -- ) : add-dependency ( dep model -- )
model-dependencies push ; dependencies>> push ;
: remove-dependency ( dep model -- ) : remove-dependency ( dep model -- )
model-dependencies delete ; dependencies>> delete ;
DEFER: add-connection DEFER: add-connection
@ -32,14 +32,14 @@ GENERIC: model-activated ( model -- )
M: model model-activated drop ; M: model model-activated drop ;
: ref-model ( model -- n ) : ref-model ( model -- n )
dup model-ref 1+ dup rot set-model-ref ; [ 1+ ] change-ref ref>> ;
: unref-model ( model -- n ) : unref-model ( model -- n )
dup model-ref 1- dup rot set-model-ref ; [ 1- ] change-ref ref>> ;
: activate-model ( model -- ) : activate-model ( model -- )
dup ref-model 1 = [ dup ref-model 1 = [
dup model-dependencies dup dependencies>>
[ dup activate-model dupd add-connection ] each [ dup activate-model dupd add-connection ] each
model-activated model-activated
] [ ] [
@ -50,7 +50,7 @@ DEFER: remove-connection
: deactivate-model ( model -- ) : deactivate-model ( model -- )
dup unref-model zero? [ dup unref-model zero? [
dup model-dependencies dup dependencies>>
[ dup deactivate-model remove-connection ] with each [ dup deactivate-model remove-connection ] with each
] [ ] [
drop drop
@ -59,46 +59,45 @@ DEFER: remove-connection
GENERIC: model-changed ( model observer -- ) GENERIC: model-changed ( model observer -- )
: add-connection ( observer model -- ) : add-connection ( observer model -- )
dup model-connections empty? [ dup activate-model ] when dup connections>> empty? [ dup activate-model ] when
model-connections push ; connections>> push ;
: remove-connection ( observer model -- ) : remove-connection ( observer model -- )
[ model-connections delete ] keep [ connections>> delete ] keep
dup model-connections empty? [ dup deactivate-model ] when dup connections>> empty? [ dup deactivate-model ] when
drop ; drop ;
: with-locked-model ( model quot -- ) : with-locked-model ( model quot -- )
swap swap
t over set-model-locked? t >>locked?
slip slip
f swap set-model-locked? ; inline f >>locked? drop ; inline
GENERIC: update-model ( model -- ) GENERIC: update-model ( model -- )
M: model update-model drop ; M: model update-model drop ;
: notify-connections ( model -- ) : notify-connections ( model -- )
dup model-connections [ model-changed ] with each ; dup connections>> [ model-changed ] with each ;
: set-model ( value model -- ) : set-model ( value model -- )
dup model-locked? [ dup locked?>> [
2drop 2drop
] [ ] [
dup [ dup [
[ set-model-value ] keep swap >>value
[ update-model ] keep [ update-model ] [ notify-connections ] bi
notify-connections
] with-locked-model ] with-locked-model
] if ; ] if ;
: ((change-model)) ( model quot -- newvalue model ) : ((change-model)) ( model quot -- newvalue model )
over >r >r model-value r> call r> ; inline over >r >r value>> r> call r> ; inline
: change-model ( model quot -- ) : change-model ( model quot -- )
((change-model)) set-model ; inline ((change-model)) set-model ; inline
: (change-model) ( model quot -- ) : (change-model) ( model quot -- )
((change-model)) set-model-value ; inline ((change-model)) swap >>value drop ; inline
GENERIC: range-value ( model -- value ) GENERIC: range-value ( model -- value )
GENERIC: range-page-value ( model -- value ) GENERIC: range-page-value ( model -- value )