factor/unmaintained/random-tester/random-tester.factor

USING: kernel math math-internals memory sequences namespaces errors
assocs words  arrays parser compiler syntax io
quotations tools prettyprint optimizer inference ;
IN: random-tester

! n-foo>bar -- list of words of type 'foo' that take n parameters
!              and output a 'bar'


! Math vocabulary words
: 1-x>y
    {
        1+ 1- >bignum >digit >fixnum abs absq arg 
        bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
        cosh cot coth denominator double>bits exp float>bits floor imaginary
        log neg numerator real sec ! next-power-of-2
        sech sgn sin sinh sq sqrt tan tanh truncate 
    } ;

: 1-x>y-throws
    {
        recip log2
        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
    } ;

: 2-x>y ( -- seq ) { * + - /f max min polar> bitand bitor bitxor align } ;
: 2-x>y-throws ( -- seq ) { / /i mod rem } ;

: 1-integer>x
    {
        1+ 1- >bignum >digit >fixnum abs absq arg 
        bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
        cosh cot coth denominator exp floor imaginary
        log neg next-power-of-2 numerator real sec
        sech sgn sin sinh sq sqrt tan tanh truncate 
    } ;

: 1-ratio>x
    {
        1+ 1- >bignum >digit >fixnum abs absq arg ceiling
        cis conjugate cos cosec cosech
        cosh cot coth exp floor imaginary
        log neg next-power-of-2 real sec
        sech sgn sin sinh sq sqrt tan tanh truncate 
    } ;

: 1-float>x ( -- seq )
    {
        1+ 1- >bignum >digit >fixnum abs absq arg 
        ceiling cis conjugate cos cosec cosech
        cosh cot coth double>bits exp float>bits floor imaginary
        log neg real sec ! next-power-of-2
        sech sgn sin sinh sq sqrt tan tanh truncate
    } ;

: 1-complex>x
    {
        1+ 1- abs absq arg conjugate cos cosec cosech
        cosh cot coth exp imaginary log neg real
        sec sech sin sinh sq sqrt tan tanh 
    } ;

: 1-integer>x-throws
    {
        recip log2
        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
    } ;

: 1-ratio>x-throws
    {
        recip
        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
    } ;

: 1-integer>integer
    {
        1+ 1- >bignum >digit >fixnum abs absq bitnot ceiling conjugate 
        denominator floor imaginary
        neg next-power-of-2 numerator real sgn sq truncate 
    } ;

: 1-ratio>ratio
    { 1+ 1- >digit abs absq conjugate neg real sq } ;

: 1-float>float
    {
        1+ 1- >digit abs absq arg ceiling
        conjugate exp floor neg real sq truncate
    } ;

: 1-complex>complex
    {
        1+ 1- abs absq arg conjugate cosec cosech cosh cot coth exp log
        neg sech sin sinh sq sqrt tanh 
    } ;

: 2-integer>x { * + - /f max min polar> bitand bitor bitxor align } ;
: 2-ratio>x { * + - /f max min polar> } ;
: 2-float>x { float+ float- float* float/f + - * /f max min polar> } ;
: 2-complex>x { * + - /f } ;

: 2-integer>integer { * + - max min bitand bitor bitxor align } ;
: 2-ratio>ratio { * + - max min } ;
: 2-float>float { float* float+ float- float/f max min /f + - } ;
: 2-complex>complex { * + - /f } ;


SYMBOL: last-quot
SYMBOL: first-arg
SYMBOL: second-arg
: 0-runtime-check ( quot -- )
    #! Checks the runtime only, not the compiler
    #! Evaluates the quotation twice and makes sure the results agree
    [ last-quot set ] keep
    [ call ] keep
    call
    ! 2dup swap unparse write " " write unparse print flush
    = [ last-quot get . "problem in runtime" throw ] unless ;

: 1-runtime-check ( quot -- )
    #! Checks the runtime only, not the compiler
    #! Evaluates the quotation twice and makes sure the results agree
    #! For quotations that are given one argument
    [ last-quot set first-arg set ] 2keep
    [ call ] 2keep
    call
    2dup swap unparse write " " write unparse print flush
    = [ "problem in runtime" throw ] unless ;

: 1-interpreted-vs-compiled-check ( x quot -- ) 
    #! Checks the runtime output vs the compiler output
    #! quot: ( x -- y )
    2dup swap unparse write " " write . flush
    [ last-quot set first-arg set ] 2keep
    [ call ] 2keep compile-1
    2dup swap unparse write " " write unparse print flush
    = [ "problem in math1" throw ] unless ;

: 2-interpreted-vs-compiled-check ( x y quot -- )
    #! Checks the runtime output vs the compiler output
    #! quot: ( x y -- z )
    .s flush
    [ last-quot set first-arg set second-arg set ] 3keep
    [ call ] 3keep compile-1
    2dup swap unparse write " " write unparse print flush
    = [ "problem in math2" throw ] unless ;

: 0-interpreted-vs-compiled-check-catch ( quot -- )
    #! Check the runtime output vs the compiler output for words that throw
    #!
    dup .
    [ last-quot set ] keep
    [ catch [ "caught: " write dup print-error ] when* ] keep 
    [ compile-1 ] catch [ nip "caught: " write dup print-error ] when*
    = [ "problem in math3" throw ] unless ;

