From 026844fa9ea2c75164b307d337b94f4893bda4a2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Feb 2023 12:20:42 -0600 Subject: [PATCH] assocs: move some -of words to extras --- core/assocs/assocs-tests.factor | 40 ------------------------ core/assocs/assocs.factor | 17 ---------- extra/assocs/extras/extras-tests.factor | 41 +++++++++++++++++++++++++ extra/assocs/extras/extras.factor | 17 ++++++++++ 4 files changed, 58 insertions(+), 57 deletions(-) diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 2ace53d834..931da8f2e0 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -345,43 +345,3 @@ 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 - -{ H{ { 1 100 } } } [ - H{ } clone 1 100 set-of -] 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 d44e22d912..7b7018e400 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -36,10 +36,6 @@ M: assoc assoc-like drop ; inline : 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 ; - 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 -: at+* ( n key assoc -- old new ) [ 0 or [ + ] keep swap dup ] change-at ; inline - : inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline -: inc-at* ( key assoc -- old new ) [ 1 ] 2dip at+* ; inline - : map>assoc ( ... seq quot: ( ... elt -- ... key value ) exemplar -- ... assoc ) dup sequence? [ [ [ 2array ] compose ] dip map-as @@ -247,9 +233,6 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ; : push-at ( value key assoc -- ) [ ?push ] change-at ; -: push-of ( assoc key value -- assoc ) - swap pick push-at ; inline - : zip-as ( keys values exemplar -- assoc ) dup sequence? [ [ 2array ] swap 2map-as diff --git a/extra/assocs/extras/extras-tests.factor b/extra/assocs/extras/extras-tests.factor index 22e7ec8f17..2ca1b4cd67 100644 --- a/extra/assocs/extras/extras-tests.factor +++ b/extra/assocs/extras/extras-tests.factor @@ -321,3 +321,44 @@ USING: arrays assocs.extras kernel math math.order sequences tools.test ; H{ { 1 2 } { 3 4 } { 5 6 } } { 1 3 } { } intersect-keys-as ] unit-test + + +{ H{ { 1 100 } } } [ + H{ } clone 1 100 set-of +] 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/extra/assocs/extras/extras.factor b/extra/assocs/extras/extras.factor index b49983def2..adf8ceb81a 100644 --- a/extra/assocs/extras/extras.factor +++ b/extra/assocs/extras/extras.factor @@ -21,10 +21,27 @@ IN: assocs.extras : rename-of ( assoc key newkey -- assoc ) [ delete-of* ] dip swap [ set-of ] [ 2drop ] if ; +: at+* ( n key assoc -- old new ) [ 0 or [ + ] keep swap dup ] change-at ; inline + +: inc-at* ( key assoc -- old new ) [ 1 ] 2dip at+* ; inline + : inc-of ( assoc key -- assoc ) 1 of+ ; inline : inc-of* ( assoc key -- assoc old new ) 1 of+* ; 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 + +: maybe-set-of ( assoc key value -- assoc changed? ) + [ 2dup ?of ] dip swap + [ dupd = [ 2drop f ] [ set-of t ] if ] [ nip set-of t ] if ; + +: push-of ( assoc key value -- assoc ) + swap pick push-at ; inline + : push-at-each ( value keys assoc -- ) '[ _ push-at ] with each ; inline -- 2.34.1