From 6db0ae308747804f7d36007add83ee80a5b0e384 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 6 Nov 2019 20:16:48 -0800 Subject: [PATCH] project-euler.common: cleanup. --- extra/project-euler/common/common.factor | 80 ++++++++++++++---------- 1 file changed, 48 insertions(+), 32 deletions(-) diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index d3248a9dfc..73dacb1d53 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,11 +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 - math.vectors namespaces parser prettyprint quotations sequences sorting - strings unicode vocabs vocabs.parser words ; +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.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 @@ -38,39 +38,19 @@ IN: project-euler.common : perfect-square? ( n -- ? ) dup sqrt mod zero? ; - [ - '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop - ] keep ; - -HINTS: count-digits fixnum ; - -: max-children ( seq -- seq ) - [ dup length 1 - [ 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 ; - -PRIVATE> - : alpha-value ( str -- n ) >lower [ CHAR: a - 1 + ] map-sum ; : mediant ( a/c b/d -- (a+b)/(c+d) ) 2>fraction [ + ] 2bi@ / ; + [ nth-pair max , ] with each ] { } make ; + +PRIVATE> + : max-path ( triangle -- n ) dup length 1 > [ 2 cut* first2 max-children v+ suffix max-path @@ -113,6 +93,14 @@ 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 : propagate-all ( triangle -- new-triangle ) @@ -120,9 +108,30 @@ PRIVATE> [ propagate dup ] map nip reverse swap suffix ; + [ + '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop + ] keep ; + +HINTS: count-digits fixnum ; + +PRIVATE> + : permutations? ( n m -- ? ) [ count-digits ] same? ; +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 ; @@ -150,6 +159,13 @@ PRIVATE> dupd divisor? [ [ 2 + ] dip ] when ] each drop * ; + + ! These transforms are for generating primitive Pythagorean triples : u-transform ( triple -- new-triple ) { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;