random-tester work-in-progress

apps/random-tester/hang.factor

@@ -0,0 +1,96 @@
+USING: errors generic io kernel lazy-lists math namespaces
+prettyprint random-tester2 sequences tools words ;
+IN: random-tester
+
+: inputs-exhaustive ( -- seq )
+    {
+        -100000000000000000
+        -1
+        0
+        1
+        100000000000000000
+
+        -29/2
+         100000000000000000/999999999999999999
+
+        -1/0.
+        -3.14
+        0.0
+        3.14
+        1/0.
+        0/0.
+
+        C{ 1 -1 }
+    } ;
+
+
+: inert ;
+TUPLE: inert-object ;
+
+: inputs ( -- seq )
+    {
+        0
+        ! -268435457
+        inert
+        T{ inert-object f }
+        -29/2
+        -3.14
+        C{ 1 -1 }
+        W{ 55 }
+        { }
+        f
+        H{ }
+        V{ }
+        ""
+        SBUF" "
+        [ ]
+        DLL" libm.dylib"
+        ALIEN: 1
+        T{ inert-object f }
+    } ;
+
+: cartesian-inputs ( n -- list )
+    >r inputs >list r>
+    1- [ drop inputs >list lcartesian-product ] each ;
+
+: word-inputs ( word -- seq )
+    stack-effect [ effect-in length ] [ drop 2 ] recover
+    cartesian-inputs list>array ;
+    
+: type-error? ( exception -- ? )
+    [ swap execute or ] curry
+    >r { no-method? no-math-method? } f r> reduce ;
+
+: maybe-explode
+    dup sequence? [ [ ] each ] when ;
+
+SYMBOL: err
+SYMBOL: type-error
+SYMBOL: params
+: throws? ( data... quot -- ? )
+    err off type-error off
+    >r
+        dup clone params set
+        maybe-explode
+    r>
+     "<<<<<testing" .
+     .s
+        3dup . . .
+     "-----" . flush
+    [ call ] [ err on ] recover
+     .s
+     ">>>>>tested" .
+    err get [
+        dup type-error? dup [
+            .s
+        ] unless
+        type-error set
+    ] when clear type-error get
+    ;
+
+: test-inputs ( word -- seq )
+    [ word-inputs ] keep
+    unit [
+        throws? not
+    ] curry map ;
+

apps/random-tester/load.factor

@@ -1,7 +1,9 @@
+REQUIRES: libs/lazy-lists libs/shuffle ;
 PROVIDE: apps/random-tester
 { +files+ {
     "utils.factor"
     "random.factor"
     "random-tester.factor"
     "random-tester2.factor"
+    "type.factor"
 } } ;

apps/random-tester/random-tester2.factor

@@ -167,3 +167,4 @@ err off
     100 random-int zero? [ code-gc ] when
     compile fooify ;
 
+

apps/random-tester/type.factor

@@ -0,0 +1,126 @@
+USING: errors generic io kernel lazy-lists math namespaces
+prettyprint random-tester2 sequences tools words ;
+IN: random-tester
+
+: inputs-exhaustive ( -- seq )
+    {
+        -100000000000000000
+        -1
+        0
+        1
+        100000000000000000
+
+        -29/2
+         100000000000000000/999999999999999999
+
+        -1/0.
+        -3.14
+        0.0
+        3.14
+        1/0.
+        0/0.
+
+        C{ 1 -1 }
+    } ;
+
+
+: inert ;
+TUPLE: inert-object ;
+
+: inputs ( -- seq )
+    {
+        0
+        ! -268435457
+        inert
+        ! T{ inert-object f }
+        -29/2
+        -3.14
+        C{ 1 -1 }
+        W{ 55 }
+        { }
+        f
+        H{ }
+        V{ }
+        ""
+        SBUF" "
+        [ ]
+        DLL" libm.dylib"
+        ALIEN: 1
+        T{ inert-object f }
+    } ;
+
+: make-inputs
+    [
+        0 ,
+        ! ! -268435457 ,
+        \ inert ,
+        ! ! T{ inert-object f } ,
+        -29/2 ,
+        -3.14 ,
+        C{ 1 -1 } ,
+        W{ 55 } clone ,
+        { } clone ,
+        f ,
+        H{ } clone ,
+        V{ } clone ,
+        "" ,
+        SBUF" " clone ,
+        [ ] clone ,
+        DLL" libm.dylib" clone ,
+        ALIEN: 1 ,
+        T{ inert-object f } ,
+    ] { } make ;
+
+! : cartesian-inputs ( n -- list )
+    ! >r make-inputs >list r>
+    ! 1- [ drop make-inputs >list lcartesian-product ] each ;
+
+: cartesian-inputs ( n -- list )
+    dup 2 > [
+        drop { } >list
+    ] [
+        >r make-inputs >list r>
+        1- [ drop make-inputs >list lcartesian-product ] each
+    ] if ;
+
+
+: word-inputs ( word -- seq )
+    [ stack-effect effect-in length ] [ drop 0 ] recover
+    cartesian-inputs list>array ;
+    
+: type-error? ( exception -- ? )
+    [ swap execute or ] curry
+    >r { no-method? no-math-method? } f r> reduce ;
+
+: maybe-explode
+    dup sequence? [ [ ] each ] when ;
+
+SYMBOL: err
+SYMBOL: type-error
+SYMBOL: params
+: throws? ( data... quot -- ? )
+    err off type-error off
+    >r
+        dup clone params set
+        maybe-explode
+    r>
+     "<<<<<testing" .
+     .s
+     "-----" . flush
+    [ call ] [ err on ] recover
+     .s
+     ">>>>>tested" .
+    err get [
+        dup type-error? dup [
+            .s
+        ] unless
+        type-error set
+    ] when clear type-error get
+    ;
+
+: test-inputs ( word -- seq )
+    [ word-inputs ] keep
+    unit [
+        throws? not
+    ] curry map ;
+

apps/random-tester/utils.factor

@@ -1,6 +1,6 @@
 USING: kernel math sequences namespaces errors hashtables words
-arrays parser compiler syntax io optimizer inference tools
+arrays parser compiler syntax io optimizer inference shuffle
-prettyprint ;
+tools prettyprint ;
 IN: random-tester
 
 : pick-one ( seq -- elt )
@@ -12,3 +12,32 @@ IN: random-tester
 
 : coin-flip ( -- bool ) 2 random-int zero? ;
 : do-one ( seq -- ) pick-one call ; inline
+
+: nzero-array ( seq -- )
+    dup length >r 0 r> [ pick set-nth ] each-with drop ;
+    
+: zero-array
+    [ drop 0 ] map ;
+
+TUPLE: p-list seq max counter ;
+: make-p-list ( seq -- tuple )
+    dup length [ 1- ] keep zero-array <p-list> ;
+
+: inc-seq ( seq max -- )
+    2dup [ < ] curry find-last over -1 = [
+        3drop nzero-array
+    ] [
+        nipd 1+ 2over swap set-nth
+        1+ over length rot <slice> nzero-array
+    ] if ;
+
+: get-permutation ( tuple -- seq )
+    [ p-list-seq ] keep p-list-counter [ swap nth ] map-with ;
+
+: p-list-next ( tuple -- seq )
+    [ get-permutation ] keep 
+    [ p-list-counter ] keep p-list-max inc-seq ;
+
+: permutations ( seq -- seq )
+    ;
+