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

Minor polynomials cleanup, could use refactoring

db4
Aaron Schaefer 2008-11-08 16:03:52 -05:00
parent 23ec6ef122
commit 798139f2e7
1 changed files with 9 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences vectors math math.vectors USING: arrays kernel make math math.order math.vectors sequences shuffle
namespaces make shuffle splitting sequences.lib math.order ; splitting vectors ;
IN: math.polynomials IN: math.polynomials
! Polynomials are vectors with the highest powers on the right: ! Polynomials are vectors with the highest powers on the right:
@ -13,14 +13,16 @@ IN: math.polynomials
<array> 1 [ * ] accumulate nip ; <array> 1 [ * ] accumulate nip ;
<PRIVATE <PRIVATE
: 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 ; : 2pad-left ( p p n -- p p ) [ 0 pad-left ] curry bi@ ;
: 2pad-right ( p p n -- p p ) [ 0 pad-right ] curry bi@ ;
: pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ; : pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ;
: pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ; : pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ;
: unempty ( seq -- seq ) [ { 0 } ] when-empty ; : unempty ( seq -- seq ) [ { 0 } ] when-empty ;
: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ; : 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
PRIVATE> PRIVATE>
: p= ( p p -- ? ) pextend = ; : p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p ) : ptrim ( p -- p )
@ -33,14 +35,14 @@ PRIVATE>
! convolution ! convolution
: pextend-conv ( p p -- p p ) : pextend-conv ( p p -- p p )
#! extend to: p_m + p_n - 1 #! extend to: p_m + p_n - 1
2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ; 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
: p* ( p p -- p ) : p* ( p p -- p )
#! Multiply two polynomials. #! Multiply two polynomials.
2unempty pextend-conv <reversed> dup length 2unempty pextend-conv <reversed> dup length
[ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ; [ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
: p-sq ( p -- p-sq ) : p-sq ( p -- p-sq )
dup p* ; dup p* ;
@ -72,7 +74,7 @@ PRIVATE>
dup V{ 0 } clone p= [ dup V{ 0 } clone p= [
drop nip drop nip
] [ ] [
tuck p/mod >r pick p* swap >r swapd p- r> r> (pgcd) tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
] if ; ] if ;
: pgcd ( p p -- p q ) : pgcd ( p p -- p q )