assocs: Add a bunch of `of` words

diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index 32305d1f375012a8ce830d10fc133d12e1c08c46..2ace53d834547037fd324e24fc10b3b9b88284bc 100644 (file)
--- a/core/assocs/assocs-tests.factor
+++ b/core/assocs/assocs-tests.factor
@@ -353,3 +353,35 @@ unit-test
 { H{ { 1 V{ 100 200 } } } } [
     H{ } clone 1 100 push-of 1 200 push-of
 ] unit-test
+
+{ H{ { 123 556 } } } [
+    H{ { 123 456 } } 123 [ 100 + ] change-of
+] unit-test
+
+{ H{ { 123 556 } } } [
+    H{ { 123 456 } } 123 [ 100 + ] ?change-of
+] unit-test
+
+{ H{ { 123 456 } } } [
+    H{ { 123 456 } } 1234 [ 100 + ] ?change-of
+] unit-test
+
+{ H{ { 10 2 } } } [
+    H{ { 10 1 } } 10 inc-of
+] unit-test
+
+{ H{ { 10 1001 } } } [
+    H{ { 10 1 } } 10 1000 of+
+] unit-test
+
+{ H{ { 1 100 } } f } [
+    H{ { 1 100 } } 1 100 maybe-set-of
+] unit-test
+
+{ H{ { 1 100 } { 2 100 } } t } [
+    H{ { 1 100 } } 2 100 maybe-set-of
+] unit-test
+
+{ H{ { 1 100 } } t } [
+    H{ { 1 100 } } 1 101 maybe-set-of
+] unit-test
\ No newline at end of file

diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 699a7830ad8761d770b75d167db2ee68405526b1..6cebc35f87a255791abf1d7de1c443aea0a62448 100644 (file)
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -25,12 +25,19 @@ M: assoc assoc-like drop ; inline
 : ?at ( key assoc -- value/key ? )
     2dup at* [ 2nip t ] [ 2drop f ] if ; inline
 
+: ?of ( assoc key -- value/key ? )
+    swap ?at ; inline
+
 : maybe-set-at ( value key assoc -- changed? )
     3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
 
 : set-of ( assoc key value -- assoc )
     swap pick set-at ; inline
 
+: maybe-set-of ( assoc key value -- assoc changed? )
+    [ 2dup ?of ] dip swap
+    [ dupd = [ 2drop f ] [ set-of t ] if ] [ nip set-of t ] if ;
+
 <PRIVATE
 
 : assoc-operator ( assoc quot -- alist quot' )
@@ -118,9 +125,6 @@ PRIVATE>
 : at ( key assoc -- value/f )
     at* drop ; inline
 
-: ?of ( assoc key -- value/key ? )
-    swap ?at ; inline
-
 : of ( assoc key -- value/f )
     swap at ; inline
 
@@ -160,7 +164,7 @@ M: assoc values [ nip ] { } assoc>map ;
     swap [ nip key? ] curry assoc-filter ;
 
 : assoc-union! ( assoc1 assoc2 -- assoc1 )
-    over [ set-at ] with-assoc assoc-each ;
+    [ set-of ] assoc-each ; inline
 
 : assoc-union-as ( assoc1 assoc2 exemplar -- union )
     [ [ [ assoc-size ] bi@ + ] dip new-assoc ] 2keepd
@@ -202,10 +206,20 @@ M: assoc values [ nip ] { } assoc>map ;
 : ?change-at ( ..a key assoc quot: ( ..a value -- ..b newvalue ) -- ..b )
     2over [ set-at ] 2curry compose [ at* ] dip [ drop ] if ; inline
 
+: change-of ( ..a assoc key quot: ( ..a value -- ..b newvalue ) -- ..b assoc )
+    [ [ of ] dip call ] 2keepd rot set-of ; inline
+
+: ?change-of ( ..a assoc key quot: ( ..a value -- ..b newvalue ) -- ..b assoc )
+    [ set-of ] compose [ 2dup ?of ] dip [ 2drop ] if ; inline
+
 : at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
 
 : inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline
 
+: of+ ( assoc key n -- assoc ) '[ 0 or _ + ] change-of ; inline
+
+: inc-of ( assoc key -- assoc ) 1 of+ ; inline
+
 : map>assoc ( ... seq quot: ( ... elt -- ... key value ) exemplar -- ... assoc )
     dup sequence? [
         [ [ 2array ] compose ] dip map-as