Merge branch 'master' of git://projects.elasticdog.com/git/factor
commit
b78332d645
|
@ -0,0 +1 @@
|
||||||
|
Aaron Schaefer
|
|
@ -0,0 +1,59 @@
|
||||||
|
! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
|
||||||
|
! 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: arrays formatting fry grouping io kernel locals math math.functions
|
||||||
|
math.matrices math.parser math.primes.factors math.vectors prettyprint
|
||||||
|
sequences sequences.deep sets ;
|
||||||
|
IN: benchmark.pidigits
|
||||||
|
|
||||||
|
: extract ( z x -- n )
|
||||||
|
1 2array '[ _ v* sum ] map first2 /i ;
|
||||||
|
|
||||||
|
: next ( z -- n )
|
||||||
|
3 extract ;
|
||||||
|
|
||||||
|
: safe? ( z n -- ? )
|
||||||
|
[ 4 extract ] dip = ;
|
||||||
|
|
||||||
|
: >matrix ( q s r t -- z )
|
||||||
|
4array 2 group ;
|
||||||
|
|
||||||
|
: produce ( z n -- z' )
|
||||||
|
[ 10 ] dip -10 * 0 1 >matrix swap m. ;
|
||||||
|
|
||||||
|
: gen-x ( x -- matrix )
|
||||||
|
dup 2 * 1 + [ 2 * 0 ] keep >matrix ;
|
||||||
|
|
||||||
|
: consume ( z k -- z' )
|
||||||
|
gen-x m. ;
|
||||||
|
|
||||||
|
:: (padded-total) ( row col -- str n format )
|
||||||
|
"" row col + "%" "s\t:%d\n"
|
||||||
|
10 col - number>string glue ;
|
||||||
|
|
||||||
|
: padded-total ( row col -- )
|
||||||
|
(padded-total) '[ _ printf ] call( str n -- ) ;
|
||||||
|
|
||||||
|
:: (pidigits) ( k z n row col -- )
|
||||||
|
n 0 > [
|
||||||
|
z next :> y
|
||||||
|
z y safe? [
|
||||||
|
col 10 = [
|
||||||
|
row 10 + y "\t:%d\n%d" printf
|
||||||
|
k z y produce n 1 - row 10 + 1 (pidigits)
|
||||||
|
] [
|
||||||
|
y number>string write
|
||||||
|
k z y produce n 1 - row col 1 + (pidigits)
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
k 1 + z k consume n row col (pidigits)
|
||||||
|
] if
|
||||||
|
] [ row col padded-total ] if ;
|
||||||
|
|
||||||
|
: pidigits ( n -- )
|
||||||
|
[ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ;
|
||||||
|
|
||||||
|
: pidigits-main ( -- )
|
||||||
|
10000 pidigits ;
|
||||||
|
|
||||||
|
MAIN: pidigits-main
|
|
@ -117,9 +117,6 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
|
||||||
: lookup ( cards table -- value )
|
: lookup ( cards table -- value )
|
||||||
[ rank-bits ] dip nth ;
|
[ rank-bits ] dip nth ;
|
||||||
|
|
||||||
: unique5? ( cards -- ? )
|
|
||||||
unique5-table lookup 0 > ;
|
|
||||||
|
|
||||||
: map-product ( seq quot -- n )
|
: map-product ( seq quot -- n )
|
||||||
[ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
|
[ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
|
||||||
|
|
||||||
|
@ -138,11 +135,11 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
|
||||||
bitxor values-table nth ;
|
bitxor values-table nth ;
|
||||||
|
|
||||||
: hand-value ( cards -- value )
|
: hand-value ( cards -- value )
|
||||||
{
|
dup flush? [ flushes-table lookup ] [
|
||||||
{ [ dup flush? ] [ flushes-table lookup ] }
|
dup unique5-table lookup dup 0 > [ nip ] [
|
||||||
{ [ dup unique5? ] [ unique5-table lookup ] }
|
drop prime-bits perfect-hash-find
|
||||||
[ prime-bits perfect-hash-find ]
|
] if
|
||||||
} cond ;
|
] if ;
|
||||||
|
|
||||||
: >card-rank ( card -- str )
|
: >card-rank ( card -- str )
|
||||||
-8 shift HEX: F bitand RANK_STR nth ;
|
-8 shift HEX: F bitand RANK_STR nth ;
|
||||||
|
|
|
@ -5,3 +5,4 @@ IN: project-euler.001.tests
|
||||||
[ 233168 ] [ euler001a ] unit-test
|
[ 233168 ] [ euler001a ] unit-test
|
||||||
[ 233168 ] [ euler001b ] unit-test
|
[ 233168 ] [ euler001b ] unit-test
|
||||||
[ 233168 ] [ euler001c ] unit-test
|
[ 233168 ] [ euler001c ] unit-test
|
||||||
|
[ 233168 ] [ euler001d ] unit-test
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
|
! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel math math.functions math.ranges sequences project-euler.common ;
|
USING: kernel math math.functions math.ranges project-euler.common sequences
|
||||||
|
sets ;
|
||||||
IN: project-euler.001
|
IN: project-euler.001
|
||||||
|
|
||||||
! http://projecteuler.net/index.php?section=problems&id=1
|
! http://projecteuler.net/index.php?section=problems&id=1
|
||||||
|
@ -32,7 +33,7 @@ PRIVATE>
|
||||||
999 15 sum-divisible-by - ;
|
999 15 sum-divisible-by - ;
|
||||||
|
|
||||||
! [ euler001 ] 100 ave-time
|
! [ euler001 ] 100 ave-time
|
||||||
! 0 ms run / 0 ms GC ave time - 100 trials
|
! 0 ms ave run time - 0.0 SD (100 trials)
|
||||||
|
|
||||||
|
|
||||||
! ALTERNATE SOLUTIONS
|
! ALTERNATE SOLUTIONS
|
||||||
|
@ -42,14 +43,14 @@ PRIVATE>
|
||||||
0 999 3 <range> sum 0 999 5 <range> sum + 0 999 15 <range> sum - ;
|
0 999 3 <range> sum 0 999 5 <range> sum + 0 999 15 <range> sum - ;
|
||||||
|
|
||||||
! [ euler001a ] 100 ave-time
|
! [ euler001a ] 100 ave-time
|
||||||
! 0 ms run / 0 ms GC ave time - 100 trials
|
! 0 ms ave run time - 0.03 SD (100 trials)
|
||||||
|
|
||||||
|
|
||||||
: euler001b ( -- answer )
|
: euler001b ( -- answer )
|
||||||
1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
|
1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
|
||||||
|
|
||||||
! [ euler001b ] 100 ave-time
|
! [ euler001b ] 100 ave-time
|
||||||
! 0 ms run / 0 ms GC ave time - 100 trials
|
! 0 ms ave run time - 0.06 SD (100 trials)
|
||||||
|
|
||||||
|
|
||||||
: euler001c ( -- answer )
|
: euler001c ( -- answer )
|
||||||
|
@ -58,4 +59,11 @@ PRIVATE>
|
||||||
! [ euler001c ] 100 ave-time
|
! [ euler001c ] 100 ave-time
|
||||||
! 0 ms ave run time - 0.06 SD (100 trials)
|
! 0 ms ave run time - 0.06 SD (100 trials)
|
||||||
|
|
||||||
|
|
||||||
|
: euler001d ( -- answer )
|
||||||
|
{ 3 5 } [ [ 999 ] keep <range> ] gather sum ;
|
||||||
|
|
||||||
|
! [ euler001d ] 100 ave-time
|
||||||
|
! 0 ms ave run time - 0.08 SD (100 trials)
|
||||||
|
|
||||||
SOLUTION: euler001
|
SOLUTION: euler001
|
||||||
|
|
|
@ -69,12 +69,9 @@ PRIVATE>
|
||||||
[ nth-prime primes-upto ]
|
[ nth-prime primes-upto ]
|
||||||
} cond product ;
|
} cond product ;
|
||||||
|
|
||||||
: (primorial-upto) ( count limit -- m )
|
|
||||||
'[ dup primorial _ <= ] [ 1+ dup primorial ] produce
|
|
||||||
nip penultimate ;
|
|
||||||
|
|
||||||
: primorial-upto ( limit -- m )
|
: primorial-upto ( limit -- m )
|
||||||
1 swap (primorial-upto) ;
|
1 swap '[ dup primorial _ <= ] [ 1+ dup primorial ] produce
|
||||||
|
nip penultimate ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue