diff --git a/library/test/gadgets/models.factor b/library/test/gadgets/models.factor index d4a15a903a..995ad15949 100644 --- a/library/test/gadgets/models.factor +++ b/library/test/gadgets/models.factor @@ -8,12 +8,6 @@ C: model-tester ; M: model-tester model-changed t swap set-model-tester-hit? ; -[ T{ model-tester f f } ] -[ - T{ model-tester f f } 3 2dup add-connection - 3 swap set-model -] unit-test - [ T{ model-tester f t } ] [ T{ model-tester f f } 3 2dup add-connection @@ -80,3 +74,28 @@ T{ model-tester f f } "tester" set [ 9 ] [ "y" get model-value ] unit-test [ ] [ "y" get deactivate-model ] unit-test [ f ] [ "z" get "x" get model-connections memq? ] unit-test + +! Test validators +3 "x" set +"x" get [ odd? ] "y" set +"y" get activate-model + +[ 3 ] [ "y" get model-value ] unit-test + +4 "x" get set-model + +[ 3 ] [ "y" get model-value ] unit-test + +5 "x" get set-model + +[ 5 ] [ "y" get model-value ] unit-test + +6 "y" get set-model + +[ 5 ] [ "x" get model-value ] unit-test +[ 5 ] [ "y" get model-value ] unit-test + +7 "y" get set-model + +[ 7 ] [ "x" get model-value ] unit-test +[ 7 ] [ "y" get model-value ] unit-test diff --git a/library/ui/models.factor b/library/ui/models.factor index bdc7cfcf49..e1393073a5 100644 --- a/library/ui/models.factor +++ b/library/ui/models.factor @@ -5,8 +5,6 @@ USING: generic kernel math sequences ; TUPLE: model connections value dependencies ref ; -M: model = eq? ; - C: model ( value -- model ) [ set-model-value ] keep V{ } clone over set-model-connections @@ -56,13 +54,11 @@ GENERIC: model-changed ( observer -- ) dup model-connections empty? [ dup deactivate-model ] when drop ; -: set-model ( value model -- ) - 2dup model-value = [ - 2drop - ] [ - [ set-model-value ] keep - model-connections [ model-changed ] each - ] if ; +GENERIC: set-model ( value model -- ) + +M: model set-model ( value model -- ) + [ set-model-value ] keep + model-connections [ model-changed ] each ; : change-model ( model quot -- ) over >r >r model-value r> call r> set-model ; inline @@ -83,6 +79,30 @@ M: filter model-changed ( filter -- ) dup filter-model model-value over filter-quot call swap set-model ; +TUPLE: validator model quot ; + +C: validator ( model quot -- filter ) + dup delegate>model + [ set-validator-quot ] keep + [ set-validator-model ] 2keep + [ add-dependency ] keep + dup model-changed ; + +M: validator model-changed ( validator -- ) + dup validator-model model-value dup + pick validator-quot call [ + swap delegate set-model + ] [ + 2drop + ] if ; + +M: validator set-model ( value validator -- ) + 2dup validator-quot call [ + validator-model set-model + ] [ + 2drop + ] if ; + TUPLE: compose ; C: compose ( models -- compose ) @@ -92,7 +112,10 @@ C: compose ( models -- compose ) M: compose model-changed ( compose -- ) dup model-dependencies [ model-value ] map - swap set-model ; + swap delegate set-model ; + +M: compose set-model ( value compose -- ) + model-dependencies [ set-model ] 2map ; TUPLE: history back forward ;