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 ;
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 M: model hashcode* drop model hashcode* ;
22 : add-dependency ( dep model -- )
23 model-dependencies push ;
25 : remove-dependency ( dep model -- )
26 model-dependencies delete ;
30 GENERIC: model-activated ( model -- )
32 M: model model-activated drop ;
34 : ref-model ( model -- n )
35 dup model-ref 1+ dup rot set-model-ref ;
37 : unref-model ( model -- n )
38 dup model-ref 1- dup rot set-model-ref ;
40 : activate-model ( model -- )
42 dup model-dependencies
43 [ dup activate-model dupd add-connection ] each
49 DEFER: remove-connection
51 : deactivate-model ( model -- )
52 dup unref-model zero? [
53 dup model-dependencies
54 [ dup deactivate-model remove-connection ] with each
59 GENERIC: model-changed ( model observer -- )
61 : add-connection ( observer model -- )
62 dup model-connections empty? [ dup activate-model ] when
63 model-connections push ;
65 : remove-connection ( observer model -- )
66 [ model-connections delete ] keep
67 dup model-connections empty? [ dup deactivate-model ] when
70 : with-locked-model ( model quot -- )
72 t over set-model-locked?
74 f swap set-model-locked? ; inline
76 GENERIC: update-model ( model -- )
78 M: model update-model drop ;
80 : notify-connections ( model -- )
81 dup model-connections [ model-changed ] with each ;
83 : set-model ( value model -- )
88 [ set-model-value ] keep
94 : ((change-model)) ( model quot -- newvalue model )
95 over >r >r model-value r> call r> ; inline
97 : change-model ( model quot -- )
98 ((change-model)) set-model ; inline
100 : (change-model) ( model quot -- )
101 ((change-model)) set-model-value ; inline
103 GENERIC: range-value ( model -- value )
104 GENERIC: range-page-value ( model -- value )
105 GENERIC: range-min-value ( model -- value )
106 GENERIC: range-max-value ( model -- value )
107 GENERIC: range-max-value* ( model -- value )
108 GENERIC: set-range-value ( value model -- )
109 GENERIC: set-range-page-value ( value model -- )
110 GENERIC: set-range-min-value ( value model -- )
111 GENERIC: set-range-max-value ( value model -- )
113 : clamp-value ( value range -- newvalue )
114 [ range-min-value max ] keep
115 range-max-value* min ;