From 55fb33f6e18ccab4ab338a94c7e52bc14c9dabe0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 31 Oct 2007 01:05:01 -0400
Subject: [PATCH] Mapping models

---
 extra/models/models-tests.factor | 33 +++++++++++++++++++++++++++++++-
 extra/models/models.factor       | 18 ++++++++++++++++-
 2 files changed, 49 insertions(+), 2 deletions(-)

diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor
index 8e970d82c6..97751c1858 100644
--- a/extra/models/models-tests.factor
+++ b/extra/models/models-tests.factor
@@ -1,6 +1,6 @@
 IN: temporary
 USING: arrays generic kernel math models namespaces sequences
-tools.test ;
+tools.test assocs ;
 
 TUPLE: model-tester hit? ;
 
@@ -106,3 +106,34 @@ f <history> "history" set
 [ { 4 5 } ] [ "c" get model-value ] unit-test
 
 [ ] [ "c" get deactivate-model ] unit-test
+
+! Test mapping
+[ ] [
+    [
+        1 <model> "one" set
+        2 <model> "two" set
+    ] H{ } make-assoc
+    <mapping> "m" set
+] unit-test
+
+[ ] [ "m" get activate-model ] unit-test
+
+[ H{ { "one" 1 } { "two" 2 } } ] [
+    "m" get model-value
+] unit-test
+
+[ ] [
+    H{ { "one" 3 } { "two" 4 } } 
+    "m" get set-model
+] unit-test
+
+[ H{ { "one" 3 } { "two" 4 } } ] [
+    "m" get model-value
+] unit-test
+
+[ H{ { "one" 5 } { "two" 4 } } ] [
+    5 "one" "m" get mapping-assoc at set-model
+    "m" get model-value
+] unit-test
+
+[ ] [ "m" get deactivate-model ] unit-test
diff --git a/extra/models/models.factor b/extra/models/models.factor
index 04ae639eff..59f888b0e0 100644
--- a/extra/models/models.factor
+++ b/extra/models/models.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: generic kernel math sequences timers arrays ;
+USING: generic kernel math sequences timers arrays assocs ;
 IN: models
 
 TUPLE: model value connections dependencies ref ;
@@ -109,6 +109,22 @@ M: compose model-activated model-changed ;
 
 M: compose set-model [ set-model ] set-composed-value ;
 
+TUPLE: mapping assoc ;
+
+: <mapping> ( models -- mapping )
+    f mapping construct-model
+    over values over set-model-dependencies
+    tuck set-mapping-assoc ;
+
+M: mapping model-changed
+    dup mapping-assoc [ model-value ] assoc-map
+    swap delegate set-model ;
+
+M: mapping model-activated model-changed ;
+
+M: mapping set-model
+    mapping-assoc [ swapd at set-model ] curry assoc-each ;
+
 TUPLE: history back forward ;
 
 : reset-history ( history -- )