USING: arrays assocs.extras kernel math math.order sequences tools.test ;
+{
+ H{ { 1 V{ 10 } } { 2 V{ 10 } } { 3 V{ 10 } } { 4 V{ 10 } } { 5 V{ 10 } } }
+} [
+ H{ } clone 10 { 1 2 3 4 5 } pick push-at-each
+] unit-test
+
{ f } [ f { } deep-at ] unit-test
{ f } [ f { "foo" } deep-at ] unit-test
{ f } [ H{ } { 1 2 3 } deep-at ] unit-test
[ min ] V{ } assoc-collapse-as
] unit-test
+
{
- H{ { 1 V{ 10 } } { 2 V{ 10 } } { 3 V{ 10 } } { 4 V{ 10 } } { 5 V{ 10 } } }
+ H{
+ { 41 V{ 401 } }
+ { 10 V{ 100 } }
+ { 20 V{ 200 } }
+ { 30 V{ 300 } }
+ }
} [
- H{ } clone 10 { 1 2 3 4 5 } pick push-at-each
+ { { 10 100 } { 20 200 } { 30 300 } { 41 401 } }
+ [ ] collect-assoc-by
+] unit-test
+
+{
+ H{ { t V{ 100 200 300 } } { f V{ 401 } } }
+} [
+ { { 10 100 } { 20 200 } { 30 300 } { 41 401 } }
+ [ [ even? ] dip ] collect-assoc-by
+] unit-test
+
+{
+ H{
+ { t V{ { 10 100 } { 20 200 } { 30 300 } } }
+ { f V{ { 41 401 } } }
+ }
+} [
+ { { 10 100 } { 20 200 } { 30 300 } { 41 401 } }
+ [ [ drop even? ] [ 2array ] 2bi ] collect-assoc-by
+] unit-test
+
+{
+ H{ { t V{ 10 20 30 } } { f V{ 41 } } }
+} [
+ { { 10 100 } { 20 200 } { 30 300 } { 41 401 } }
+ [ even? ] collect-key-by
+] unit-test
+
+{
+ H{ { t V{ 100 200 300 } } { f V{ 401 } } }
+} [
+ { { 10 100 } { 20 200 } { 30 300 } { 41 401 } }
+ [ even? ] collect-value-by
] unit-test
+
{
H{
{ 1 V{ 10 20 30 40 50 60 } }
} [
{ 10 20 30 } [ drop { 1 2 3 4 5 } ] collect-by-multi
{ 40 50 60 } [ drop { 1 2 3 4 5 } ] collect-by-multi!
+] unit-test
+
+
+
+{
+ H{
+ { 20 V{ 20 } }
+ { 21 V{ 20 } }
+ { 41 V{ 41 } }
+ { 10 V{ 10 } }
+ { 11 V{ 10 } }
+ { 42 V{ 41 } }
+ { 30 V{ 30 } }
+ { 31 V{ 30 } }
+ }
+} [
+ { { 10 100 } { 20 200 } { 30 300 } { 41 401 } }
+ [ dup 1 + 2array ] collect-key-by-multi
+] unit-test
+
+
+{
+ H{
+ { 401 V{ 401 } }
+ { 402 V{ 401 } }
+ { 100 V{ 100 } }
+ { 101 V{ 100 } }
+ { 200 V{ 200 } }
+ { 201 V{ 200 } }
+ { 300 V{ 300 } }
+ { 301 V{ 300 } }
+ }
+} [
+ { { 10 100 } { 20 200 } { 30 300 } { 41 401 } }
+ [ dup 1 + 2array ] collect-value-by-multi
+] unit-test
+
+
+{
+ H{
+ { 20 V{ 200 } }
+ { 21 V{ 200 } }
+ { 41 V{ 401 } }
+ { 10 V{ 100 } }
+ { 11 V{ 100 } }
+ { 42 V{ 401 } }
+ { 30 V{ 300 } }
+ { 31 V{ 300 } }
+ }
+} [
+ { { 10 100 } { 20 200 } { 30 300 } { 41 401 } }
+ [ [ dup 1 + 2array ] dip ] collect-assoc-by-multi
] unit-test
\ No newline at end of file
: counts ( seq elts -- counts )
[ histogram ] dip intersect-keys ;
-: collect-key-by ( ... seq quot: ( ... obj -- ... key ) -- ... assoc )
- [ keep swap ] curry H{ } clone
- [ '[ @ [ first ] dip _ push-at ] each ] keep ; inline
-
-: collect-value-by ( ... seq quot: ( ... obj -- ... key ) -- ... assoc )
- [ keep swap ] curry H{ } clone
- [ '[ @ [ second ] dip _ push-at ] each ] keep ; inline
-
: histogram-diff ( hashtable1 hashtable2 -- hashtable3 )
[ neg swap pick at+ ] assoc-each
[ 0 > ] filter-values ;
-: collect-by-multi! ( ... assoc seq quot: ( ... obj -- ... key ) -- ... assoc )
+: collect-by-multi! ( ... assoc seq quot: ( ... obj -- ... new-keys ) -- ... assoc )
[ keep swap ] curry rot [
[ push-at-each ] curry compose each
] keep ; inline
-: collect-by-multi ( ... seq quot: ( ... obj -- ... keys ) -- ... assoc )
+: collect-by-multi ( ... seq quot: ( ... obj -- ... new-keys ) -- ... assoc )
[ H{ } clone ] 2dip collect-by-multi! ; inline
+
+
+: collect-assoc-by! ( ... assoc input-assoc quot: ( ... key value -- ... key' value' ) -- ... assoc )
+ rot [ '[ @ swap _ push-at ] assoc-each ] keep ; inline
+
+: collect-assoc-by ( ... input-assoc quot: ( ... key value -- ... key value ) -- ... assoc )
+ [ H{ } clone ] 2dip collect-assoc-by! ; inline
+
+: collect-key-by! ( ... assoc input-assoc quot: ( ... key -- ... new-key ) -- ... assoc )
+ rot [ '[ drop _ keep swap _ push-at ] assoc-each ] keep ; inline
+
+: collect-key-by ( ... input-assoc quot: ( ... key -- ... new-key ) -- ... assoc )
+ [ H{ } clone ] 2dip collect-key-by! ; inline
+
+: collect-value-by! ( ... assoc input-assoc quot: ( ... value -- ... new-key ) -- ... assoc )
+ rot [ '[ nip _ keep swap _ push-at ] assoc-each ] keep ; inline
+
+: collect-value-by ( ... input-assoc quot: ( ... value -- ... new-key ) -- ... assoc )
+ [ H{ } clone ] 2dip collect-value-by! ; inline
+
+
+: collect-assoc-by-multi! ( ... assoc input-assoc quot: ( ... key value -- ... new-keys value' ) -- ... assoc )
+ rot [ '[ @ swap _ B push-at-each ] assoc-each ] keep ; inline
+
+: collect-assoc-by-multi ( ... assoc quot: ( ... key value -- ... new-keys value' ) -- ... assoc )
+ [ H{ } clone ] 2dip collect-assoc-by-multi! ; inline
+
+: collect-key-by-multi! ( ... assoc input-assoc quot: ( ... key -- ... new-keys ) -- ... assoc )
+ rot [ '[ drop _ keep swap _ push-at-each ] assoc-each ] keep ; inline
+
+: collect-key-by-multi ( ... assoc quot: ( ... key -- ... new-keys ) -- ... assoc )
+ [ H{ } clone ] 2dip collect-key-by-multi! ; inline
+
+: collect-value-by-multi! ( ... assoc input-assoc quot: ( ... value -- ... new-keys ) -- ... assoc )
+ rot [ '[ nip _ keep swap _ push-at-each ] assoc-each ] keep ; inline
+
+: collect-value-by-multi ( ... assoc quot: ( ... value -- ... new-keys ) -- ... assoc )
+ [ H{ } clone ] 2dip collect-value-by-multi! ; inline