From 6688cf1c9779dce87529392f3bbdcdcabcd81baa Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 26 Apr 2009 08:42:31 -0500
Subject: [PATCH 1/2] mopping up some noobsauce
---
extra/roles/roles.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/roles/roles.factor b/extra/roles/roles.factor
index f9ce808eb8..d54b4339a7 100644
--- a/extra/roles/roles.factor
+++ b/extra/roles/roles.factor
@@ -8,8 +8,8 @@ IN: roles
ERROR: role-slot-overlap class slots ;
ERROR: multiple-inheritance-attempted classes ;
-PREDICATE: role < class
- { [ mixin-class? ] [ "role-slots" word-prop >boolean ] } 1&& ;
+PREDICATE: role < mixin-class
+ "role-slots" word-prop >boolean ;
: parse-role-definition ( -- class superroles slots )
CREATE-CLASS scan {
From d2e293eb5ea779d2bfbbde84b76009748ab8de6b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 26 Apr 2009 09:39:38 -0500
Subject: [PATCH 2/2] product virtual sequence
---
extra/sequences/product/product-tests.factor | 24 ++++++++++-------
extra/sequences/product/product.factor | 28 ++++++++++++++++++++
2 files changed, 42 insertions(+), 10 deletions(-)
create mode 100644 extra/sequences/product/product.factor
diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor
index dfabc166ac..0a984072e0 100644
--- a/extra/sequences/product/product-tests.factor
+++ b/extra/sequences/product/product-tests.factor
@@ -1,19 +1,23 @@
-USING: arrays kernel sequences sequences.cartesian-product tools.test ;
+USING: arrays kernel make sequences sequences.product tools.test ;
IN: sequences.product.tests
-[
- { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } }
-] [ { { 0 1 2 } { "a" "b" } } [ ] cartesian-product-map ] unit-test
+
+[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
+[ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
+
+[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
+[ { { 0 1 2 } { "a" "b" } } [ ] product-map ] unit-test
[
{
{ 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t }
{ 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f }
}
-] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] cartesian-product-map ] unit-test
-
-[
- { "012012" "aaabbb" }
-] [ { { "0" "1" "2" } { "a" "b" } } [ [ first2 ] bi* [ append ] bi@ 2array ] cartesian-product-each ] unit-test
-
+] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test
+[ "a1b1c1a2b2c2" ] [
+ [
+ { { "a" "b" "c" } { "1" "2" } }
+ [ [ % ] each ] product-each
+ ] "" make
+] unit-test
diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor
new file mode 100644
index 0000000000..73ba1e4e01
--- /dev/null
+++ b/extra/sequences/product/product.factor
@@ -0,0 +1,28 @@
+USING: accessors arrays kernel math sequences ;
+IN: sequences.product
+
+TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
+
+: <product-sequence> ( sequences -- product-sequence )
+ >array dup [ length ] map product-sequence boa ;
+
+INSTANCE: product-sequence sequence
+
+M: product-sequence length lengths>> product ;
+
+: ns ( n lengths -- ns )
+ [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
+
+: product@ ( n product-sequence -- ns seqs )
+ [ lengths>> ns ] [ nip sequences>> ] 2bi ;
+
+M: product-sequence nth
+ product@ [ nth ] { } 2map-as ;
+
+M: product-sequence set-nth
+ immutable ;
+
+: product-map ( sequences quot -- sequence )
+ [ <product-sequence> ] dip map ; inline
+: product-each ( sequences quot -- )
+ [ <product-sequence> ] dip each ; inline