assocs: adding ?change-at.

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 } }

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

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