From 397790241f2aa13b67b9b3dc58c1110640b2beee Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Wed, 7 Jan 2009 22:16:39 +0100
Subject: [PATCH] math.primes.factors rewrite

---
 extra/math/primes/factors/factors.factor | 39 +++++++++---------------
 1 file changed, 14 insertions(+), 25 deletions(-)

diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor
index 8e22757249..05d6b26010 100644
--- a/extra/math/primes/factors/factors.factor
+++ b/extra/math/primes/factors/factors.factor
@@ -1,40 +1,29 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! 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
 
 <PRIVATE
 
 : 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 ;
-
-: (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
+: write-factor ( n d -- n' d )
+    2dup mod zero? [ [ [ count-factor ] keep swap 2array , ] keep ] when ;
 
 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 )
-    dup 2 < [
-        drop 0
-    ] [
-        dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / *
-    ] if ; foldable
+    {
+        { [ dup 2 < ] [ drop 0 ] }
+        [ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ]
+    } cond ; foldable