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

math.primes.factors rewrite

db4
Samuel Tardieu 2009-01-07 22:16:39 +01:00
parent 594bd3aee8
commit 397790241f
1 changed files with 14 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
extra/math/primes/factors/factors.factor
View File

@ -1,40 +1,29 @@
! Copyright (C) 2007-2009 Samuel Tardieu. ! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel lists make math math.primes.lists sequences ; USING: arrays combinators kernel make math math.primes sequences ;
IN: math.primes.factors IN: math.primes.factors
<PRIVATE <PRIVATE
: count-factor ( n d -- n' c ) : count-factor ( n d -- n' c )
0 [ [ 2dup mod zero? ] dip swap ] [ [ [ / ] keep ] dip 1+ ] [ ] while nip ; [ 1 ] 2dip [ /i ] keep
[ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] [ drop ] while
swap ;
: (factor) ( n d -- n' ) dup [ , ] curry [ count-factor ] dip times ; : write-factor ( n d -- n' d )
2dup mod zero? [ [ [ count-factor ] keep swap 2array , ] keep ] when ;
: (count) ( n d -- n' )
dup [ swap 2array , ] curry
[ count-factor dup zero? [ drop ] ] dip if ;
: (unique) ( n d -- n' )
dup [ , ] curry [ count-factor zero? ] dip unless ;
: (factors) ( quot list n -- )
dup 1 > [
swap uncons swap [ pick call ] dip swap (factors)
] [ 3drop ] if ; inline recursive
: decompose ( n quot -- seq ) [ lprimes rot (factors) ] { } make ; inline
PRIVATE> PRIVATE>
: factors ( n -- seq ) [ (factor) ] decompose ; flushable : group-factors ( n -- seq )
[ 2 [ over 1 > ] [ write-factor next-prime ] [ ] while 2drop ] { } make ;
: group-factors ( n -- seq ) [ (count) ] decompose ; flushable : unique-factors ( n -- seq ) group-factors [ first ] map ;
: unique-factors ( n -- seq ) [ (unique) ] decompose ; flushable : factors ( n -- seq ) group-factors [ first2 swap <array> ] map concat ;
: totient ( n -- t ) : totient ( n -- t )
dup 2 < [ {
drop 0 { [ dup 2 < ] [ drop 0 ] }
] [ [ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ]
dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * } cond ; foldable
] if ; foldable