From 67ce49dc594b234c8f7fc96c5814190009698380 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 7 Nov 2008 01:24:32 -0500 Subject: [PATCH] Update syntax for extra/math vocabs --- extra/math/algebra/algebra.factor | 5 +- extra/math/combinatorics/combinatorics.factor | 2 +- extra/math/compare/compare.factor | 24 ++-- extra/math/derivatives/derivatives.factor | 111 ++++++++---------- extra/math/erato/erato.factor | 40 +++---- extra/math/erato/summary.txt | 2 +- .../math/function-tools/function-tools.factor | 25 ++-- .../matrices/elimination/elimination.factor | 18 +-- extra/math/matrices/matrices.factor | 7 +- extra/math/miller-rabin/miller-rabin.factor | 2 +- .../math/newtons-method/newtons-method.factor | 5 +- extra/math/secant-method/secant-method.factor | 5 +- 12 files changed, 121 insertions(+), 125 deletions(-) diff --git a/extra/math/algebra/algebra.factor b/extra/math/algebra/algebra.factor index 8cccded26a..82a2578a7f 100644 --- a/extra/math/algebra/algebra.factor +++ b/extra/math/algebra/algebra.factor @@ -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 diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor index 00a104b381..1bc692ca54 100644 --- a/extra/math/combinatorics/combinatorics.factor +++ b/extra/math/combinatorics/combinatorics.factor @@ -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 ; diff --git a/extra/math/compare/compare.factor b/extra/math/compare/compare.factor index d19dac3d2b..826f0ecf16 100644 --- a/extra/math/compare/compare.factor +++ b/extra/math/compare/compare.factor @@ -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 ; diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor index b7612e112b..7922a48a6b 100644 --- a/extra/math/derivatives/derivatives.factor +++ b/extra/math/derivatives/derivatives.factor @@ -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 ] 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 ; diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index 4c6675e8f1..894905e405 100644 --- a/extra/math/erato/erato.factor +++ b/extra/math/erato/erato.factor @@ -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 > ] bi* nth ; inline + [ ind ] [ bits>> ] bi* nth ; inline : indices ( n erato -- range ) - limit>> ind over 3 * ind swap rot ; + limit>> ind over 3 * ind swap rot ; : 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 ; : ( n -- erato ) - dup ind 1+ 1 over set-bits erato boa ; + dup ind 1+ 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 - ] [ - 2 [ drop next-prime ] with lfrom-by [ ] lwhile - ] if ; + dup 1000003 < [ + 0 primes-under-million seq>list swap '[ _ <= ] lwhile + ] [ + 2 [ drop next-prime ] with lfrom-by [ ] lwhile + ] if ; diff --git a/extra/math/erato/summary.txt b/extra/math/erato/summary.txt index e8982fa3e0..ee15b7e06f 100644 --- a/extra/math/erato/summary.txt +++ b/extra/math/erato/summary.txt @@ -1 +1 @@ -Sieve of Eratosthene +Sieve of Eratosthenes diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor index ec93a0891a..3bc785c1b6 100644 --- a/extra/math/function-tools/function-tools.factor +++ b/extra/math/function-tools/function-tools.factor @@ -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 diff --git a/extra/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor index 6e83a61eb3..0368dd5286 100755 --- a/extra/math/matrices/elimination/elimination.factor +++ b/extra/math/matrices/elimination/elimination.factor @@ -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 ; : 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 ) diff --git a/extra/math/matrices/matrices.factor b/extra/math/matrices/matrices.factor index 529ddb083a..0088b17372 100755 --- a/extra/math/matrices/matrices.factor +++ b/extra/math/matrices/matrices.factor @@ -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 ; 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 diff --git a/extra/math/newtons-method/newtons-method.factor b/extra/math/newtons-method/newtons-method.factor index 269eae2538..4b53b1222d 100644 --- a/extra/math/newtons-method/newtons-method.factor +++ b/extra/math/newtons-method/newtons-method.factor @@ -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 +