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

Update models to use inheritance instead of delegation

db4
Slava Pestov 2008-07-11 00:47:16 -05:00
parent e8d0cbbd6a
commit de07ee1128
7 changed files with 68 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
extra/models/compose/compose.factor
View File

@ -1,19 +1,24 @@
USING: models kernel sequences ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors models kernel sequences ;
IN: models.compose
TUPLE: compose ;
TUPLE: compose < model ;
: new-compose ( models class -- compose )
f swap new-model
swap clone >>dependencies ; inline
: <compose> ( models -- compose )
f compose construct-model
swap clone over set-model-dependencies ;
compose new-compose ;
: composed-value >r model-dependencies r> map ; inline
: composed-value [ dependencies>> ] dip map ; inline
: set-composed-value >r model-dependencies r> 2each ; inline
: set-composed-value [ dependencies>> ] dip 2each ; inline
M: compose model-changed
nip
dup [ model-value ] composed-value swap delegate set-model ;
[ [ model-value ] composed-value ] keep set-model ;
M: compose model-activated dup model-changed ;

22
extra/models/delay/delay.factor
View File

@ -1,24 +1,26 @@
USING: kernel models alarms ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel models alarms ;
IN: models.delay
TUPLE: delay model timeout alarm ;
TUPLE: delay < model model timeout alarm ;
: update-delay-model ( delay -- )
dup delay-model model-value swap set-model ;
[ delay-model model-value ] keep set-model ;
: <delay> ( model timeout -- delay )
f delay construct-model
[ set-delay-timeout ] keep
[ set-delay-model ] 2keep
[ add-dependency ] keep ;
f delay new-model
swap >>timeout
over >>model
[ add-dependency ] keep ;
: cancel-delay ( delay -- )
delay-alarm [ cancel-alarm ] when* ;
: start-delay ( delay -- )
dup [ f over set-delay-alarm update-delay-model ] curry
over delay-timeout later
swap set-delay-alarm ;
dup
[ [ f >>alarm update-delay-model ] curry ] [ timeout>> ] bi later
>>alarm drop ;
M: delay model-changed nip dup cancel-delay start-delay ;

19
extra/models/filter/filter.factor
View File

@ -1,16 +1,17 @@
USING: models kernel ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors models kernel ;
IN: models.filter
TUPLE: filter model quot ;
TUPLE: filter < model model quot ;
: <filter> ( model quot -- filter )
f filter construct-model
[ set-filter-quot ] keep
[ set-filter-model ] 2keep
[ add-dependency ] keep ;
f filter new-model
swap >>quot
over >>model
[ add-dependency ] keep ;
M: filter model-changed
swap model-value over filter-quot call
swap set-model ;
[ [ value>> ] [ quot>> ] bi* call ] [ nip ] 2bi set-model ;
M: filter model-activated dup filter-model swap model-changed ;
M: filter model-activated [ model>> ] keep model-changed ;

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

@ -1,14 +1,17 @@
USING: kernel models sequences ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel models sequences ;
IN: models.history
TUPLE: history back forward ;
TUPLE: history < model back forward ;
: reset-history ( history -- )
V{ } clone over set-history-back
V{ } clone swap set-history-forward ;
V{ } clone >>back
V{ } clone >>forward ;
: <history> ( value -- history )
history construct-model dup reset-history ;
history new-model
reset-history ;
: (add-history) ( history to -- )
swap model-value dup [ swap push ] [ 2drop ] if ;

21
extra/models/mapping/mapping.factor
View File

@ -1,20 +1,21 @@
USING: models kernel assocs ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors models kernel assocs ;
IN: models.mapping
TUPLE: mapping assoc ;
TUPLE: mapping < model assoc ;
: <mapping> ( models -- mapping )
f mapping construct-model
over values over set-model-dependencies
tuck set-mapping-assoc ;
f mapping new-model
over values >>dependencies
swap >>assoc ;
M: mapping model-changed
nip
dup mapping-assoc [ model-value ] assoc-map
swap delegate set-model ;
nip [ assoc>> [ value>> ] assoc-map ] keep set-model ;
M: mapping model-activated dup model-changed ;
M: mapping model-activated
dup model-changed ;
M: mapping update-model
dup model-value swap mapping-assoc
[ value>> ] [ assoc>> ] bi
[ swapd at set-model ] curry assoc-each ;

3
extra/models/models.factor
View File

@ -100,9 +100,6 @@ M: model update-model drop ;
: (change-model) ( model quot -- )
((change-model)) set-model-value ; inline
: construct-model ( value class -- instance )
>r <model> { set-delegate } r> construct ; inline
GENERIC: range-value ( model -- value )
GENERIC: range-page-value ( model -- value )
GENERIC: range-min-value ( model -- value )

29
extra/models/range/range.factor
View File

@ -1,32 +1,33 @@
USING: kernel models arrays sequences math math.order
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel models arrays sequences math math.order
models.compose ;
IN: models.range
TUPLE: range ;
TUPLE: range < compose ;
: <range> ( value min max page -- range )
4array [ <model> ] map <compose>
{ set-delegate } range construct ;
4array [ <model> ] map range new-compose ;
: range-model ( range -- model ) model-dependencies first ;
: range-page ( range -- model ) model-dependencies second ;
: range-min ( range -- model ) model-dependencies third ;
: range-max ( range -- model ) model-dependencies fourth ;
: range-model ( range -- model ) dependencies>> first ;
: range-page ( range -- model ) dependencies>> second ;
: range-min ( range -- model ) dependencies>> third ;
: range-max ( range -- model ) dependencies>> fourth ;
M: range range-value
[ range-model model-value ] keep clamp-value ;
[ range-model value>> ] keep clamp-value ;
M: range range-page-value range-page model-value ;
M: range range-page-value range-page value>> ;
M: range range-min-value range-min model-value ;
M: range range-min-value range-min value>> ;
M: range range-max-value range-max model-value ;
M: range range-max-value range-max value>> ;
M: range range-max-value*
dup range-max-value swap range-page-value [-] ;
[ range-max-value ] [ range-page-value ] bi [-] ;
M: range set-range-value
[ clamp-value ] keep range-model set-model ;
[ clamp-value ] [ range-model ] bi set-model ;
M: range set-range-page-value range-page set-model ;