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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions sequences fry ; USING: kernel math math.functions sequences fry ;
IN: math.algebra IN: math.algebra
: chinese-remainder ( aseq nseq -- x ) : chinese-remainder ( aseq nseq -- x )
dup product dup product [
[
'[ _ over / [ swap gcd drop ] keep * * ] 2map sum '[ _ over / [ swap gcd drop ] keep * * ] 2map sum
] keep rem ; foldable ] 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 ; 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq ) : (>permutation) ( seq n -- seq )
[ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ; [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
: >permutation ( factoradic -- permutation ) : >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ; reverse 1 cut [ (>permutation) ] each ;

14
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 ! See http://factorcode.org/license.txt for BSD license
USING: math math.order kernel ; USING: math math.order kernel ;
IN: math.compare IN: math.compare
: absmin ( a b -- x ) : absmin ( a b -- x )
[ [ abs ] bi@ < ] 2keep ? ; [ [ abs ] bi@ < ] 2keep ? ;
: absmax ( a b -- x ) : absmax ( a b -- x )
[ [ abs ] bi@ > ] 2keep ? ; [ [ abs ] bi@ > ] 2keep ? ;
: posmax ( a b -- x ) : posmax ( a b -- x )
0 max max ; 0 max max ;
: negmin ( a b -- x ) : negmin ( a b -- x )
0 min min ; 0 min min ;
: clamp ( a value b -- x ) : clamp ( a value b -- x )
min max ; min max ;

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

@ -1,6 +1,7 @@
USING: kernel continuations combinators sequences math ! Copyright (c) 2008 Reginald Keith Ford II, Eduardo Cavazos.
math.order math.ranges accessors float-arrays ; ! 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 IN: math.derivatives
TUPLE: state x func h err i j errt fac hh ans a done ; 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 ; : a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ;
: check-h ( state -- state ) : 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-a ( state -- state ) ntab [ ntab <float-array> ] replicate >>a ;
: init-hh ( state -- state ) dup h>> >>hh ; : init-hh ( state -- state ) dup h>> >>hh ;
: init-err ( state -- state ) big >>err ; : 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 ! If error is decreased, save the improved answer
: error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ; : error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ;
: save-improved-answer ( state -- state ) : save-improved-answer ( state -- state )
dup err>> >>errt dup err>> >>errt
dup a[j][i] >>ans ; dup a[j][i] >>ans ;
! If higher order is worse by a significant factor SAFE, then quit early. ! If higher order is worse by a significant factor SAFE, then quit early.
: check-safe ( state -- state ) : check-safe ( state -- state )
dup dup [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ]
[ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >= [ err>> safe * ] bi >= [ t >>done ] when ;
[ t >>done ]
when ;
: x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ; : x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ;
: x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ; : x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ;
: limit-approx ( state -- val ) : limit-approx ( state -- val )
[ [
[ [ x+hh ] [ func>> ] bi call ] [ [ x+hh ] [ func>> ] bi call ]
[ [ x-hh ] [ func>> ] bi call ] [ [ x-hh ] [ func>> ] bi call ] bi -
bi - ] [ hh>> 2.0 * ] bi / ;
]
[ hh>> 2.0 * ]
bi / ;
: a[0][0]! ( state -- state ) : 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 ) : 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 * ; : a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ;
: new-a[j][i] ( state -- val ) : new-a[j][i] ( state -- val )
[ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ] [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
[ fac>> 1.0 - ] [ fac>> 1.0 - ] bi / ;
bi / ;
: a[j][i]! ( state -- state ) : 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 ) : update-errt ( state -- state )
dup dup [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
[ [ a[j][i] ] [ a[j-1][i] ] bi - abs ] [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ] bi max >>errt ;
[ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ]
bi max
>>errt ;
: not-done? ( state -- state ? ) dup done>> not ; : not-done? ( state -- state ? ) dup done>> not ;
: derive ( state -- state ) : derive ( state -- state )
init-a init-a
check-h check-h
init-hh init-hh
a[0][0]! a[0][0]!
init-err init-err
1 ntab [a,b) 1 ntab [a,b) [
[ >>i not-done? [
>>i update-hh
not-done? a[0][i]!
[ reset-fac
update-hh 1 over i>> [a,b] [
a[0][i]! >>j
reset-fac a[j][i]!
1 over i>> [a,b] update-fac
[ update-errt
>>j error-decreased? [ save-improved-answer ] when
a[j][i]! ] each check-safe
update-fac ] when
update-errt ] each ;
error-decreased? [ save-improved-answer ] when
]
each
check-safe
]
when
]
each ;
: derivative-state ( x func h err -- state ) : derivative-state ( x func h err -- state )
state new 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)) ! 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- ! err is the max tolerance of gain in error for a single iteration-
: (derivative) ( x func h err -- ans error ) : (derivative) ( x func h err -- ans error )
derivative-state derivative-state derive [ ans>> ] [ errt>> ] bi ;
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 ; : derivative-func ( func -- der ) [ derivative ] curry ;

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

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

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

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

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

@ -1,9 +1,18 @@
! Copyright © 2008 Reginald Keith Ford II ! Copyright (c) 2008 Reginald Keith Ford II.
! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math arrays sequences sequences.lib ; USING: kernel math arrays sequences sequences.lib ;
IN: math.function-tools IN: math.function-tools
: difference-func ( func func -- func ) [ bi - ] 2curry ; inline
: eval ( x func -- pt ) dupd call 2array ; inline ! Tools for quickly comparing, transforming, and evaluating mathematical functions
: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline
: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline : 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 ; : cols ( -- n ) 0 nth-row length ;
: skip ( i seq quot -- n ) : 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-col ( row# -- n )
#! First non-zero column #! First non-zero column
0 swap nth-row [ zero? not ] skip ; 0 swap nth-row [ zero? not ] skip ;
: clear-scale ( col# pivot-row i-row -- n ) : clear-scale ( col# pivot-row i-row -- n )
>r over r> nth dup zero? [ [ over ] dip nth dup zero? [
3drop 0 3drop 0
] [ ] [
>r nth dup zero? r> swap [ [ nth dup zero? ] dip swap [
2drop 0 2drop 0
] [ ] [
swap / neg swap / neg
@ -39,13 +39,13 @@ SYMBOL: matrix
] if ; ] if ;
: (clear-col) ( col# pivot-row i -- ) : (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-from ( row# -- slice )
rows dup <slice> ; rows dup <slice> ;
: clear-col ( col# row# rows -- ) : 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# -- ) : do-row ( exchange-with row# -- )
[ exchange-rows ] keep [ exchange-rows ] keep
@ -53,7 +53,7 @@ SYMBOL: matrix
dup 1+ rows-from clear-col ; dup 1+ rows-from clear-col ;
: find-row ( row# quot -- i elt ) : find-row ( row# quot -- i elt )
>r rows-from r> find ; inline [ rows-from ] dip find ; inline
: pivot-row ( col# row# -- n ) : pivot-row ( col# row# -- n )
[ dupd nth-row nth zero? not ] find-row 2nip ; [ dupd nth-row nth zero? not ] find-row 2nip ;
@ -61,7 +61,7 @@ SYMBOL: matrix
: (echelon) ( col# row# -- ) : (echelon) ( col# row# -- )
over cols < over rows < and [ over cols < over rows < and [
2dup pivot-row [ over do-row 1+ ] when* 2dup pivot-row [ over do-row 1+ ] when*
>r 1+ r> (echelon) [ 1+ ] dip (echelon)
] [ ] [
2drop 2drop
] if ; ] if ;
@ -86,10 +86,10 @@ SYMBOL: matrix
] with-matrix ; ] with-matrix ;
: basis-vector ( row col# -- ) : basis-vector ( row col# -- )
>r clone r> [ clone ] dip
[ swap nth neg recip ] 2keep [ swap nth neg recip ] 2keep
[ 0 spin set-nth ] 2keep [ 0 spin set-nth ] 2keep
>r n*v r> [ n*v ] dip
matrix get set-nth ; matrix get set-nth ;
: nullspace ( matrix -- seq ) : nullspace ( matrix -- seq )

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

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

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

@ -12,7 +12,7 @@ IN: math.miller-rabin
TUPLE: positive-even-expected n ; TUPLE: positive-even-expected n ;
: (factor-2s) ( r s -- r s ) : (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-2s ( n -- r s )
#! factor an integer into s * 2^r #! 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. ! See http://factorcode.org/license.txt for BSD license.
! Newton's Method of approximating roots
USING: kernel math math.derivatives ; USING: kernel math math.derivatives ;
IN: math.newtons-method IN: math.newtons-method
! Newton's method of approximating roots
<PRIVATE <PRIVATE
: newton-step ( x function -- x2 ) : 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. ! See http://factorcode.org/license.txt for BSD license.
! Secant Method of approximating roots
USING: kernel math math.function-tools math.points math.vectors ; USING: kernel math math.function-tools math.points math.vectors ;
IN: math.secant-method IN: math.secant-method
! Secant method of approximating roots
<PRIVATE <PRIVATE
: secant-solution ( x1 x2 function -- solution ) : secant-solution ( x1 x2 function -- solution )