assocs.extras: Add assoc-collapse! and assoc-collapse-as

`assoc-collapse!` is the destructive version of `assoc-collapse`, but takes the
target assoc as extra element.

For `assoc-collapse-as`, the size of resulting assoc is based on the first assoc
in the input sequence.

diff --git a/extra/assocs/extras/extras-tests.factor b/extra/assocs/extras/extras-tests.factor
index 276005980c7ca787e1d26dcf8b8ca8ac7611e58c..a4d7a08efd8edb24e0de631477f2667993bea9d8 100644 (file)
--- a/extra/assocs/extras/extras-tests.factor
+++ b/extra/assocs/extras/extras-tests.factor
@@ -145,3 +145,22 @@ USING: arrays assocs.extras kernel math math.order sequences tools.test ;
     H{ { 3 30 } { 4 40 } } 3array
     [ min ] assoc-collapse
 ] unit-test
+
+{
+    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
+
+{
+    H{ { 1 11 } { 2 20 } }
+    V{ { 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 ] V{ } assoc-collapse-as
+] unit-test

diff --git a/extra/assocs/extras/extras.factor b/extra/assocs/extras/extras.factor
index 44b076817967dc63689f19d8e21c56380b550fe2..7abad29da3f2379d973d3440e589547d32450d86 100644 (file)
--- a/extra/assocs/extras/extras.factor
+++ b/extra/assocs/extras/extras.factor
@@ -82,6 +82,13 @@ IN: assocs.extras
     [ 2drop f ]
     [ [ unclip-slice H{ } or clone ] [ [ assoc-merge! ] curry ] bi* reduce ] if ; inline
 
+: assoc-collapse! ( assoc seq quot: ( value1 value2 -- new-value ) -- assoc )
+    [ assoc-merge! ] curry each ; inline
+
+: assoc-collapse-as ( seq quot: ( value1 value2 -- new-value ) exemplar -- assoc )
+    pick first assoc-size swap new-assoc
+    -rot assoc-collapse! ; inline
+
 GENERIC: delete-value-at ( value assoc -- )
 
 M: assoc delete-value-at