! 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
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) ;
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; 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? [
[ * ] 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 < [