some new math words, fix implementation of class< for unions
Slava Pestov
parent
6c11b788e0
commit
4f7d80af74
|
|
@ -149,6 +149,10 @@ M: cons hashcode ( cons -- hash ) car hashcode ;
|
|||
#! list1.
|
||||
[ over contains? not ] subset nip ;
|
||||
|
||||
: contained? ( list1 list2 -- ? )
|
||||
#! Is every element of list1 in list2?
|
||||
swap [ swap contains? ] all-with? ;
|
||||
|
||||
: <queue> ( -- queue )
|
||||
#! Make a new functional queue.
|
||||
[[ [ ] [ ] ]] ;
|
||||
|
|
|
|||
|
|
@ -20,7 +20,9 @@ union [
|
|||
|
||||
union 55 "priority" set-word-prop
|
||||
|
||||
union [ 2drop t ] "class<" set-word-prop
|
||||
union [
|
||||
swap builtin-supertypes swap builtin-supertypes contained?
|
||||
] "class<" set-word-prop
|
||||
|
||||
: union-predicate ( definition -- list )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,12 +1,29 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: math
|
||||
USING: errors generic kernel math ;
|
||||
|
||||
BUILTIN: fixnum 0 ;
|
||||
BUILTIN: bignum 1 ;
|
||||
UNION: integer fixnum bignum ;
|
||||
|
||||
: (gcd) ( b a y x -- a d )
|
||||
dup 0 number= [
|
||||
drop nip
|
||||
] [
|
||||
tuck /mod >r pick * swap >r swapd - r> r> (gcd)
|
||||
] ifte ;
|
||||
|
||||
: gcd ( x y -- a d )
|
||||
#! Compute the greatest common divisor d and multiplier a
|
||||
#! such that a*x=d mod y.
|
||||
swap 0 1 2swap (gcd) abs ;
|
||||
|
||||
: mod-inv ( x n -- y )
|
||||
#! Compute the multiplicative inverse of x mod n.
|
||||
gcd 1 = [ "Non-trivial divisor found" throw ] unless ;
|
||||
|
||||
IN: math-internals
|
||||
USING: errors generic kernel math ;
|
||||
|
||||
: fraction> ( a b -- a/b )
|
||||
dup 1 number= [
|
||||
|
|
@ -25,7 +42,7 @@ USING: errors generic kernel math ;
|
|||
dup 0 < [
|
||||
swap neg swap neg
|
||||
] when
|
||||
2dup gcd tuck /i >r /i r> fraction>
|
||||
2dup gcd nip tuck /i >r /i r> fraction>
|
||||
] ifte ; inline
|
||||
|
||||
M: fixnum number=
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2003, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: math
|
||||
USING: generic kernel math-internals ;
|
||||
USING: errors generic kernel math-internals ;
|
||||
|
||||
! Math operations
|
||||
2GENERIC: number= ( x y -- ? )
|
||||
|
|
@ -55,13 +55,6 @@ GENERIC: bitnot ( n -- n )
|
|||
|
||||
GENERIC: abs ( z -- |z| )
|
||||
|
||||
: (gcd) ( x y -- z )
|
||||
dup 0 number= [ drop ] [ tuck mod (gcd) ] ifte ;
|
||||
|
||||
: gcd ( x y -- z )
|
||||
#! Greatest common divisor.
|
||||
abs swap abs 2dup < [ swap ] when (gcd) ;
|
||||
|
||||
: align ( offset width -- offset )
|
||||
2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: math
|
||||
USING: math math-internals kernel ;
|
||||
USING: errors kernel math math-internals ;
|
||||
|
||||
! Power-related functions:
|
||||
! exp log sqrt pow
|
||||
! exp log sqrt pow ^mod
|
||||
|
||||
: exp >rect swap fexp swap polar> ;
|
||||
: log >polar swap flog swap rect> ;
|
||||
|
|
@ -16,15 +16,45 @@ USING: math math-internals kernel ;
|
|||
swap fsqrt swap 2 / polar>
|
||||
] ifte ;
|
||||
|
||||
GENERIC: ^ ( z w -- z^w )
|
||||
|
||||
: ^mag ( w abs arg -- magnitude )
|
||||
>r >r >rect swap r> swap fpow r> rot * fexp / ;
|
||||
|
||||
: ^theta ( w abs arg -- theta )
|
||||
>r >r >rect r> flog * swap r> * + ;
|
||||
|
||||
: ^ ( z w -- z^w )
|
||||
over real? over integer? and [
|
||||
fpow
|
||||
M: number ^ ( z w -- z^w )
|
||||
swap >polar 3dup ^theta >r ^mag r> polar> ;
|
||||
|
||||
: each-bit ( n quot -- | quot: 0/1 -- )
|
||||
#! Apply the quotation to each bit of the number. The number
|
||||
#! must be positive.
|
||||
over 0 number= [
|
||||
2drop
|
||||
] [
|
||||
swap >polar 3dup ^theta >r ^mag r> polar>
|
||||
2dup >r >r >r 1 bitand r> call r> -1 shift r> each-bit
|
||||
] ifte ; inline
|
||||
|
||||
: (integer^) ( z w -- z^w )
|
||||
1 swap [ 1 number= [ dupd * ] when >r sq r> ] each-bit nip ;
|
||||
|
||||
M: integer ^ ( z w -- z^w )
|
||||
over 0 number= over 0 number= and [
|
||||
"0^0 is not defined" throw
|
||||
] [
|
||||
dup 0 < [ neg ^ recip ] [ (integer^) ] ifte
|
||||
] ifte ;
|
||||
|
||||
: (^mod) ( n z w -- z^w )
|
||||
1 swap [
|
||||
1 number= [ dupd * pick mod ] when >r sq over mod r>
|
||||
] each-bit 2nip ;
|
||||
|
||||
: ^mod ( z w n -- z^w )
|
||||
#! Compute z^w mod n.
|
||||
over 0 < [
|
||||
[ >r neg r> ^mod ] keep mod-inv
|
||||
] [
|
||||
-rot (^mod)
|
||||
] ifte ;
|
||||
|
|
|
|||
|
|
@ -145,3 +145,10 @@ M: sequence testing 4 ;
|
|||
|
||||
! Bootstrap hashing
|
||||
[ f ] [ \ f \ unparse "methods" word-prop hash not ] unit-test
|
||||
|
||||
GENERIC: union-containment
|
||||
M: integer union-containment drop 1 ;
|
||||
M: number union-containment drop 2 ;
|
||||
|
||||
[ 1 ] [ 1 union-containment ] unit-test
|
||||
[ 2 ] [ 1.0 union-containment ] unit-test
|
||||
|
|
|
|||
|
|
@ -49,3 +49,6 @@ USING: kernel lists sequences test ;
|
|||
[ [ 1 2 3 ] ] [ [ 1 2 3 4 ] 3 head ] unit-test
|
||||
|
||||
[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] difference ] unit-test
|
||||
|
||||
[ t ] [ [ 1 2 3 ] [ 1 2 3 4 5 ] contained? ] unit-test
|
||||
[ f ] [ [ 1 2 3 6 ] [ 1 2 3 4 5 ] contained? ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,19 +0,0 @@
|
|||
IN: temporary
|
||||
USE: math
|
||||
USE: test
|
||||
USE: unparser
|
||||
USE: kernel
|
||||
|
||||
[ -1 ] [ -1 >bignum >fixnum ] unit-test
|
||||
|
||||
[ "8589934592" ]
|
||||
[ 134217728 dup + dup + dup + dup + dup + dup + unparse ]
|
||||
unit-test
|
||||
|
||||
[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test
|
||||
[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
|
||||
[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
|
||||
[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test
|
||||
[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
|
||||
[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
|
||||
[ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test
|
||||
|
|
@ -1,27 +0,0 @@
|
|||
IN: temporary
|
||||
USE: math
|
||||
USE: test
|
||||
|
||||
[ 100 ] [ 100 100 gcd ] unit-test
|
||||
[ 100 ] [ 1000 100 gcd ] unit-test
|
||||
[ 100 ] [ 100 1000 gcd ] unit-test
|
||||
[ 4 ] [ 132 64 gcd ] unit-test
|
||||
[ 4 ] [ -132 64 gcd ] unit-test
|
||||
[ 4 ] [ -132 -64 gcd ] unit-test
|
||||
[ 4 ] [ 132 -64 gcd ] unit-test
|
||||
[ 4 ] [ -132 -64 gcd ] unit-test
|
||||
|
||||
[ 100 ] [ 100 >bignum 100 >bignum gcd ] unit-test
|
||||
[ 100 ] [ 1000 >bignum 100 >bignum gcd ] unit-test
|
||||
[ 100 ] [ 100 >bignum 1000 >bignum gcd ] unit-test
|
||||
[ 4 ] [ 132 >bignum 64 >bignum gcd ] unit-test
|
||||
[ 4 ] [ -132 >bignum 64 >bignum gcd ] unit-test
|
||||
[ 4 ] [ -132 >bignum -64 >bignum gcd ] unit-test
|
||||
[ 4 ] [ 132 >bignum -64 >bignum gcd ] unit-test
|
||||
[ 4 ] [ -132 >bignum -64 >bignum gcd ] unit-test
|
||||
|
||||
[ 6 ] [
|
||||
1326264299060955293181542400000006
|
||||
1591517158873146351817850880000000
|
||||
gcd
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
IN: temporary
|
||||
USING: kernel math test unparser ;
|
||||
|
||||
[ "-8" ] [ -8 unparse ] unit-test
|
||||
|
||||
[ t ] [ 0 fixnum? ] unit-test
|
||||
[ t ] [ 31415 number? ] unit-test
|
||||
[ t ] [ 31415 >bignum number? ] unit-test
|
||||
[ t ] [ 2345621 fixnum? ] unit-test
|
||||
|
||||
[ t ] [ 2345621 dup >bignum >fixnum = ] unit-test
|
||||
|
||||
[ t ] [ 0 >fixnum 0 >bignum = ] unit-test
|
||||
[ f ] [ 0 >fixnum 1 >bignum = ] unit-test
|
||||
[ f ] [ 1 >bignum 0 >bignum = ] unit-test
|
||||
[ t ] [ 0 >bignum 0 >fixnum = ] unit-test
|
||||
|
||||
[ t ] [ 0 >bignum bignum? ] unit-test
|
||||
[ f ] [ 0 >fixnum bignum? ] unit-test
|
||||
[ f ] [ 0 >fixnum bignum? ] unit-test
|
||||
[ t ] [ 0 >fixnum fixnum? ] unit-test
|
||||
|
||||
[ -1 ] [ 1 neg ] unit-test
|
||||
[ -1 ] [ 1 >bignum neg ] unit-test
|
||||
|
||||
[ 9 3 ] [ 93 10 /mod ] unit-test
|
||||
[ 9 3 ] [ 93 >bignum 10 /mod ] unit-test
|
||||
|
||||
[ 5 ] [ 2 >bignum 3 >bignum + ] unit-test
|
||||
|
||||
[ 100 ] [ 100 100 gcd nip ] unit-test
|
||||
[ 100 ] [ 1000 100 gcd nip ] unit-test
|
||||
[ 100 ] [ 100 1000 gcd nip ] unit-test
|
||||
[ 4 ] [ 132 64 gcd nip ] unit-test
|
||||
[ 4 ] [ -132 64 gcd nip ] unit-test
|
||||
[ 4 ] [ -132 -64 gcd nip ] unit-test
|
||||
[ 4 ] [ 132 -64 gcd nip ] unit-test
|
||||
[ 4 ] [ -132 -64 gcd nip ] unit-test
|
||||
|
||||
[ 100 ] [ 100 >bignum 100 >bignum gcd nip ] unit-test
|
||||
[ 100 ] [ 1000 >bignum 100 >bignum gcd nip ] unit-test
|
||||
[ 100 ] [ 100 >bignum 1000 >bignum gcd nip ] unit-test
|
||||
[ 4 ] [ 132 >bignum 64 >bignum gcd nip ] unit-test
|
||||
[ 4 ] [ -132 >bignum 64 >bignum gcd nip ] unit-test
|
||||
[ 4 ] [ -132 >bignum -64 >bignum gcd nip ] unit-test
|
||||
[ 4 ] [ 132 >bignum -64 >bignum gcd nip ] unit-test
|
||||
[ 4 ] [ -132 >bignum -64 >bignum gcd nip ] unit-test
|
||||
|
||||
[ 6 ] [
|
||||
1326264299060955293181542400000006
|
||||
1591517158873146351817850880000000
|
||||
gcd nip
|
||||
] unit-test
|
||||
|
||||
: verify-gcd ( x y )
|
||||
2dup gcd ( a d )
|
||||
>r rot * swap rem r> = ;
|
||||
|
||||
[ t ] [ 123 124 verify-gcd ] unit-test
|
||||
[ t ] [ 50 120 verify-gcd ] unit-test
|
||||
[ 3 ] [ 5 7 mod-inv ] unit-test
|
||||
[ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
|
||||
|
||||
[ -1 ] [ -1 >bignum >fixnum ] unit-test
|
||||
|
||||
[ "8589934592" ]
|
||||
[ 134217728 dup + dup + dup + dup + dup + dup + unparse ]
|
||||
unit-test
|
||||
|
||||
[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test
|
||||
[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
|
||||
[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
|
||||
[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test
|
||||
[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
|
||||
[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
|
||||
[ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test
|
||||
|
||||
[ 0 0 ^ ] unit-test-fails
|
||||
[ 1 ] [ 10 0 ^ ] unit-test
|
||||
[ 1/8 ] [ 1/2 3 ^ ] unit-test
|
||||
[ 1/8 ] [ 2 -3 ^ ] unit-test
|
||||
[ t ] [ 1 100 shift 2 100 ^ = ] unit-test
|
||||
|
|
@ -4,33 +4,6 @@ USE: math
|
|||
USE: test
|
||||
USE: unparser
|
||||
|
||||
[ "-8" ] [ -8 unparse ] unit-test
|
||||
|
||||
[ t ] [ 0 fixnum? ] unit-test
|
||||
[ t ] [ 31415 number? ] unit-test
|
||||
[ t ] [ 31415 >bignum number? ] unit-test
|
||||
[ t ] [ 2345621 fixnum? ] unit-test
|
||||
|
||||
[ t ] [ 2345621 dup >bignum >fixnum = ] unit-test
|
||||
|
||||
[ t ] [ 0 >fixnum 0 >bignum = ] unit-test
|
||||
[ f ] [ 0 >fixnum 1 >bignum = ] unit-test
|
||||
[ f ] [ 1 >bignum 0 >bignum = ] unit-test
|
||||
[ t ] [ 0 >bignum 0 >fixnum = ] unit-test
|
||||
|
||||
[ t ] [ 0 >bignum bignum? ] unit-test
|
||||
[ f ] [ 0 >fixnum bignum? ] unit-test
|
||||
[ f ] [ 0 >fixnum bignum? ] unit-test
|
||||
[ t ] [ 0 >fixnum fixnum? ] unit-test
|
||||
|
||||
[ -1 ] [ 1 neg ] unit-test
|
||||
[ -1 ] [ 1 >bignum neg ] unit-test
|
||||
|
||||
[ 9 3 ] [ 93 10 /mod ] unit-test
|
||||
[ 9 3 ] [ 93 >bignum 10 /mod ] unit-test
|
||||
|
||||
[ 5 ] [ 2 >bignum 3 >bignum + ] unit-test
|
||||
|
||||
[ 1/2 ] [ 1 >bignum 2 >bignum / ] unit-test
|
||||
[ t ] [ 10 3 / ratio? ] unit-test
|
||||
[ f ] [ 10 2 / ratio? ] unit-test
|
||||
|
|
|
|||
Loading…
Reference in New Issue