! Copyright (c) 2007 Samuel Tardieu
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions sequences ;
+USING: kernel math math.functions sequences fry ;
IN: math.algebra
: chinese-remainder ( aseq nseq -- x )
dup product
- [ [ over / [ swap gcd drop ] keep * * ] curry 2map sum ] keep rem ; foldable
+ [
+ '[ _ over / [ swap gcd drop ] keep * * ] 2map sum
+ ] keep rem ; foldable
+! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.constants math.functions math.intervals
-math.vectors namespaces sequences ;
+math.vectors namespaces sequences combinators.short-circuit ;
IN: math.analysis
<PRIVATE
: (gamma-lanczos6) ( x -- log[gamma[x+1]] )
#! log(gamma(x+1)
- dup 0.5 + dup gamma-g6 + dup >r log * r> -
- swap 6 gamma-z gamma-p6 v. log + ;
+ [ 0.5 + dup gamma-g6 + dup [ log * ] dip - ]
+ [ 6 gamma-z gamma-p6 v. log ] bi + ;
: gamma-lanczos6 ( x -- gamma[x] )
#! gamma(x) = gamma(x+1) / x
: gamma ( x -- y )
#! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
#! gamma(n+1) = n! for n > 0
- dup 0.0 <= over 1.0 mod zero? and [
+ dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
drop 1./0.
] [
dup abs gamma-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if
] if ;
: nth-root ( n x -- y )
- over 0 = [ "0th root is undefined" throw ] when >r recip r> swap ^ ;
+ [ recip ] dip swap ^ ;
! Forth Scientific Library Algorithm #1
!
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math math.order math.ranges mirrors
-namespaces make sequences sequences.lib sorting ;
+namespaces sequences sorting fry ;
IN: math.combinatorics
<PRIVATE
2dup - dupd > [ dupd - ] when ; inline
! See this article for explanation of the factoradic-based permutation methodology:
-! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
+! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
: factoradic ( n -- factoradic )
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
twiddle [ nPk ] keep factorial / ;
: permutation ( n seq -- seq )
- tuck permutation-indices swap nths ;
+ [ permutation-indices ] keep nths ;
: all-permutations ( seq -- seq )
- [
- [ length factorial ] keep [ permutation , ] curry each
- ] { } make ;
+ [ length factorial ] keep '[ _ permutation ] map ;
: inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ;
-
: clamp ( a value b -- x )
min max ;
-
-
USING: kernel continuations combinators sequences math
math.order math.ranges accessors float-arrays ;
TUPLE: state x func h err i j errt fac hh ans a done ;
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
-: ntab ( -- val ) 8 ;
-: con ( -- val ) 1.6 ;
-: con2 ( -- val ) con con * ;
-: big ( -- val ) largest-float ;
-: safe ( -- val ) 2.0 ;
+: ntab ( -- val ) 8 ; inline
+: con ( -- val ) 1.6 ; inline
+: con2 ( -- val ) con con * ; inline
+: big ( -- val ) largest-float ; inline
+: safe ( -- val ) 2.0 ; inline
! Yes, this was ported from C code.
: a[i][i] ( state -- elt ) [ i>> ] [ i>> ] [ a>> ] tri nth nth ;
bi ;
: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
-: derivative-func ( func -- der ) [ derivative ] curry ;
\ No newline at end of file
+: derivative-func ( func -- der ) [ derivative ] curry ;
: ind ( n -- i )
2/ 1- ; inline
-: is-prime ( n erato -- bool )
- >r ind r> bits>> nth ; inline
+: is-prime ( n limit -- bool )
+ [ ind ] [ bits>> ] bi* nth ; inline
: indices ( n erato -- range )
limit>> ind over 3 * ind swap rot <range> ;
: odd ( seq -- seq ) 2 group 1 <column> ;
DEFER: fft
: two ( seq -- seq ) fft 2 v/n dup append ;
-: omega ( n -- n ) recip -2 pi i* * * exp ;
+: omega ( n -- n' ) recip -2 pi i* * * exp ;
: twiddle ( seq -- seq ) dup length dup omega swap n^v v* ;
: (fft) ( seq -- seq ) dup odd two twiddle swap even two v+ ;
: fft ( seq -- seq ) dup length 1 = [ (fft) ] unless ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators combinators.lib io locals kernel math
math.functions math.ranges namespaces random sequences
hashtables sets ;
! Copyright © 2008 Reginald Keith Ford II
+! See http://factorcode.org/license.txt for BSD license.
! Newton's Method of approximating roots
-
USING: kernel math math.derivatives ;
IN: math.newtons-method
<PRIVATE
-: newton-step ( x function -- x2 ) dupd [ call ] [ derivative ] 2bi / - ;
-: newton-precision ( -- n ) 13 ;
+
+: newton-step ( x function -- x2 )
+ dupd [ call ] [ derivative ] 2bi / - ; inline
+
+: newton-precision ( -- n ) 13 ; inline
+
PRIVATE>
-: newtons-method ( guess function -- x ) newton-precision [ [ newton-step ] keep ] times drop ;
+
+: newtons-method ( guess function -- x )
+ newton-precision [ [ newton-step ] keep ] times drop ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences namespaces make math math.ranges
math.vectors vectors ;
IN: math.numerical-integration
SYMBOL: num-steps 180 num-steps set-global
+
: setup-simpson-range ( from to -- frange )
2dup swap - num-steps get / <range> ;
: generate-simpson-weights ( seq -- seq )
- [
- { 1 4 } % length 2 / 2 - { 2 4 } <repetition> concat % 1 ,
- ] { } make ;
+ { 1 4 }
+ swap length 2 / 2 - { 2 4 } <repetition> concat
+ { 1 } 3append ;
: integrate-simpson ( from to f -- x )
- >r setup-simpson-range r>
- dupd map dup generate-simpson-weights
+ [ setup-simpson-range dup ] dip
+ map dup generate-simpson-weights
v. swap [ third ] keep first - 6 / * ;
-
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences vectors math math.vectors
namespaces make shuffle splitting sequences.lib math.order ;
IN: math.polynomials
: polyval ( p x -- p[x] )
#! Evaluate a polynomial.
- >r dup length r> powers v. ;
+ [ dup length ] dip powers v. ;
<PRIVATE
: find-prime-miller-rabin ( n -- p )
- dup miller-rabin [ 2 + find-prime-miller-rabin ] unless ; foldable
+ dup miller-rabin [ 2 + find-prime-miller-rabin ] unless ; foldable
PRIVATE>
: next-prime ( n -- p )
- dup 999983 < [
- primes-under-million [ natural-search drop 1+ ] keep nth
- ] [
- next-odd find-prime-miller-rabin
- ] if ; foldable
+ dup 999983 < [
+ primes-under-million [ natural-search drop 1+ ] keep nth
+ ] [
+ next-odd find-prime-miller-rabin
+ ] if ; foldable
: prime? ( n -- ? )
- dup 1000000 < [
- dup primes-under-million natural-search nip =
- ] [
- miller-rabin
- ] if ; foldable
+ dup 1000000 < [
+ dup primes-under-million natural-search nip =
+ ] [
+ miller-rabin
+ ] if ; foldable
: lprimes ( -- list )
- 0 primes-under-million seq>list
- 1000003 [ 2 + find-prime-miller-rabin ] lfrom-by
- lappend ;
+ 0 primes-under-million seq>list
+ 1000003 [ 2 + find-prime-miller-rabin ] lfrom-by
+ lappend ;
: lprimes-from ( n -- list )
- dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
+ dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
: primes-upto ( n -- seq )
- {
- { [ dup 2 < ] [ drop { } ] }
- { [ dup 1000003 < ]
- [ primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice> ] }
- [ primes-under-million 1000003 lprimes-from
- rot [ <= ] curry lwhile list>array append ]
- } cond ; foldable
+ {
+ { [ dup 2 < ] [ drop { } ] }
+ { [ dup 1000003 < ] [
+ primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice>
+ ] }
+ [ primes-under-million 1000003 lprimes-from
+ rot [ <= ] curry lwhile list>array append ]
+ } cond ; foldable
: primes-between ( low high -- seq )
- primes-upto
- [ 1- next-prime ] dip
- [ natural-search drop ] keep [ length ] keep <slice> ; foldable
+ primes-upto
+ [ 1- next-prime ] dip
+ [ natural-search drop ] keep [ length ] keep <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
: qconjugate ( u -- u' )
#! Quaternion conjugate.
- first2 neg >r conjugate r> 2array ;
+ first2 [ conjugate ] [ neg ] bi* 2array ;
: qrecip ( u -- 1/u )
#! Quaternion inverse.
! Copyright © 2008 Reginald Keith Ford II
+! See http://factorcode.org/license.txt for BSD license.
! Secant Method of approximating roots
-
USING: kernel math math.function-tools math.points math.vectors ;
IN: math.secant-method
<PRIVATE
-: secant-solution ( x1 x2 function -- solution ) [ eval ] curry bi@ linear-solution ;
-: secant-step ( x1 x2 func -- x2 x3 func ) 2dup [ secant-solution ] 2dip swapd ;
-: secant-precision ( -- n ) 15 ;
+
+: secant-solution ( x1 x2 function -- solution )
+ [ eval ] curry bi@ linear-solution ;
+
+: secant-step ( x1 x2 func -- x2 x3 func )
+ [ secant-solution ] 2keep swapd ;
+
+: secant-precision ( -- n ) 15 ; inline
+
PRIVATE>
-: secant-method ( left right function -- x ) secant-precision [ secant-step ] times drop + 2 / ;
+
+: secant-method ( left right function -- x )
+ secant-precision [ secant-step ] times drop + 2 / ;
+
! : close-enough? ( a b -- t/f ) - abs tiny-amount < ;
-! : secant-method2 ( left right function -- x ) 2over close-enough? [ drop average ] [ secant-step secant-method ] if ;
\ No newline at end of file
+
+! : secant-method2 ( left right function -- x )
+ ! 2over close-enough?
+ ! [ drop average ] [ secant-step secant-method ] if ;
+! Copyright (C) 2008 Doug Coleman, Michael Judge.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.analysis math.functions math.vectors sequences
- sequences.lib sorting ;
+sequences.lib sorting ;
IN: math.statistics
: mean ( seq -- n )
: median ( seq -- n )
#! middle number if odd, avg of two middle numbers if even
natural-sort dup length dup even? [
- 1- 2 / swap [ nth ] [ >r 1+ r> nth ] 2bi + 2 /
+ 1- 2 / swap [ nth ] [ [ 1+ ] dip nth ] 2bi + 2 /
] [
2 / swap nth
] if ;
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.parser namespaces
- sequences splitting grouping sequences.lib
- combinators.short-circuit ;
+sequences splitting grouping combinators.short-circuit ;
IN: math.text.english
<PRIVATE
] if ;
: (number>text) ( n -- str )
- dup negative-text swap abs 3digit-groups recombine append ;
+ [ negative-text ] [ abs 3digit-groups recombine ] bi append ;
PRIVATE>
: number>text ( n -- str )
- dup zero? [
- small-numbers
- ] [
- [ (number>text) ] with-scope
- ] if ;
+ dup zero? [ small-numbers ] [ [ (number>text) ] with-scope ] if ;
-
+! Copyright (C) 2008 Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
USING: math math.constants ;
-
IN: math.trig
: deg>rad pi * 180 / ; inline
projects / factor.git / commitdiff