Merge OneEyed's patch

[factor.git] / basis / math / functions / functions.factor

diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
index 1cea0a74dd3790305ef47b967a0436caac33e94f..a87b3995d7eb03a6b0b65f46dba4f8c08ab160d7 100644 (file)
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel math.constants math.private
+USING: math kernel math.constants math.private math.bits
 math.libm combinators math.order sequences ;
 IN: math.functions
 
@@ -26,33 +26,24 @@ GENERIC: sqrt ( x -- y ) foldable
 M: real sqrt
     >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
 
-: each-bit ( n quot: ( ? -- ) -- )
-    over [ 0 = ] [ -1 = ] bi or [
-        2drop
-    ] [
-        2dup { [ odd? ] [ call ] [ 2/ ] [ each-bit ] } spread
-    ] if ; inline recursive
-
-: map-bits ( n quot: ( ? -- obj ) -- seq )
-    accumulator [ each-bit ] dip ; inline
-
 : factor-2s ( n -- r s )
     #! factor an integer into 2^r * s
     dup 0 = [ 1 ] [
-        0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while
+        0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while
     ] if ; inline
 
 <PRIVATE
 
 GENERIC# ^n 1 ( z w -- z^w )
 
-: (^n) 1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline
+: (^n) ( z w -- z^w )
+    make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
 
 M: integer ^n
     [ factor-2s ] dip [ (^n) ] keep rot * shift ;
 
 M: ratio ^n
-    [ >fraction ] dip tuck [ ^n ] 2bi@ / ;
+    [ >fraction ] dip [ ^n ] curry bi@ / ;
 
 M: float ^n
     (^n) ;
@@ -92,20 +83,10 @@ PRIVATE>
 : 0^ ( x -- z )
     dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
 
-PRIVATE>
-
-: ^ ( x y -- z )
-    {
-        { [ over zero? ] [ nip 0^ ] }
-        { [ dup integer? ] [ integer^ ] }
-        { [ 2dup real^? ] [ fpow ] }
-        [ ^complex ]
-    } cond ; inline
-
 : (^mod) ( n x y -- z )
-    1 swap [
+    make-bits 1 [
         [ dupd * pick mod ] when [ sq over mod ] dip
-    ] each-bit 2nip ; inline
+    ] reduce 2nip ; inline
 
 : (gcd) ( b a x y -- a d )
     over zero? [
@@ -114,6 +95,16 @@ PRIVATE>
         swap [ /mod [ over * swapd - ] dip ] keep (gcd)
     ] if ;
 
+PRIVATE>
+
+: ^ ( x y -- z )
+    {
+        { [ over zero? ] [ nip 0^ ] }
+        { [ dup integer? ] [ integer^ ] }
+        { [ 2dup real^? ] [ fpow ] }
+        [ ^complex ]
+    } cond ; inline
+
 : gcd ( x y -- a d )
     [ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; foldable
 
@@ -121,11 +112,9 @@ PRIVATE>
     [ * ] 2keep gcd nip /i ; foldable
 
 : mod-inv ( x n -- y )
-    tuck gcd 1 = [
-        dup 0 < [ + ] [ nip ] if
-    ] [
-        "Non-trivial divisor found" throw
-    ] if ; foldable
+    [ nip ] [ gcd 1 = ] 2bi
+    [ dup 0 < [ + ] [ nip ] if ]
+    [ "Non-trivial divisor found" throw ] if ; foldable
 
 : ^mod ( x y n -- z )
     over 0 < [
@@ -177,9 +166,9 @@ M: complex log >polar swap flog swap rect> ;
 GENERIC: cos ( x -- y ) foldable
 
 M: complex cos
-    >float-rect 2dup
-    fcosh swap fcos * -rot
-    fsinh swap fsin neg * rect> ;
+    >float-rect
+    [ [ fcos ] [ fcosh ] bi* * ]
+    [ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
 
 M: real cos fcos ;
 
@@ -188,9 +177,9 @@ M: real cos fcos ;
 GENERIC: cosh ( x -- y ) foldable
 
 M: complex cosh
-    >float-rect 2dup
-    fcos swap fcosh * -rot
-    fsin swap fsinh * rect> ;
+    >float-rect
+    [ [ fcosh ] [ fcos ] bi* * ]
+    [ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
 
 M: real cosh fcosh ;
 
@@ -199,9 +188,9 @@ M: real cosh fcosh ;
 GENERIC: sin ( x -- y ) foldable
 
 M: complex sin
-    >float-rect 2dup
-    fcosh swap fsin * -rot
-    fsinh swap fcos * rect> ;
+    >float-rect
+    [ [ fsin ] [ fcosh ] bi* * ]
+    [ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
 
 M: real sin fsin ;
 
@@ -210,9 +199,9 @@ M: real sin fsin ;
 GENERIC: sinh ( x -- y ) foldable
 
 M: complex sinh 
-    >float-rect 2dup
-    fcos swap fsinh * -rot
-    fsin swap fcosh * rect> ;
+    >float-rect
+    [ [ fsinh ] [ fcos ] bi* * ]
+    [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
 
 M: real sinh fsinh ;