463 lines
9.4 KiB
Factor
463 lines
9.4 KiB
Factor
! :folding=indent:collapseFolds=0:
|
|
|
|
! $Id$
|
|
!
|
|
! Copyright (C) 2004 Slava Pestov.
|
|
!
|
|
! Redistribution and use in source and binary forms, with or without
|
|
! modification, are permitted provided that the following conditions are met:
|
|
!
|
|
! 1. Redistributions of source code must retain the above copyright notice,
|
|
! this list of conditions and the following disclaimer.
|
|
!
|
|
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
|
! this list of conditions and the following disclaimer in the documentation
|
|
! and/or other materials provided with the distribution.
|
|
!
|
|
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
|
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
|
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
|
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
|
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
|
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
|
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
|
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
|
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
IN: math
|
|
USE: combinators
|
|
USE: errors
|
|
USE: kernel
|
|
USE: stack
|
|
USE: vectors
|
|
USE: words
|
|
|
|
: (gcd) ( x y -- z ) dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
|
|
: gcd ( x y -- z ) abs swap abs 2dup < [ swap ] when (gcd) ;
|
|
|
|
: reduce ( x y -- x' y' )
|
|
dup 0 < [ swap neg swap neg ] when 2dup gcd tuck /i >r /i r> ;
|
|
: ratio ( x y -- x/y ) reduce fraction> ;
|
|
: 2>fraction ( a/b c/d -- a b c d ) >r >fraction r> >fraction ;
|
|
|
|
: ratio= ( a/b c/d -- ? ) 2>fraction 2= ;
|
|
: ratio-scale ( a/b c/d -- a*d b*c ) 2>fraction -rot * >r * r> ;
|
|
: ratio+d ( a/b c/d -- b*d ) denominator swap denominator * ;
|
|
: ratio+ ( x y -- x+y ) 2dup ratio-scale + -rot ratio+d ratio ;
|
|
: ratio- ( x y -- x-y ) 2dup ratio-scale - -rot ratio+d ratio ;
|
|
: ratio* ( x y -- x*y ) 2>fraction swapd * >r * r> ratio ;
|
|
: ratio/ ( x y -- x/y ) ratio-scale ratio ;
|
|
: ratio/f ( x y -- x/y ) ratio-scale /f ;
|
|
|
|
: ratio< ( x y -- ? ) ratio-scale < ;
|
|
: ratio<= ( x y -- ? ) ratio-scale <= ;
|
|
: ratio> ( x y -- ? ) ratio-scale > ;
|
|
: ratio>= ( x y -- ? ) ratio-scale >= ;
|
|
|
|
: 2>rect ( x y -- x:re x:im y:re y:im ) >r >rect r> >rect ;
|
|
|
|
: complex= ( x y -- ? ) 2>rect 2= ;
|
|
: complex+ ( x y -- x+y ) 2>rect swapd + >r + r> rect> ;
|
|
: complex- ( x y -- x-y ) 2>rect swapd - >r - r> rect> ;
|
|
: complex*re ( x y -- zx:re * y:re x:im * r:im )
|
|
2>rect swapd * >r * r> ;
|
|
: complex*im ( x y -- x:re * y:im x:im * y:re )
|
|
2>rect >r * swap r> * ;
|
|
: complex* ( x y -- x*y )
|
|
2dup complex*re - -rot complex*im + rect> ;
|
|
: abs^2 ( x -- y ) >rect sq swap sq + ;
|
|
: (complex/) ( x y -- r i m )
|
|
#! r = x:re * y:re + x:im * y:im
|
|
#! i = x:im * y:re - x:re * y:im
|
|
#! m = y:re * y:re + y:im * y:im
|
|
dup abs^2 >r 2dup complex*re + -rot complex*im - r> ;
|
|
: complex/ ( x y -- x/y )
|
|
(complex/) tuck / >r / r> rect> ;
|
|
: complex/f ( x y -- x/y )
|
|
(complex/) tuck /f >r /f r> rect> ;
|
|
|
|
: no-method ( -- )
|
|
"No applicable method" throw ;
|
|
|
|
: (not-=) ( x y -- f )
|
|
2drop f ;
|
|
|
|
: number= ( x y -- ? )
|
|
{
|
|
fixnum=
|
|
(not-=)
|
|
(not-=)
|
|
(not-=)
|
|
ratio=
|
|
complex=
|
|
(not-=)
|
|
(not-=)
|
|
(not-=)
|
|
(not-=)
|
|
(not-=)
|
|
(not-=)
|
|
(not-=)
|
|
bignum=
|
|
float=
|
|
(not-=)
|
|
(not-=)
|
|
} 2generic ;
|
|
|
|
: + ( x y -- x+y )
|
|
{
|
|
fixnum+
|
|
no-method
|
|
no-method
|
|
no-method
|
|
ratio+
|
|
complex+
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum+
|
|
float+
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: - ( x y -- x-y )
|
|
{
|
|
fixnum-
|
|
no-method
|
|
no-method
|
|
no-method
|
|
ratio-
|
|
complex-
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum-
|
|
float-
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: * ( x y -- x*y )
|
|
{
|
|
fixnum*
|
|
no-method
|
|
no-method
|
|
no-method
|
|
ratio*
|
|
complex*
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum*
|
|
float*
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: / ( x y -- x/y )
|
|
{
|
|
ratio
|
|
no-method
|
|
no-method
|
|
no-method
|
|
ratio/
|
|
complex/
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
ratio
|
|
float/f
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: /i ( x y -- x/y )
|
|
{
|
|
fixnum/i
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum/i
|
|
no-method
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: /f ( x y -- x/y )
|
|
{
|
|
fixnum/f
|
|
no-method
|
|
no-method
|
|
no-method
|
|
ratio/f
|
|
complex/f
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum/f
|
|
float/f
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: mod ( x y -- x%y )
|
|
{
|
|
fixnum-mod
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum-mod
|
|
no-method
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: /mod ( x y -- x/y x%y )
|
|
{
|
|
fixnum/mod
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum/mod
|
|
no-method
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: bitand ( x y -- x&y )
|
|
{
|
|
fixnum-bitand
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum-bitand
|
|
no-method
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: bitor ( x y -- x|y )
|
|
{
|
|
fixnum-bitor
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum-bitor
|
|
no-method
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: bitxor ( x y -- x^y )
|
|
{
|
|
fixnum-bitxor
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum-bitxor
|
|
no-method
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: bitnot ( x -- ~x )
|
|
{
|
|
[ fixnum-bitnot ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ bignum-bitnot ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
[ no-method ]
|
|
} generic ;
|
|
|
|
: shift ( x n -- x<<n )
|
|
{
|
|
fixnum-shift
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum-shift
|
|
no-method
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: < ( x y -- ? )
|
|
{
|
|
fixnum<
|
|
no-method
|
|
no-method
|
|
no-method
|
|
ratio<
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum<
|
|
float<
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: <= ( x y -- ? )
|
|
{
|
|
fixnum<=
|
|
no-method
|
|
no-method
|
|
no-method
|
|
ratio<=
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum<=
|
|
float<=
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: > ( x y -- ? )
|
|
{
|
|
fixnum>
|
|
no-method
|
|
no-method
|
|
no-method
|
|
ratio>
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum>
|
|
float>
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|
|
|
|
: >= ( x y -- ? )
|
|
{
|
|
fixnum>=
|
|
no-method
|
|
no-method
|
|
no-method
|
|
ratio>=
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
no-method
|
|
bignum>=
|
|
float>=
|
|
no-method
|
|
no-method
|
|
} 2generic ;
|