1 ! Copyright (C) 2006, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors generic kernel math sequences arrays assocs
4 alarms calendar math.order continuations fry ;
7 TUPLE: model < identity-tuple
8 value connections dependencies ref locked? ;
10 : new-model ( value class -- model )
13 V{ } clone >>connections
14 V{ } clone >>dependencies
17 : <model> ( value -- model )
20 : add-dependency ( dep model -- )
23 : remove-dependency ( dep model -- )
24 dependencies>> remove! drop ;
28 GENERIC: model-activated ( model -- )
30 M: model model-activated drop ;
32 : ref-model ( model -- n )
33 [ 1 + ] change-ref ref>> ;
35 : unref-model ( model -- n )
36 [ 1 - ] change-ref ref>> ;
38 : activate-model ( model -- )
41 [ dup activate-model dupd add-connection ] each
47 DEFER: remove-connection
49 : deactivate-model ( model -- )
50 dup unref-model zero? [
52 [ dup deactivate-model remove-connection ] with each
57 GENERIC: model-changed ( model observer -- )
59 : add-connection ( observer model -- )
60 dup connections>> empty? [ dup activate-model ] when
63 : remove-connection ( observer model -- )
64 [ connections>> remove! drop ] keep
65 dup connections>> empty? [ dup deactivate-model ] when
68 : with-locked-model ( model quot -- )
69 [ '[ _ t >>locked? @ ] ]
70 [ drop '[ _ f >>locked? drop ] ]
71 2bi [ ] cleanup ; inline
73 GENERIC: update-model ( model -- )
75 M: model update-model drop ;
77 : notify-connections ( model -- )
78 dup connections>> [ model-changed ] with each ;
80 : set-model ( value model -- )
86 [ update-model ] [ notify-connections ] bi
90 : ((change-model)) ( model quot -- newvalue model )
91 over [ [ value>> ] dip call ] dip ; inline
93 : change-model ( model quot -- )
94 ((change-model)) set-model ; inline
96 : (change-model) ( model quot -- )
97 ((change-model)) value<< ; inline
99 GENERIC: range-value ( model -- value )
100 GENERIC: range-page-value ( model -- value )
101 GENERIC: range-min-value ( model -- value )
102 GENERIC: range-max-value ( model -- value )
103 GENERIC: range-max-value* ( model -- value )
104 GENERIC: set-range-value ( value model -- )
105 GENERIC: set-range-page-value ( value model -- )
106 GENERIC: set-range-min-value ( value model -- )
107 GENERIC: set-range-max-value ( value model -- )
109 : clamp-value ( value range -- newvalue )
110 [ range-min-value ] [ range-max-value* ] bi clamp ;