: 1-interpreted-vs-compiled-check-catch ( quot -- )
    #! Check the runtime output vs the compiler output for words that throw
    2dup swap unparse write " " write .
    ! "." write
    [ last-quot set first-arg set ] 2keep
    [ catch [ nip "caught: " write dup print-error ] when* ] 2keep 
    [ compile-1 ] catch [ 2nip "caught: " write dup print-error ] when*
    = [ "problem in math4" throw ] unless ;

: 2-interpreted-vs-compiled-check-catch ( quot -- )
    #! Check the runtime output vs the compiler output for words that throw
    ! 3dup rot unparse write " " write swap unparse write " " write .
    "." write
    [ last-quot set first-arg set second-arg set ] 3keep
    [ catch [ 2nip "caught: " write dup print-error ] when* ] 3keep
    [ compile-1 ] catch [ 2nip nip "caught: " write dup print-error ] when*
    = [ "problem in math5" throw ] unless ;


! RANDOM QUOTATIONS TO TEST
: random-1-integer>x-quot ( -- quot ) 1-integer>x random 1quotation ;
: random-1-ratio>x-quot ( -- quot ) 1-ratio>x random 1quotation ;
: random-1-float>x-quot ( -- quot ) 1-float>x random 1quotation ;
: random-1-complex>x-quot ( -- quot ) 1-complex>x random 1quotation ;

: test-1-integer>x ( -- )
    random-integer random-1-integer>x-quot 1-interpreted-vs-compiled-check ;
: test-1-ratio>x ( -- )
    random-ratio random-1-ratio>x-quot 1-interpreted-vs-compiled-check ;
: test-1-float>x ( -- )
    random-float random-1-float>x-quot 1-interpreted-vs-compiled-check ;
: test-1-complex>x ( -- )
    random-complex random-1-complex>x-quot 1-interpreted-vs-compiled-check ;


: random-1-float>float-quot ( -- obj ) 1-float>float random 1quotation ;
: random-2-float>float-quot ( -- obj ) 2-float>float random 1quotation ;
: nrandom-2-float>float-quot ( -- obj )
    [
        5
        [
            {
                [ 2-float>float random , random-float , ]
                [ 1-float>float random ,  ]
            } do-one
        ] times 
        2-float>float random ,
    ] [ ] make ;

: test-1-float>float ( -- )
    random-float random-1-float>float-quot 1-interpreted-vs-compiled-check ;
: test-2-float>float ( -- )
    random-float random-float random-2-float>float-quot
    2-interpreted-vs-compiled-check ;

: test-n-2-float>float ( -- )
    random-float random-float nrandom-2-float>float-quot
    2-interpreted-vs-compiled-check ;

: test-1-integer>x-runtime ( -- )
    random-integer random-1-integer>x-quot 1-runtime-check ;

: random-1-integer>x-throws-quot ( -- obj ) 1-integer>x-throws random 1quotation ;
: random-1-ratio>x-throws-quot ( -- obj ) 1-ratio>x-throws random 1quotation ;
: test-1-integer>x-throws ( -- obj )
    random-integer random-1-integer>x-throws-quot
    1-interpreted-vs-compiled-check-catch ;
: test-1-ratio>x-throws ( -- obj )
    random-ratio random-1-ratio>x-throws-quot
    1-interpreted-vs-compiled-check-catch ;



: test-2-integer>x-throws ( -- )
    [
        random-integer , random-integer ,
        2-x>y-throws random ,
    ] [ ] make 2-interpreted-vs-compiled-check-catch ;

! : test-^-ratio ( -- )
    ! [
        ! random-ratio , random-ratio , \ ^ ,
    ! ] [ ] make interp-compile-check-catch ;

: test-0-float?-when
    [
        random-number , \ dup , \ float? , 1-float>x random 1quotation , \ when ,
    ] [ ] make 0-runtime-check ;

: test-1-integer?-when
    random-integer [
        \ dup , \ integer? , 1-integer>x random 1quotation , \ when ,
    ] [ ] make 1-interpreted-vs-compiled-check ;

: test-1-ratio?-when
    random-ratio [
        \ dup , \ ratio? , 1-ratio>x random 1quotation , \ when ,
    ] [ ] make 1-interpreted-vs-compiled-check ;

: test-1-float?-when
    random-float [
        \ dup , \ float? , 1-float>x random 1quotation , \ when ,
    ] [ ] make 1-interpreted-vs-compiled-check ;

: test-1-complex?-when
    random-complex [
        \ dup , \ complex? , 1-complex>x random 1quotation , \ when ,
    ] [ ] make 1-interpreted-vs-compiled-check ;


: many-word-test ( -- )
    #! defines words a1000 down to a0, which does a trivial addition
    "random-tester-scratchpad" vocabularies get delete-at
    "random-tester-scratchpad" set-in
    "a0" "random-tester-scratchpad" create [ 1 1 + ] define-compound
    100 [
        [ 1+ "a" swap unparse append "random-tester-scratchpad" create ] keep
        "a" swap unparse append [ parse ] catch [ :1 ] when define-compound
    ] each ;

: compile-loop ( -- )
    10 [ many-word-test "a100" parse first compile ] times ;

: random-test
    "----" print
    {
        test-1-integer>x
        test-1-ratio>x
        test-1-float>x
        test-1-complex>x
        test-1-integer>x-throws
        test-1-ratio>x-throws
        test-1-float>float
        test-2-float>float
        ! test-n-2-float>float
        test-1-integer>x-runtime
        ! test-0-float?-when
        test-1-integer?-when
        test-1-ratio?-when
        test-1-float?-when
        test-1-complex?-when
        ! full-gc
        ! code-gc
    } random dup . execute nl ;