factor: trim using lists

[factor.git] / extra / project-euler / common / common.factor

diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index f72a5b96af21e7a61289f2471045e629a400ee50..00f3f95cc0eb80cd8e8e6679ddef05e46ed8c1bd 100644 (file)
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -1,12 +1,11 @@
 ! Copyright (c) 2007-2010 Aaron Schaefer.
 ! The contents of this file are licensed under the Simplified BSD License
 ! A copy of the license is available at http://factorcode.org/license.txt
-USING: accessors arrays byte-arrays fry hints kernel lists make math
-    math.functions math.matrices math.order math.parser math.primes.factors
-    math.primes.lists math.primes.miller-rabin math.ranges math.ratios
-    namespaces parser prettyprint quotations sequences sorting strings
-    unicode.case vocabs vocabs.parser words ;
-FROM: sequences => change-nth ;
+USING: accessors arrays byte-arrays hints kernel lists make
+math math.functions math.matrices math.order math.parser
+math.primes.factors math.primes.lists ranges math.ratios
+math.vectors parser prettyprint sequences sorting strings
+unicode vocabs.parser words ;
 IN: project-euler.common
 
 ! A collection of words used by more than one Project Euler solution
@@ -39,42 +38,22 @@ IN: project-euler.common
 : perfect-square? ( n -- ? )
     dup sqrt mod zero? ;
 
-<PRIVATE
+: alpha-value ( str -- n )
+    >lower [ CHAR: a - 1 + ] map-sum ;
 
-: count-digits ( n -- byte-array )
-    10 <byte-array> [
-        '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
-    ] keep ;
+: mediant ( a/c b/d -- (a+b)/(c+d) )
+    2>fraction [ + ] 2bi@ / ;
 
-HINTS: count-digits fixnum ;
+<PRIVATE
 
 : max-children ( seq -- seq )
-    [ dup length 1 - iota [ nth-pair max , ] with each ] { } make ;
-
-! Propagate one row into the upper one
-: propagate ( bottom top -- newtop )
-    [ over rest rot first2 max rot + ] map nip ;
-
-: (sum-divisors) ( n -- sum )
-    dup sqrt >integer [1,b] [
-        [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
-        dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
-    ] { } make sum ;
-
-: transform ( triple matrix -- new-triple )
-    [ 1array ] dip m. first ;
+    [ dup length 1 - <iota> [ nth-pair max , ] with each ] { } make ;
 
 PRIVATE>
 
-: alpha-value ( str -- n )
-    >lower [ CHAR: a - 1 + ] map-sum ;
-
-: mediant ( a/c b/d -- (a+b)/(c+d) )
-    2>fraction [ + ] 2bi@ / ;
-
 : max-path ( triangle -- n )
     dup length 1 > [
-        2 cut* first2 max-children [ + ] 2map suffix max-path
+        2 cut* first2 max-children v+ suffix max-path
     ] [
         first first
     ] if ;
@@ -82,6 +61,9 @@ PRIVATE>
 : number>digits ( n -- seq )
     [ dup 0 = not ] [ 10 /mod ] produce reverse! nip ;
 
+: digits>number ( seq -- n )
+    0 [ [ 10 * ] [ + ] bi* ] reduce ;
+
 : number-length ( n -- m )
     abs [
         1
@@ -111,20 +93,50 @@ PRIVATE>
 : penultimate ( seq -- elt )
     dup length 2 - swap nth ;
 
-! Not strictly needed, but it is nice to be able to dump the triangle after the
-! propagation
+<PRIVATE
+
+! Propagate one row into the upper one
+: propagate ( bottom top -- newtop )
+    [ over rest rot first2 max rot + ] map nip ;
+
+PRIVATE>
+
+! Not strictly needed, but it is nice to be able to dump the
+! triangle after the propagation
 : propagate-all ( triangle -- new-triangle )
-    reverse [ first dup ] [ rest ] bi
-    [ propagate dup ] map nip reverse swap suffix ;
+    reverse unclip dup rot
+    [ propagate dup ] map nip
+    reverse swap suffix ;
+
+<PRIVATE
+
+: count-digits ( n -- byte-array )
+    10 <byte-array> [
+        '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
+    ] keep ;
+
+HINTS: count-digits fixnum ;
+
+PRIVATE>
 
 : permutations? ( n m -- ? )
     [ count-digits ] same? ;
 
+<PRIVATE
+
+: (sum-divisors) ( n -- sum )
+    dup sqrt >integer [1..b] [
+        [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
+        dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
+    ] { } make sum ;
+
+PRIVATE>
+
 : sum-divisors ( n -- sum )
     dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
 
 : sum-proper-divisors ( n -- sum )
-    dup sum-divisors swap - ;
+    [ sum-divisors ] keep - ;
 
 : abundant? ( n -- ? )
     dup sum-proper-divisors < ;
@@ -143,10 +155,17 @@ PRIVATE>
 : tau* ( m -- n )
     factor-2s dup [ 1 + ]
     [ perfect-square? -1 0 ? ]
-    [ dup sqrt >fixnum [1,b] ] tri* [
+    [ dup sqrt >fixnum [1..b] ] tri* [
         dupd divisor? [ [ 2 + ] dip ] when
     ] each drop * ;
 
+<PRIVATE
+
+: transform ( triple matrix -- new-triple )
+    [ 1array ] dip mdot first ;
+
+PRIVATE>
+
 ! These transforms are for generating primitive Pythagorean triples
 : u-transform ( triple -- new-triple )
     { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
@@ -157,7 +176,7 @@ PRIVATE>
 
 SYNTAX: SOLUTION:
     scan-word
-    [ name>> "-main" append create-in ] keep
+    [ name>> "-main" append create-word-in ] keep
     [ drop current-vocab main<< ]
     [ [ . ] swap prefix ( -- ) define-declared ]
     2bi ;