assocs: adding ?change-at.

diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index 384f0a79b70f713a9628a20a4f60b7ad98a4a5da..12f9c5becd08ce639770b3088017c547605fe87e 100644 (file)
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -481,7 +481,12 @@ HELP: change-at
 { $description "Applies the quotation to the value associated with " { $snippet "key" } ", storing the new value back in the assoc." }
 { $side-effects "assoc" } ;
 
-{ change-at change-nth change } related-words
+HELP: ?change-at
+{ $values { "key" object } { "assoc" assoc } { "quot" { $quotation ( ..a value -- ..b newvalue ) } } }
+{ $description "If the " { $snippet "key" } " exists in the " { $snippet "assoc" } ", applies the quotation to the value associated with " { $snippet "key" } ", storing the new value back in the assoc." }
+{ $side-effects "assoc" } ;
+
+{ change-at ?change-at change-nth change } related-words
 
 HELP: at+
 { $values { "n" number } { "key" object } { "assoc" assoc } }

diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index c56edcc671cdc70a5b57dd023dca1f122a6e0ace..be72d223cb6036f91cb3592ca5eb6115edb7a04e 100644 (file)
--- a/core/assocs/assocs-tests.factor
+++ b/core/assocs/assocs-tests.factor
@@ -317,3 +317,7 @@ unit-test
 } [
     10 <iota> [ 3 mod ] collect-by
 ] unit-test
+
+{ H{ { 1 4 } } } [ H{ { 1 2 } } 1 over [ sq ] ?change-at ] unit-test
+{ H{ { 1 2 } } } [ H{ { 1 2 } } 2 over [ sq ] ?change-at ] unit-test
+{ H{ { 1 3 } } } [ H{ { 1 2 } } 3 1 pick [ drop dup ] ?change-at drop ] unit-test

diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 515fdcb26ee3aca8c17fdbd0444e23f7b9d4f688..7ab32dc83bfb988ceaa94befb5fc89b67e950b04 100644 (file)
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -195,6 +195,9 @@ M: assoc values [ nip ] { } assoc>map ;
 : change-at ( ..a key assoc quot: ( ..a value -- ..b newvalue ) -- ..b )
     [ [ at ] dip call ] [ drop ] 3bi set-at ; inline
 
+: ?change-at ( ..a key assoc quot: ( ..a value -- ..b newvalue ) -- ..b )
+    2over [ set-at ] 2curry compose [ at* ] dip [ drop ] if ; inline
+
 : at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
 
 : inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline