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

Update syntax for extra/math vocabs

db4
Aaron Schaefer 2008-11-07 01:24:32 -05:00
parent 8ec695332a
commit 67ce49dc59
12 changed files with 121 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,10 +1,9 @@
! Copyright (c) 2007 Samuel Tardieu
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions sequences fry ;
IN: math.algebra
: chinese-remainder ( aseq nseq -- x )
dup product
[
dup product [
'[ _ over / [ swap gcd drop ] keep * * ] 2map sum
] keep rem ; foldable

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

@ -19,7 +19,7 @@ IN: math.combinatorics
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq )
[ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ;
[ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;

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

@ -1,21 +1,19 @@
! Copyright (C) 2008 John Benediktsson
! Copyright (C) 2008 John Benediktsson.
! See http://factorcode.org/license.txt for BSD license
USING: math math.order kernel ;
IN: math.compare
IN: math.compare
: absmin ( a b -- x )
[ [ abs ] bi@ < ] 2keep ? ;
: absmin ( a b -- x )
[ [ abs ] bi@ < ] 2keep ? ;
: absmax ( a b -- x )
[ [ abs ] bi@ > ] 2keep ? ;
: absmax ( a b -- x )
[ [ abs ] bi@ > ] 2keep ? ;
: posmax ( a b -- x )
0 max max ;
: posmax ( a b -- x )
0 max max ;
: negmin ( a b -- x )
0 min min ;
: negmin ( a b -- x )
0 min min ;
: clamp ( a value b -- x )
min max ;
min max ;

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

@ -1,6 +1,7 @@
USING: kernel continuations combinators sequences math
math.order math.ranges accessors float-arrays ;
! Copyright (c) 2008 Reginald Keith Ford II, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations combinators sequences math math.order math.ranges
accessors float-arrays ;
IN: math.derivatives
TUPLE: state x func h err i j errt fac hh ans a done ;
@ -20,7 +21,8 @@ TUPLE: state x func h err i j errt fac hh ans a done ;
: a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ;
: check-h ( state -- state )
dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
: init-a ( state -- state ) ntab [ ntab <float-array> ] replicate >>a ;
: init-hh ( state -- state ) dup h>> >>hh ;
: init-err ( state -- state ) big >>err ;
@ -30,75 +32,66 @@ TUPLE: state x func h err i j errt fac hh ans a done ;
! If error is decreased, save the improved answer
: error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ;
: save-improved-answer ( state -- state )
dup err>> >>errt
dup a[j][i] >>ans ;
dup err>> >>errt
dup a[j][i] >>ans ;
! If higher order is worse by a significant factor SAFE, then quit early.
: check-safe ( state -- state )
dup
[ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >=
[ t >>done ]
when ;
dup [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ]
[ err>> safe * ] bi >= [ t >>done ] when ;
: x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ;
: x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ;
: limit-approx ( state -- val )
[
[ [ x+hh ] [ func>> ] bi call ]
[ [ x-hh ] [ func>> ] bi call ]
bi -
]
[ hh>> 2.0 * ]
bi / ;
[
[ [ x+hh ] [ func>> ] bi call ]
[ [ x-hh ] [ func>> ] bi call ] bi -
] [ hh>> 2.0 * ] bi / ;
: a[0][0]! ( state -- state )
{ [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
{ [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
: a[0][i]! ( state -- state )
{ [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
{ [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
: a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ;
: new-a[j][i] ( state -- val )
[ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
[ fac>> 1.0 - ]
bi / ;
[ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
[ fac>> 1.0 - ] bi / ;
: a[j][i]! ( state -- state )
{ [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
{ [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
: update-errt ( state -- state )
dup
[ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
[ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ]
bi max
>>errt ;
dup [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
[ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ] bi max >>errt ;
: not-done? ( state -- state ? ) dup done>> not ;
: derive ( state -- state )
init-a
check-h
init-hh
a[0][0]!
init-err
1 ntab [a,b)
[
>>i
not-done?
[
update-hh
a[0][i]!
reset-fac
1 over i>> [a,b]
[
>>j
a[j][i]!
update-fac
update-errt
error-decreased? [ save-improved-answer ] when
]
each
check-safe
]
when
]
each ;
init-a
check-h
init-hh
a[0][0]!
init-err
1 ntab [a,b) [
>>i not-done? [
update-hh
a[0][i]!
reset-fac
1 over i>> [a,b] [
>>j
a[j][i]!
update-fac
update-errt
error-decreased? [ save-improved-answer ] when
] each check-safe
] when
] each ;
: derivative-state ( x func h err -- state )
state new
@ -112,11 +105,7 @@ TUPLE: state x func h err i j errt fac hh ans a done ;
! h should be small enough to give the correct sgn(f'(x))
! err is the max tolerance of gain in error for a single iteration-
: (derivative) ( x func h err -- ans error )
derivative-state
derive
[ ans>> ]
[ errt>> ]
bi ;
derivative-state derive [ ans>> ] [ errt>> ] bi ;
: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
: derivative-func ( func -- der ) [ derivative ] curry ;

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

@ -1,7 +1,7 @@
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
math.ranges sequences accessors ;
USING: accessors bit-arrays fry kernel lists.lazy math math.functions
math.primes.list math.ranges sequences ;
IN: math.erato
<PRIVATE
@ -9,35 +9,35 @@ IN: math.erato
TUPLE: erato limit bits latest ;
: ind ( n -- i )
2/ 1- ; inline
2/ 1- ; inline
: is-prime ( n limit -- bool )
[ ind ] [ bits>> ] bi* nth ; inline
[ ind ] [ bits>> ] bi* nth ; inline
: indices ( n erato -- range )
limit>> ind over 3 * ind swap rot <range> ;
limit>> ind over 3 * ind swap rot <range> ;
: mark-multiples ( n erato -- )
over sq over limit>> <=
[ [ indices ] keep bits>> [ f -rot set-nth ] curry each ] [ 2drop ] if ;
2dup [ sq ] [ limit>> ] bi* <= [
[ indices ] keep bits>> '[ _ f -rot set-nth ] each
] [ 2drop ] if ;
: <erato> ( n -- erato )
dup ind 1+ <bit-array> 1 over set-bits erato boa ;
dup ind 1+ <bit-array> dup set-bits 1 erato boa ;
: next-prime ( erato -- prime/f )
[ 2 + ] change-latest [ latest>> ] keep
2dup limit>> <=
[
2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
] [
2drop f
] if ;
[ 2 + ] change-latest [ latest>> ] keep
2dup limit>> <= [
2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
] [
2drop f
] if ;
PRIVATE>
: lerato ( n -- lazy-list )
dup 1000003 < [
0 primes-under-million seq>list swap [ <= ] curry lwhile
] [
<erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
] if ;
dup 1000003 < [
0 primes-under-million seq>list swap '[ _ <= ] lwhile
] [
<erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
] if ;

2
extra/math/erato/summary.txt
View File

@ -1 +1 @@
Sieve of Eratosthene
Sieve of Eratosthenes

25
extra/math/function-tools/function-tools.factor
View File

@ -1,9 +1,18 @@
! Copyright © 2008 Reginald Keith Ford II
! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions
! Copyright (c) 2008 Reginald Keith Ford II.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math arrays sequences sequences.lib ;
IN: math.function-tools
: difference-func ( func func -- func ) [ bi - ] 2curry ; inline
: eval ( x func -- pt ) dupd call 2array ; inline
: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline
: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline
IN: math.function-tools
! Tools for quickly comparing, transforming, and evaluating mathematical functions
: difference-func ( func func -- func )
[ bi - ] 2curry ; inline
: eval ( x func -- pt )
dupd call 2array ; inline
: eval-inverse ( y func -- pt )
dupd call swap 2array ; inline
: eval3d ( x y func -- pt )
[ 2dup ] dip call 3array ; inline

18
extra/math/matrices/elimination/elimination.factor
View File

@ -21,17 +21,17 @@ SYMBOL: matrix
: cols ( -- n ) 0 nth-row length ;
: skip ( i seq quot -- n )
over >r find-from drop r> length or ; inline
over [ find-from drop ] dip length or ; inline
: first-col ( row# -- n )
#! First non-zero column
0 swap nth-row [ zero? not ] skip ;
: clear-scale ( col# pivot-row i-row -- n )
>r over r> nth dup zero? [
[ over ] dip nth dup zero? [
3drop 0
] [
>r nth dup zero? r> swap [
[ nth dup zero? ] dip swap [
2drop 0
] [
swap / neg
@ -39,13 +39,13 @@ SYMBOL: matrix
] if ;
: (clear-col) ( col# pivot-row i -- )
[ [ clear-scale ] 2keep >r n*v r> v+ ] change-row ;
[ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
: rows-from ( row# -- slice )
rows dup <slice> ;
: clear-col ( col# row# rows -- )
>r nth-row r> [ >r 2dup r> (clear-col) ] each 2drop ;
[ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
: do-row ( exchange-with row# -- )
[ exchange-rows ] keep
@ -53,7 +53,7 @@ SYMBOL: matrix
dup 1+ rows-from clear-col ;
: find-row ( row# quot -- i elt )
>r rows-from r> find ; inline
[ rows-from ] dip find ; inline
: pivot-row ( col# row# -- n )
[ dupd nth-row nth zero? not ] find-row 2nip ;
@ -61,7 +61,7 @@ SYMBOL: matrix
: (echelon) ( col# row# -- )
over cols < over rows < and [
2dup pivot-row [ over do-row 1+ ] when*
>r 1+ r> (echelon)
[ 1+ ] dip (echelon)
] [
2drop
] if ;
@ -86,10 +86,10 @@ SYMBOL: matrix
] with-matrix ;
: basis-vector ( row col# -- )
>r clone r>
[ clone ] dip
[ swap nth neg recip ] 2keep
[ 0 spin set-nth ] 2keep
>r n*v r>
[ n*v ] dip
matrix get set-nth ;
: nullspace ( matrix -- seq )

7
extra/math/matrices/matrices.factor
View File

@ -1,7 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences math math.functions
math.vectors math.order ;
USING: arrays kernel math math.order math.vectors sequences ;
IN: math.matrices
! Matrices
@ -29,8 +28,8 @@ IN: math.matrices
: m.v ( m v -- v ) [ v. ] curry map ;
: m. ( m m -- m ) flip [ swap m.v ] curry map ;
: mmin ( m -- n ) >r 1/0. r> [ [ min ] each ] each ;
: mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ;
: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ;
<PRIVATE

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

@ -12,7 +12,7 @@ IN: math.miller-rabin
TUPLE: positive-even-expected n ;
: (factor-2s) ( r s -- r s )
dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
dup even? [ -1 shift [ 1+ ] dip (factor-2s) ] when ;
: factor-2s ( n -- r s )
#! factor an integer into s * 2^r

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

@ -1,9 +1,10 @@
! Copyright © 2008 Reginald Keith Ford II
! Copyright (c) 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
! Newton's method of approximating roots
<PRIVATE
: newton-step ( x function -- x2 )

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

@ -1,9 +1,10 @@
! Copyright © 2008 Reginald Keith Ford II
! Copyright (c) 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
! Secant method of approximating roots
<PRIVATE
: secant-solution ( x1 x2 function -- solution )