write each-permutation word for random-tester

diff --git a/apps/random-tester/type.factor b/apps/random-tester/type.factor
index 20b2629c68ac5bf754064e7a89b8363f70cf5e28..731f52cec3925b92a9cf639d952692c9c90878dd 100644 (file)
--- a/apps/random-tester/type.factor
+++ b/apps/random-tester/type.factor
@@ -93,7 +93,7 @@ TUPLE: inert-object ;
     >r { no-method? no-math-method? } f r> reduce ;
 
 : maybe-explode
-    dup sequence? [ [ ] each ] when ;
+    dup sequence? [ [ ] each ] when ; inline
 
 SYMBOL: err
 SYMBOL: type-error

diff --git a/apps/random-tester/utils.factor b/apps/random-tester/utils.factor
index 190982798ff812e04e3511b1a2d1b0cc6801248d..34b69db33e1d7cc8da273a8917b4fef27222d208 100644 (file)
--- a/apps/random-tester/utils.factor
+++ b/apps/random-tester/utils.factor
@@ -19,9 +19,11 @@ IN: random-tester
 : zero-array
     [ drop 0 ] map ;
 
-TUPLE: p-list seq max counter ;
+TUPLE: p-list seq max count count-vec ;
 : make-p-list ( seq -- tuple )
-    dup length [ 1- ] keep zero-array <p-list> ;
+    dup length [ 1- ] keep
+    [ dup ^ 0 swap 2array ] keep
+    zero-array <p-list> ;
 
 : inc-seq ( seq max -- )
     2dup [ < ] curry find-last over -1 = [
@@ -31,13 +33,41 @@ TUPLE: p-list seq max counter ;
         1+ over length rot <slice> nzero-array
     ] if ;
 
+: inc-count ( tuple -- )
+    [ p-list-count first2 >r 1+ r> 2array ] keep
+    set-p-list-count ;
+
 : get-permutation ( tuple -- seq )
-    [ p-list-seq ] keep p-list-counter [ swap nth ] map-with ;
+    [ p-list-seq ] keep p-list-count-vec [ swap nth ] map-with ;
+
+: p-list-next ( tuple -- seq/f )
+    dup p-list-count first2 < [
+        [
+            [ get-permutation ] keep 
+            [ p-list-count-vec ] keep p-list-max
+            inc-seq
+        ] keep inc-count
+    ] [
+        drop f
+    ] if ;
 
-: p-list-next ( tuple -- seq )
-    [ get-permutation ] keep 
-    [ p-list-counter ] keep p-list-max inc-seq ;
+: (permutations) ( tuple -- )
+    dup p-list-next [ , (permutations) ] [ drop ] if* ;
 
 : permutations ( seq -- seq )
-    ;
+    make-p-list
+    [
+        (permutations)
+    ] { } make ;
+
+: (each-permutation) ( tuple quot -- )
+    over p-list-next [
+        [ rot drop swap call ] 3keep
+        drop (each-permutation)
+    ] [
+        2drop
+    ] if* ; inline
+
+: each-permutation ( seq quot -- )
+    >r make-p-list r> (each-permutation) ;