116 lines
2.9 KiB
Factor
Executable File
116 lines
2.9 KiB
Factor
Executable File
! Copyright (C) 2006, 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors generic kernel math sequences arrays assocs
|
|
alarms calendar math.order ;
|
|
IN: models
|
|
|
|
TUPLE: model < identity-tuple
|
|
value connections dependencies ref locked? ;
|
|
|
|
: new-model ( value class -- model )
|
|
new
|
|
swap >>value
|
|
V{ } clone >>connections
|
|
V{ } clone >>dependencies
|
|
0 >>ref ; inline
|
|
|
|
: <model> ( value -- model )
|
|
model new-model ;
|
|
|
|
M: model hashcode* drop model hashcode* ;
|
|
|
|
: add-dependency ( dep model -- )
|
|
model-dependencies push ;
|
|
|
|
: remove-dependency ( dep model -- )
|
|
model-dependencies delete ;
|
|
|
|
DEFER: add-connection
|
|
|
|
GENERIC: model-activated ( model -- )
|
|
|
|
M: model model-activated drop ;
|
|
|
|
: ref-model ( model -- n )
|
|
dup model-ref 1+ dup rot set-model-ref ;
|
|
|
|
: unref-model ( model -- n )
|
|
dup model-ref 1- dup rot set-model-ref ;
|
|
|
|
: activate-model ( model -- )
|
|
dup ref-model 1 = [
|
|
dup model-dependencies
|
|
[ dup activate-model dupd add-connection ] each
|
|
model-activated
|
|
] [
|
|
drop
|
|
] if ;
|
|
|
|
DEFER: remove-connection
|
|
|
|
: deactivate-model ( model -- )
|
|
dup unref-model zero? [
|
|
dup model-dependencies
|
|
[ dup deactivate-model remove-connection ] with each
|
|
] [
|
|
drop
|
|
] if ;
|
|
|
|
GENERIC: model-changed ( model observer -- )
|
|
|
|
: add-connection ( observer model -- )
|
|
dup model-connections empty? [ dup activate-model ] when
|
|
model-connections push ;
|
|
|
|
: remove-connection ( observer model -- )
|
|
[ model-connections delete ] keep
|
|
dup model-connections empty? [ dup deactivate-model ] when
|
|
drop ;
|
|
|
|
: with-locked-model ( model quot -- )
|
|
swap
|
|
t over set-model-locked?
|
|
slip
|
|
f swap set-model-locked? ; inline
|
|
|
|
GENERIC: update-model ( model -- )
|
|
|
|
M: model update-model drop ;
|
|
|
|
: notify-connections ( model -- )
|
|
dup model-connections [ model-changed ] with each ;
|
|
|
|
: set-model ( value model -- )
|
|
dup model-locked? [
|
|
2drop
|
|
] [
|
|
dup [
|
|
[ set-model-value ] keep
|
|
[ update-model ] keep
|
|
notify-connections
|
|
] with-locked-model
|
|
] if ;
|
|
|
|
: ((change-model)) ( model quot -- newvalue model )
|
|
over >r >r model-value r> call r> ; inline
|
|
|
|
: change-model ( model quot -- )
|
|
((change-model)) set-model ; inline
|
|
|
|
: (change-model) ( model quot -- )
|
|
((change-model)) set-model-value ; inline
|
|
|
|
GENERIC: range-value ( model -- value )
|
|
GENERIC: range-page-value ( model -- value )
|
|
GENERIC: range-min-value ( model -- value )
|
|
GENERIC: range-max-value ( model -- value )
|
|
GENERIC: range-max-value* ( model -- value )
|
|
GENERIC: set-range-value ( value model -- )
|
|
GENERIC: set-range-page-value ( value model -- )
|
|
GENERIC: set-range-min-value ( value model -- )
|
|
GENERIC: set-range-max-value ( value model -- )
|
|
|
|
: clamp-value ( value range -- newvalue )
|
|
[ range-min-value max ] keep
|
|
range-max-value* min ;
|