From 06dd9895384205246c1049ccd061564574ab8ebe Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 28 Sep 2006 05:11:47 +0000 Subject: [PATCH] fix p/mod --- contrib/math/TODO.txt | 2 +- contrib/math/analysis.factor | 2 +- contrib/math/combinatorics.factor | 6 +++++- contrib/math/polynomials.factor | 25 +++++++++++++++---------- contrib/math/test.factor | 8 +++++--- contrib/math/utils.factor | 15 +-------------- 6 files changed, 28 insertions(+), 30 deletions(-) diff --git a/contrib/math/TODO.txt b/contrib/math/TODO.txt index 909e7ebccc..b3ee36de07 100644 --- a/contrib/math/TODO.txt +++ b/contrib/math/TODO.txt @@ -1,6 +1,6 @@ Nice to have: -- Permutations -- composition and inverse (trivial; use sort and map-with) +- Permutations -- composition (trivial; use sort and map-with) - Analysis: - error function, cosine integral, sine integral, fresnel functions - logarithm integral, zeta function diff --git a/contrib/math/analysis.factor b/contrib/math/analysis.factor index b9905b0d74..c99f1e499f 100644 --- a/contrib/math/analysis.factor +++ b/contrib/math/analysis.factor @@ -37,7 +37,7 @@ USING: kernel sequences errors namespaces math ; IN: math-contrib -: gamma ( x -- gamma[x] ) +: gamma ( x -- y ) #! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt #! gamma(n+1) = n! for n > 0 dup Z:(-inf,0]? [ diff --git a/contrib/math/combinatorics.factor b/contrib/math/combinatorics.factor index f84b5f775c..2a60f2beed 100644 --- a/contrib/math/combinatorics.factor +++ b/contrib/math/combinatorics.factor @@ -1,5 +1,5 @@ IN: math-contrib -USING: kernel sequences errors namespaces math ; +USING: arrays kernel sequences errors namespaces math ; : ( from to -- seq ) dup ; inline : (0..n] ( n -- (0..n] ) 1+ 1 swap ; inline @@ -35,3 +35,7 @@ USING: kernel sequences errors namespaces math ; ] [ 2dup - nip [ factorial ] keep rot pick >r factorial-part r> / ] if ; + +: inverse-permutation ( seq -- seq ) + dup length dup 0 -rot swap [ pick set-nth ] 2each ; + diff --git a/contrib/math/polynomials.factor b/contrib/math/polynomials.factor index 8e9299d24b..f6431bf3a3 100644 --- a/contrib/math/polynomials.factor +++ b/contrib/math/polynomials.factor @@ -1,12 +1,14 @@ IN: polynomials-internals -USING: kernel sequences vectors math math-internals namespaces arrays ; +USING: arrays kernel sequences vectors math math-internals namespaces arrays ; ! Polynomials are vectors with the highest powers on the right: ! { 1 1 0 1 } -> 1 + x + x^3 ! { } -> 0 -: pextend* ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ; -: pextend ( p p -- p p ) 2dup [ length ] 2apply max pextend* ; +: 2pad-left ( p p n -- p p ) 0 [ pad-left swap ] 2keep pad-left swap ; +: 2pad-right ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ; +: pextend ( p p -- p p ) 2dup [ length ] 2apply max 2pad-right ; +: pextend-left ( p p -- p p ) 2dup [ length ] 2apply max 2pad-left ; : unempty ( seq -- seq ) dup empty? [ drop { 0 } ] when ; : 2unempty ( seq seq -- seq seq ) [ unempty ] 2apply ; @@ -26,7 +28,7 @@ IN: math-contrib ! convolution : pextend-conv ( p p -- p p ) #! extend to: p_m + p_n - 1 - 2dup [ length ] 2apply + 1- pextend* [ >vector ] 2apply ; + 2dup [ length ] 2apply + 1- 2pad-right [ >vector ] 2apply ; : p* ( p p -- p ) #! Multiply two polynomials. @@ -43,15 +45,18 @@ IN: polynomials-internals : /-last ( seq seq -- a ) #! divide the last two numbers in the sequences - [ peek ] 2apply /i ; + [ peek ] 2apply / ; + +: p/mod-setup ( p p -- p p n ) + 2ptrim 2dup [ length ] 2apply - dup 1 < [ drop 1 ] when + dup >r over length + 0 pad-left pextend r> 1+ ; : (p/mod) - 2dup /-last 2dup , n*p swapd p- dup pop drop swap pop-front ; + 2dup /-last 2dup , n*p swapd p- >vector dup pop drop swap pop-front ; IN: math-contrib - : p/mod - pextend dup length 1- [ [ (p/mod) ] times ] V{ } make + p/mod-setup [ [ (p/mod) ] times ] V{ } make reverse nip swap 2ptrim pextend ; : (pgcd) ( b a y x -- a d ) @@ -61,8 +66,8 @@ IN: math-contrib tuck p/mod >r pick p* swap >r swapd p- r> r> (pgcd) ] if ; -: pgcd ( p p -- p ) - swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) ; +: pgcd ( p p -- p q ) + swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] 2apply ; : pdiff ( p -- p' ) #! Polynomial derivative. diff --git a/contrib/math/test.factor b/contrib/math/test.factor index ebf23e9bcb..9a75da360a 100644 --- a/contrib/math/test.factor +++ b/contrib/math/test.factor @@ -22,15 +22,17 @@ USING: kernel math test sequences math-contrib ; [ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 } { 1 1 } p/mod ] unit-test [ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 } { 1 1 0 0 0 0 0 0 } p/mod ] unit-test [ V{ 1 0 1 } V{ 0 0 0 } ] [ { 1 1 1 1 0 0 0 0 } { 1 1 0 0 } p/mod ] unit-test -! [ { 5.0 } { 0.0 } ] [ { 10.0 } { 2.0 } p/mod ] unit-test -! [ { 15/16 } { 0 } ] [ { 3/4 } { 4/5 } p/mod ] unit-test +[ V{ 5.0 } V{ 0.0 } ] [ { 10.0 } { 2.0 } p/mod ] unit-test +[ V{ 15/16 } V{ 0 } ] [ { 3/4 } { 4/5 } p/mod ] unit-test [ t ] [ { 0 1 } { 0 1 0 } p= ] unit-test [ f ] [ { 0 0 1 } { 0 1 0 } p= ] unit-test [ t ] [ { 1 1 1 } { 1 1 1 } p= ] unit-test -[ V{ 0 0 } V{ 1 1 } ] [ { 1 1 1 1 } { 1 1 } pgcd ] unit-test +[ { 0 0 } { 1 1 } ] [ { 1 1 1 1 } { 1 1 } pgcd ] unit-test [ t ] [ 10 3 nPk 10 factorial 7 factorial / = ] unit-test [ t ] [ 10 3 nCk 10 factorial 3 factorial 7 factorial * / = ] unit-test +[ { 3 7 9 0 5 2 6 8 1 4 } ] [ { 3 8 5 0 9 4 6 1 7 2 } inverse-permutation ] unit-test +[ { } ] [ { } inverse-permutation ] unit-test [ 1 ] [ 0 factorial ] unit-test [ 1 ] [ 1 factorial ] unit-test [ 2 ] [ 2 factorial ] unit-test diff --git a/contrib/math/utils.factor b/contrib/math/utils.factor index ffa74db832..d368b653ae 100644 --- a/contrib/math/utils.factor +++ b/contrib/math/utils.factor @@ -108,18 +108,5 @@ SYMBOL: step-size .01 step-size set ! base on arguments : limit ( quot -- x ) .1 step-size set [ call ] keep step-size [ 2 / ] change 0 -rot (limit) 2drop ; -! take elements n at a time and apply the quotation, forming a new seq -: group-map ( seq n quot -- seq ) - >r group r> map ; - -: nths ( start n seq -- seq ) - -rot pick length [ over nth ] map nip ; - -! take a set of every nth element and apply the quotation, forming a new seq -! { 1 2 3 4 5 6 } 3 [ sum ] skip-map -> { 1 4 } { 2 5 } { 3 6 } -> { 5 7 9 } -! : skip-map ( seq n quot -- seq ) - ! >r - -: nth-rand ( seq -- elem ) - [ length random-int ] keep nth ; +: nth-rand ( seq -- elem ) [ length random-int ] keep nth ;