Working on UI dataflow code

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 <model> 2dup add-connection
-    3 swap set-model
-] unit-test
-
 [ T{ model-tester f t } ]
 [
     T{ model-tester f f } 3 <model> 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 <model> "x" set
+"x" get [ odd? ] <validator> "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

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 -- )
+GENERIC: set-model ( value model -- )
-    2dup model-value = [
+
-        2drop
+M: model set-model ( value model -- )
-    ] [
     [ set-model-value ] keep
-        model-connections [ model-changed ] each
+    model-connections [ model-changed ] each ;
-    ] if ;
 
 : 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 ;