steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

initial math cleanup

db4
Doug Coleman 2008-10-03 02:19:03 -05:00
parent e7a785c58f
commit 56a0af9628
17 changed files with 101 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
extra/math/algebra/algebra.factor
View File

@ -1,8 +1,10 @@
! 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

12
extra/math/analysis/analysis.factor
View File

@ -1,5 +1,7 @@
! 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
@ -20,8 +22,8 @@ IN: math.analysis
: (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
@ -39,7 +41,7 @@ PRIVATE>
: 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
@ -55,7 +57,7 @@ PRIVATE>
] 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
!

11
extra/math/combinatorics/combinatorics.factor
View File

@ -1,7 +1,7 @@
! 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
@ -13,7 +13,7 @@ IN: math.combinatorics
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 ;
@ -39,13 +39,10 @@ PRIVATE>
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 ;

1
extra/math/compare/compare.factor
View File

@ -19,4 +19,3 @@ IN: math.compare
: clamp ( a value b -- x )
min max ;

13
extra/math/derivatives/derivatives.factor
View File

@ -1,4 +1,3 @@
USING: kernel continuations combinators sequences math
math.order math.ranges accessors float-arrays ;
@ -7,11 +6,11 @@ IN: math.derivatives
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 ;
@ -120,4 +119,4 @@ TUPLE: state x func h err i j errt fac hh ans a done ;
bi ;
: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
: derivative-func ( func -- der ) [ derivative ] curry ;
: derivative-func ( func -- der ) [ derivative ] curry ;

4
extra/math/erato/erato.factor
View File

@ -11,8 +11,8 @@ TUPLE: erato limit bits latest ;
: 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> ;

2
extra/math/fft/fft.factor
View File

@ -9,7 +9,7 @@ IN: math.fft
: 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 ;

2
extra/math/miller-rabin/miller-rabin.factor
View File

@ -1,3 +1,5 @@
! 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 ;

14
extra/math/newtons-method/newtons-method.factor
View File

@ -1,11 +1,17 @@
! 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 ;

14
extra/math/numerical-integration/numerical-integration.factor
View File

@ -1,18 +1,20 @@
! 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 / * ;

4
extra/math/polynomials/polynomials.factor
View File

@ -1,3 +1,5 @@
! 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
@ -82,5 +84,5 @@ PRIVATE>
: polyval ( p x -- p[x] )
#! Evaluate a polynomial.
>r dup length r> powers v. ;
[ dup length ] dip powers v. ;

51
extra/math/primes/primes.factor
View File

@ -8,44 +8,45 @@ IN: math.primes
<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

2
extra/math/quaternions/quaternions.factor
View File

@ -28,7 +28,7 @@ PRIVATE>
: qconjugate ( u -- u' )
#! Quaternion conjugate.
first2 neg >r conjugate r> 2array ;
first2 [ conjugate ] [ neg ] bi* 2array ;
: qrecip ( u -- 1/u )
#! Quaternion inverse.

24
extra/math/secant-method/secant-method.factor
View File

@ -1,14 +1,26 @@
! 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 ;
! : secant-method2 ( left right function -- x )
! 2over close-enough?
! [ drop average ] [ secant-step secant-method ] if ;

6
extra/math/statistics/statistics.factor
View File

@ -1,5 +1,7 @@
! 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 )
@ -18,7 +20,7 @@ IN: math.statistics
: 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 ;

11
extra/math/text/english/english.factor
View File

@ -1,8 +1,7 @@
! 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
@ -86,14 +85,10 @@ SYMBOL: and-needed?
] 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 ;

4
extra/math/trig/trig.factor
View File

@ -1,6 +1,6 @@
! 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