extra/math/factorials/factorials.factor

   1 ! Copyright (C) 2013 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: combinators combinators.short-circuit kernel locals math
   5 math.functions math.ranges memoize sequences ;
   6
   7 IN: math.factorials
   8
   9 MEMO: factorial ( n -- n! )
  10     dup 1 > [ [1,b] product ] [ drop 1 ] if ;
  11
  12 : factorial/ ( n k -- n!/k! )
  13     {
  14         { [ dup 1 < ] [ drop factorial ] }
  15         { [ over 1 < ] [ nip factorial recip ] }
  16         [
  17             2dup < [ t ] [ swap f ] if
  18             [ (a,b] product ] dip [ recip ] when
  19         ]
  20     } cond ;
  21
  22 : rising-factorial ( x n -- x(n) )
  23     {
  24         { 1 [ ] }
  25         { 0 [ drop 0 ] }
  26         [
  27             dup 0 < [ neg [ + ] keep t ] [ f ] if
  28             [ dupd + [a,b) product ] dip
  29             [ recip ] when
  30         ]
  31     } case ;
  32
  33 ALIAS: pochhammer rising-factorial
  34
  35 : falling-factorial ( x n -- (x)n )
  36     {
  37         { 1 [ ] }
  38         { 0 [ drop 0 ] }
  39         [
  40             dup 0 < [ neg [ + ] keep t ] [ f ] if
  41             [ dupd - swap (a,b] product ] dip
  42             [ recip ] when
  43         ]
  44     } case ;
  45
  46 : factorial-power ( x n h -- (x)n(h) )
  47     {
  48         { 1 [ falling-factorial ] }
  49         { 0 [ ^ ] }
  50         [
  51             over 0 < [
  52                 [ [ nip + ] [ swap neg * + ] 3bi ] keep
  53                 <range> product recip
  54             ] [
  55                 neg [ [ dupd 1 - ] [ * ] bi* + ] keep
  56                 <range> product
  57             ] if
  58         ]
  59     } case ;