steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Cleanup math.functions and remove >r r> usages

db4
Aaron Schaefer 2008-11-16 21:24:56 -05:00
parent 72fea07526
commit c7f5d53144
1 changed files with 13 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
basis/math/functions/functions.factor
View File

@ -15,7 +15,7 @@ IN: math.functions
PRIVATE> PRIVATE>
: rect> ( x y -- z ) : rect> ( x y -- z )
over real? over real? and [ 2dup [ real? ] both? [
(rect>) (rect>)
] [ ] [
"Complex number must have real components" throw "Complex number must have real components" throw
@ -27,10 +27,10 @@ M: real sqrt
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
: each-bit ( n quot: ( ? -- ) -- ) : each-bit ( n quot: ( ? -- ) -- )
over 0 = pick -1 = or [ over [ 0 = ] [ -1 = ] bi or [
2drop 2drop
] [ ] [
2dup >r >r >r odd? r> call r> 2/ r> each-bit 2dup { [ odd? ] [ call ] [ 2/ ] [ each-bit ] } spread
] if ; inline recursive ] if ; inline recursive
: map-bits ( n quot: ( ? -- obj ) -- seq ) : map-bits ( n quot: ( ? -- obj ) -- seq )
@ -69,8 +69,7 @@ PRIVATE>
>rect [ >float ] bi@ ; inline >rect [ >float ] bi@ ; inline
: >polar ( z -- abs arg ) : >polar ( z -- abs arg )
>float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; >float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; inline
inline
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline : cis ( arg -- z ) dup fcos swap fsin rect> ; inline
@ -79,11 +78,10 @@ PRIVATE>
<PRIVATE <PRIVATE
: ^mag ( w abs arg -- magnitude ) : ^mag ( w abs arg -- magnitude )
>r >r >float-rect swap r> swap fpow r> rot * fexp /f ; [ >float-rect swap ] [ swap fpow ] [ rot * fexp /f ] tri* ; inline
inline
: ^theta ( w abs arg -- theta ) : ^theta ( w abs arg -- theta )
>r >r >float-rect r> flog * swap r> * + ; inline [ >float-rect ] [ flog * swap ] [ * + ] tri* ; inline
: ^complex ( x y -- z ) : ^complex ( x y -- z )
swap >polar [ ^mag ] [ ^theta ] 3bi polar> ; inline swap >polar [ ^mag ] [ ^theta ] 3bi polar> ; inline
@ -106,18 +104,18 @@ PRIVATE>
: (^mod) ( n x y -- z ) : (^mod) ( n x y -- z )
1 swap [ 1 swap [
[ dupd * pick mod ] when >r sq over mod r> [ dupd * pick mod ] when [ sq over mod ] dip
] each-bit 2nip ; inline ] each-bit 2nip ; inline
: (gcd) ( b a x y -- a d ) : (gcd) ( b a x y -- a d )
over zero? [ over zero? [
2nip 2nip
] [ ] [
swap [ /mod >r over * swapd - r> ] keep (gcd) swap [ /mod [ over * swapd - ] dip ] keep (gcd)
] if ; ] if ;
: gcd ( x y -- a d ) : gcd ( x y -- a d )
0 -rot 1 -rot (gcd) dup 0 < [ neg ] when ; foldable [ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; foldable
: lcm ( a b -- c ) : lcm ( a b -- c )
[ * ] 2keep gcd nip /i ; foldable [ * ] 2keep gcd nip /i ; foldable
@ -131,7 +129,7 @@ PRIVATE>
: ^mod ( x y n -- z ) : ^mod ( x y n -- z )
over 0 < [ over 0 < [
[ >r neg r> ^mod ] keep mod-inv [ [ neg ] dip ^mod ] keep mod-inv
] [ ] [
-rot (^mod) -rot (^mod)
] if ; foldable ] if ; foldable
@ -141,14 +139,14 @@ GENERIC: absq ( x -- y ) foldable
M: real absq sq ; M: real absq sq ;
: ~abs ( x y epsilon -- ? ) : ~abs ( x y epsilon -- ? )
>r - abs r> < ; [ - abs ] dip < ;
: ~rel ( x y epsilon -- ? ) : ~rel ( x y epsilon -- ? )
>r [ - abs ] 2keep [ abs ] bi@ + r> * < ; [ [ - abs ] 2keep [ abs ] bi@ + ] dip * < ;
: ~ ( x y epsilon -- ? ) : ~ ( x y epsilon -- ? )
{ {
{ [ pick fp-nan? pick fp-nan? or ] [ 3drop f ] } { [ pick pick [ fp-nan? ] either? ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] } { [ dup zero? ] [ drop number= ] }
{ [ dup 0 < ] [ ~rel ] } { [ dup 0 < ] [ ~rel ] }
[ ~abs ] [ ~abs ]