assocs.extras: Combinator for merging two assocs, rename assoc-merge

Renamed `assoc-merge` to `assoc-collect`, and introduced `assoc-merge` as
combinator to combine two assocs, specifying a quotation in case there is a
value for a certain key in both. `assoc-collapse` is the reducing version.

diff --git a/extra/assocs/extras/extras-tests.factor b/extra/assocs/extras/extras-tests.factor
index 23dd663aff2cf6793a9c34644478ad641fa21ac5..e14ef76a9444938246efb23d087b47e59bcd809a 100644 (file)
--- a/extra/assocs/extras/extras-tests.factor
+++ b/extra/assocs/extras/extras-tests.factor
@@ -1,4 +1,4 @@
-USING: assocs.extras kernel math sequences tools.test ;
+USING: arrays assocs.extras kernel math math.order sequences tools.test ;
 
 { f } [ f { } deep-at ] unit-test
 { f } [ f { "foo" } deep-at ] unit-test
@@ -12,7 +12,7 @@ USING: assocs.extras kernel math sequences tools.test ;
 { H{ { "a" V{ 2 5 } } { "b" V{ 3 } } { "c" V{ 10 } } } }
 [
     { H{ { "a" 2 } { "b" 3 } } H{ { "a" 5 } { "c" 10 } } }
-    [ ] [ assoc-merge ] map-reduce
+    [ ] [ assoc-collect ] map-reduce
 ] unit-test
 
 { H{ } } [ H{ { 1 2 } } 2 over delete-value-at ] unit-test
@@ -80,4 +80,59 @@ USING: assocs.extras kernel math sequences tools.test ;
 { t } [
     H{ { "1" 1 } { "2" 2 } { "3" 3 } }
     [ { "1" "2" "2" } rekey-assoc ] keep eq?
-] unit-test
\ No newline at end of file
+] unit-test
+
+{ H{ { 1 11 } { 2 22 } { 3 33 } } } [
+    H{ { 1 11 } { 2 20 } }
+    H{ { 2 22 } { 3 33 } }
+    [ max ] assoc-merge
+] unit-test
+
+{ H{ { 1 11 } { 2 22 } { 3 33 } } } [
+    H{ { 2 22 } { 3 33 } }
+    H{ { 1 11 } { 2 20 } }
+    [ max ] assoc-merge
+] unit-test
+
+{ H{ { 1 11 } { 2 20 } { 3 33 } } } [
+    H{ { 1 11 } { 2 20 } }
+    H{ { 2 22 } { 3 33 } }
+    [ min ] assoc-merge
+] unit-test
+
+{ f } [ f f [ min ] assoc-merge ] unit-test
+
+! Ensure non-destructive
+{
+    H{ { 1 11 } { 2 20 } }
+    H{ { 2 22 } { 3 33 } }
+    H{ { 1 11 } { 2 20 } { 3 33 } }
+} [
+    H{ { 1 11 } { 2 20 } }
+    H{ { 2 22 } { 3 33 } } 2dup
+    [ min ] assoc-merge
+] unit-test
+
+! Ensure destructive
+{
+    H{ { 1 11 } { 2 20 } { 3 33 } }
+    H{ { 2 22 } { 3 33 } }
+    H{ { 1 11 } { 2 20 } { 3 33 } }
+} [
+    H{ { 1 11 } { 2 20 } }
+    H{ { 2 22 } { 3 33 } } 2dup
+    [ min ] assoc-merge!
+] unit-test
+
+! assoc-collapse
+{ f } [ f [ min ] assoc-collapse ] unit-test
+
+{
+    H{ { 1 11 } { 2 20 } }
+    H{ { 1 11 } { 2 20 } { 3 30 } { 4 40 } }
+} [
+    H{ { 1 11 } { 2 20 } } dup
+    H{ { 2 22 } { 3 33 } }
+    H{ { 3 30 } { 4 40 } } 3array
+    [ min ] assoc-collapse
+] unit-test

diff --git a/extra/assocs/extras/extras.factor b/extra/assocs/extras/extras.factor
index 9ae550a3d5d092f416251f642a04586023b483c4..b13bd21f182f58ad974de8ae2aa460025b60e831 100644 (file)
--- a/extra/assocs/extras/extras.factor
+++ b/extra/assocs/extras/extras.factor
@@ -56,12 +56,31 @@ IN: assocs.extras
 : assoc-invert ( assoc -- newassoc )
     dup assoc-invert-as ;
 
-: assoc-merge! ( assoc1 assoc2 -- assoc1 )
+: assoc-collect! ( assoc1 assoc2 -- assoc1 )
     over [ push-at ] with-assoc assoc-each ;
 
-: assoc-merge ( assoc1 assoc2 -- newassoc )
+: assoc-collect ( assoc1 assoc2 -- newassoc )
     [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
-    [ assoc-merge! ] bi@ ;
+    [ assoc-collect! ] bi@ ;
+
+! iterate over assoc2, replace conflicting values
+! Modifies assoc1
+: assoc-merge! ( assoc1 assoc2 quot: ( value1 value2 -- new-value ) -- assoc1' )
+    [| key2 val2 quot | val2 key2 pick
+     at* [ swap quot call ] [ drop ] if
+     key2 pick set-at ] curry assoc-each ; inline
+
+! Same as above, non-destructive
+: assoc-merge ( assoc1 assoc2 quot: ( value1 value2 -- new-value ) -- new-assoc )
+    pick [ [ clone ] 2dip assoc-merge! ]
+    [ drop nip ] if
+    ; inline
+
+! Successively apply assoc-merge operation
+: assoc-collapse ( seq quot: ( value1 value2 -- new-value ) -- assoc )
+    over empty?
+    [ 2drop f ]
+    [ [ unclip-slice clone ] [ [ assoc-merge! ] curry ] bi* reduce ] if ; inline
 
 GENERIC: delete-value-at ( value assoc -- )