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

models: some more cleanup.

db4
John Benediktsson 2014-11-29 23:00:24 -08:00
parent 439649e707
commit 4b1690b9c1
4 changed files with 22 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/models/arrow/arrow.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors models kernel sequences ; USING: accessors kernel models sequences ;
IN: models.arrow IN: models.arrow
TUPLE: arrow < model quot ; TUPLE: arrow < model quot ;
@ -8,11 +8,11 @@ TUPLE: arrow < model quot ;
: <arrow> ( model quot -- arrow ) : <arrow> ( model quot -- arrow )
f arrow new-model f arrow new-model
swap >>quot swap >>quot
[ add-dependency ] keep ; [ add-dependency ] keep ;
M: arrow model-changed M: arrow model-changed
[ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi [ [ value>> ] [ quot>> ] bi* call( old -- new ) ]
set-model ; [ set-model ] bi ;
M: arrow model-activated M: arrow model-activated
[ dependencies>> ] keep [ model-changed ] curry each ; [ dependencies>> ] keep [ model-changed ] curry each ;

4
basis/models/product/product.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors models kernel sequences ; USING: accessors kernel models sequences ;
IN: models.product IN: models.product
TUPLE: product < model ; TUPLE: product < model ;
@ -26,7 +26,7 @@ M: product model-changed
M: product model-activated dup model-changed ; M: product model-activated dup model-changed ;
M: product update-model M: product update-model
dup value>> swap [ set-model ] set-product-value ; [ value>> ] keep [ set-model ] set-product-value ;
M: product range-value M: product range-value
[ range-value ] product-value ; [ range-value ] product-value ;

12
extra/models/history/history.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel models sequences ; USING: accessors kernel locals models sequences ;
IN: models.history IN: models.history
TUPLE: history < model back forward ; TUPLE: history < model back forward ;
@ -14,11 +14,13 @@ TUPLE: history < model back forward ;
reset-history ; reset-history ;
: (add-history) ( history to -- ) : (add-history) ( history to -- )
swap value>> dup [ swap push ] [ 2drop ] if ; swap value>> [ swap push ] [ drop ] if* ;
: go-back/forward ( history to from -- ) :: go-back/forward ( history to from -- )
[ 2drop ] from empty? [
[ [ dupd (add-history) ] dip pop swap set-model ] if-empty ; history to (add-history)
from pop history set-model
] unless ;
: go-back ( history -- ) : go-back ( history -- )
dup [ forward>> ] [ back>> ] bi go-back/forward ; dup [ forward>> ] [ back>> ] bi go-back/forward ;

14
extra/models/illusion/illusion.factor
View File

@ -1,15 +1,19 @@
USING: accessors models models.arrow inverse kernel ; USING: accessors inverse kernel models models.arrow ;
IN: models.illusion IN: models.illusion
TUPLE: illusion < arrow ; TUPLE: illusion < arrow ;
: <illusion> ( model quot -- illusion ) : <illusion> ( model quot -- illusion )
illusion new V{ } clone >>connections V{ } clone >>dependencies 0 >>ref f illusion new-model
swap >>quot over >>model [ add-dependency ] keep ; swap >>quot
over >>model
[ add-dependency ] keep ;
: <activated-illusion> ( model quot -- illusion ) <illusion> dup activate-model ; : <activated-illusion> ( model quot -- illusion )
<illusion> dup activate-model ;
: backtalk ( value object -- ) : backtalk ( value object -- )
[ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ; [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ;
M: illusion update-model ( model -- ) [ [ value>> ] keep backtalk ] with-locked-model ; M: illusion update-model ( model -- )
[ [ value>> ] keep backtalk ] with-locked-model ;