core/math/pow.factor

   1 ! Copyright (C) 2004, 2005 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: math
   4 USING: errors kernel math math-internals ;
   5
   6 : exp ( x -- y ) >rect swap fexp swap polar> ; inline
   7 : log ( x -- y ) >polar swap flog swap rect> ; inline
   8
   9 GENERIC: sqrt ( x -- y ) foldable
  10
  11 M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ;
  12
  13 M: real sqrt
  14     >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
  15
  16 GENERIC: (^) ( x y -- z ) foldable
  17
  18 : ^ ( x y -- z )
  19     over zero? [
  20         dup zero?
  21         [ 2drop 0.0/0.0 ] [ 0 < [ drop 1.0/0.0 ] when ] if
  22      ] [
  23          (^)
  24      ] if ; inline
  25
  26 : ^mag ( w abs arg -- magnitude )
  27     >r >r >float-rect swap r> swap fpow r> rot * fexp /f ;
  28     inline
  29
  30 : ^theta ( w abs arg -- theta )
  31     >r >r >float-rect r> flog * swap r> * + ; inline
  32
  33 M: number (^)
  34     swap >polar 3dup ^theta >r ^mag r> polar> ;
  35
  36 : ^n ( z w -- z^w )
  37     {
  38         { [ dup zero? ] [ 2drop 1 ] }
  39         { [ dup 1 number= ] [ drop ] }
  40         { [ t ] [ over sq over 2 /i ^n -rot 2 mod ^n * ] }
  41     } cond ; inline
  42
  43 M: integer (^)
  44     dup 0 < [ neg ^n recip ] [ ^n ] if ;
  45
  46 : power-of-2? ( n -- ? )
  47     dup 0 > [
  48         dup dup neg bitand number=
  49     ] [
  50         drop f
  51     ] if ; foldable
  52
  53 : log2 ( n -- b )
  54     {
  55         { [ dup 0 <= ] [ "log2 expects positive inputs" throw ] }
  56         { [ dup 1 number= ] [ drop 0 ] }
  57         { [ t ] [ -1 shift log2 1+ ] }
  58     } cond ; foldable