assocs: more work on -of words

diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index b22c299e6be9cd17610ba8ca74fa0efbf347d10b..2ace53d834547037fd324e24fc10b3b9b88284bc 100644 (file)
--- a/core/assocs/assocs-tests.factor
+++ b/core/assocs/assocs-tests.factor
@@ -355,23 +355,23 @@ unit-test
 ] unit-test
 
 { H{ { 123 556 } } } [
-    H{ { 123 456 } } dup 123 [ 100 + ] change-of
+    H{ { 123 456 } } 123 [ 100 + ] change-of
 ] unit-test
 
 { H{ { 123 556 } } } [
-    H{ { 123 456 } } dup 123 [ 100 + ] ?change-of
+    H{ { 123 456 } } 123 [ 100 + ] ?change-of
 ] unit-test
 
 { H{ { 123 456 } } } [
-    H{ { 123 456 } } dup 1234 [ 100 + ] ?change-of
+    H{ { 123 456 } } 1234 [ 100 + ] ?change-of
 ] unit-test
 
 { H{ { 10 2 } } } [
-    H{ { 10 1 } } dup 10 inc-of
+    H{ { 10 1 } } 10 inc-of
 ] unit-test
 
 { H{ { 10 1001 } } } [
-    H{ { 10 1 } } dup 10 1000 of+
+    H{ { 10 1 } } 10 1000 of+
 ] unit-test
 
 { H{ { 1 100 } } f } [

diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 92019367a2f22914baf02a2197d62aa2a9fc013e..c112f54004010828b6375cdc6ecfdf3a96839fae 100644 (file)
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -22,6 +22,12 @@ GENERIC: unzip ( assoc -- keys values )
 
 M: assoc assoc-like drop ; inline
 
+: key? ( key assoc -- ? ) at* nip ; inline
+
+: delete-of ( assoc key -- assoc ) over delete-at ; inline
+
+: of* ( assoc key -- value/f ? ) swap at* ; inline
+
 : ?at ( key assoc -- value/key ? )
     2dup at* [ 2nip t ] [ 2drop f ] if ; inline
 
@@ -43,6 +49,9 @@ M: assoc assoc-like drop ; inline
 : assoc-operator ( assoc quot -- alist quot' )
     [ >alist ] dip [ first2 ] prepose ; inline
 
+: assoc-operator* ( assoc quot -- alist quot' )
+    [ >alist ] dip [ first2 swap ] prepose ; inline
+
 : assoc-stack-from ( key i seq -- value/f )
     over 0 < [
         3drop f
@@ -62,11 +71,12 @@ PRIVATE>
 : assoc-find ( ... assoc quot: ( ... key value -- ... ? ) -- ... key value ? )
     assoc-operator find swap [ first2-unsafe t ] [ drop f f f ] if ; inline
 
-: key? ( key assoc -- ? ) at* nip ; inline
-
 : assoc-each ( ... assoc quot: ( ... key value -- ... ) -- ... )
     assoc-operator each ; inline
 
+: assoc-each* ( ... assoc quot: ( ... value key -- ... ) -- ... )
+    assoc-operator* each ; inline
+
 : assoc>map ( ... assoc quot: ( ... key value -- ... elt ) exemplar -- ... seq )
     [ assoc-operator ] dip map-as ; inline
 
@@ -137,10 +147,19 @@ M: assoc keys [ drop ] { } assoc>map ;
 M: assoc values [ nip ] { } assoc>map ;
 
 : delete-at* ( key assoc -- value/f ? )
-    [ at* ] 2keep delete-at ;
+    [ at* ] [ delete-at ] 2bi ;
 
 : ?delete-at ( key assoc -- value/key ? )
-    [ ?at ] 2keep delete-at ;
+    [ ?at ] [ delete-at ] 2bi ;
+
+: delete-of* ( assoc key -- assoc value/f ? )
+    [ of* ] [ delete-of -rot ] 2bi ;
+
+: ?delete-of ( assoc key -- assoc value/key ? )
+    [ ?of ] [ delete-of -rot ] 2bi ;
+
+: rename-of ( assoc key newkey -- assoc )
+    [ delete-of* ] dip swap [ set-of ] [ 2drop ] if ;
 
 : rename-at ( newkey key assoc -- )
     [ delete-at* ] keep [ set-at ] with-assoc [ 2drop ] if ;
@@ -206,11 +225,11 @@ 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 )
-    [ [ of ] dip call ] 2keepd rot set-of drop ; 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 )
-    [ set-of drop ] compose [ 2dup ?of ] dip [ 3drop ] if ; 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
 
@@ -220,13 +239,13 @@ M: assoc values [ nip ] { } assoc>map ;
 
 : inc-at* ( key assoc -- old new ) [ 1 ] 2dip at+* ; inline
 
-: of+ ( assoc key n -- ) '[ 0 or _ + ] change-of ; inline
+: of+ ( assoc key n -- assoc ) '[ 0 or _ + ] change-of ; inline
 
-: of+* ( assoc key n -- old new ) '[ [ 0 or _ + ] keep swap dup ] change-of ; inline
+: of+* ( assoc key n -- assoc old new ) '[ [ 0 or _ + ] keep swap dup ] change-of ; inline
 
-: inc-of ( assoc key -- ) 1 of+ ; inline
+: inc-of ( assoc key -- assoc ) 1 of+ ; inline
 
-: inc-of* ( assoc key -- old new ) 1 of+* ; inline
+: inc-of* ( assoc key -- assoc old new ) 1 of+* ; inline
 
 : map>assoc ( ... seq quot: ( ... elt -- ... key value ) exemplar -- ... assoc )
     dup sequence? [