From 7c898bd553146f67a585d9df603454a5575d2a08 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 8 Apr 2009 12:30:11 -0400 Subject: [PATCH 1/6] Eliminate redundant unique5 lookup for poker hands --- extra/poker/poker.factor | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index 2a7fe73762..e8e9fa23c5 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -117,9 +117,6 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" : lookup ( cards table -- value ) [ rank-bits ] dip nth ; -: unique5? ( cards -- ? ) - unique5-table lookup 0 > ; - : map-product ( seq quot -- n ) [ 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 ; : hand-value ( cards -- value ) - { - { [ dup flush? ] [ flushes-table lookup ] } - { [ dup unique5? ] [ unique5-table lookup ] } - [ prime-bits perfect-hash-find ] - } cond ; + dup flush? [ flushes-table lookup ] [ + dup unique5-table lookup dup 0 > [ nip ] [ + drop prime-bits perfect-hash-find + ] if + ] if ; : >card-rank ( card -- str ) -8 shift HEX: F bitand RANK_STR nth ; From 01677ada51c65d392df4ab61cb011644eaa08acc Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 8 Apr 2009 18:15:24 -0400 Subject: [PATCH 2/6] Remove unnecessary helper word after refactoring --- extra/project-euler/069/069.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/extra/project-euler/069/069.factor b/extra/project-euler/069/069.factor index eae1d82ece..3a59d66522 100644 --- a/extra/project-euler/069/069.factor +++ b/extra/project-euler/069/069.factor @@ -69,12 +69,9 @@ PRIVATE> [ nth-prime primes-upto ] } cond product ; -: (primorial-upto) ( count limit -- m ) - '[ dup primorial _ <= ] [ 1+ dup primorial ] produce - nip penultimate ; - : primorial-upto ( limit -- m ) - 1 swap (primorial-upto) ; + 1 swap '[ dup primorial _ <= ] [ 1+ dup primorial ] produce + nip penultimate ; PRIVATE> From e4ce05f73bdfcdfa2f9fc1b13eeb0a9e1b3f215e Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 19 Apr 2009 13:01:02 -0400 Subject: [PATCH 3/6] Additional solution to PE problem 1 from IRC --- extra/project-euler/001/001-tests.factor | 1 + extra/project-euler/001/001.factor | 16 ++++++++++++---- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/extra/project-euler/001/001-tests.factor b/extra/project-euler/001/001-tests.factor index 1cab275619..32a72dfaf0 100644 --- a/extra/project-euler/001/001-tests.factor +++ b/extra/project-euler/001/001-tests.factor @@ -5,3 +5,4 @@ IN: project-euler.001.tests [ 233168 ] [ euler001a ] unit-test [ 233168 ] [ euler001b ] unit-test [ 233168 ] [ euler001c ] unit-test +[ 233168 ] [ euler001d ] unit-test diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 20e08242c5..0d4f5fb1bd 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov. ! 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 ! http://projecteuler.net/index.php?section=problems&id=1 @@ -32,7 +33,7 @@ PRIVATE> 999 15 sum-divisible-by - ; ! [ 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 @@ -42,14 +43,14 @@ PRIVATE> 0 999 3 sum 0 999 5 sum + 0 999 15 sum - ; ! [ 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 ) 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; ! [ 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 ) @@ -58,4 +59,11 @@ PRIVATE> ! [ euler001c ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) + +: euler001d ( -- answer ) + { 3 5 } [ [ 999 ] keep ] gather sum ; + +! [ euler001d ] 100 ave-time +! 0 ms ave run time - 0.08 SD (100 trials) + SOLUTION: euler001 From 6c38831c4813391b2ff380df925e60bc41a2b286 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 21 Apr 2009 18:29:06 -0400 Subject: [PATCH 4/6] Improve license owner phrasing and in-file copyright notices --- basis/tools/scaffold/scaffold.factor | 11 ++++++----- license.txt | 3 +++ 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index f35da24266..6f7cb25ab9 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -1,5 +1,5 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. +! Copyright (c) 2008 Doug Coleman. All rights reserved. +! This software is licensed under the Simplified BSD License. USING: assocs io.files io.pathnames io.directories io.encodings.utf8 hashtables kernel namespaces sequences vocabs.loader io combinators calendar accessors math.parser @@ -79,9 +79,10 @@ ERROR: no-vocab vocab ; dup exists? [ not-scaffolding f ] [ scaffolding t ] if ; : scaffold-copyright ( -- ) - "! Copyright (C) " write now year>> number>string write - developer-name get [ "Your name" ] unless* bl write "." print - "! See http://factorcode.org/license.txt for BSD license." print ; + "! Copyright (c) " write now year>> number>string write + developer-name get [ "Your name" ] unless* bl write + ". All rights reserved." print + "! This software is licensed under the Simplified BSD License." print ; : main-file-string ( vocab -- string ) [ diff --git a/license.txt b/license.txt index e9cd58a5e4..3310ddc18f 100644 --- a/license.txt +++ b/license.txt @@ -1,3 +1,6 @@ +Copyright (c) 2003-2009, Slava Pestov and contributing authors +All rights reserved. + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: From 25cc5a409ae3fc6d8f26cf3e21b28923834fcf6a Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 22 Apr 2009 00:20:53 -0400 Subject: [PATCH 5/6] Revert "Improve license owner phrasing and in-file copyright notices" This reverts commit 6c38831c4813391b2ff380df925e60bc41a2b286. --- basis/tools/scaffold/scaffold.factor | 11 +++++------ license.txt | 3 --- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 6f7cb25ab9..f35da24266 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -1,5 +1,5 @@ -! Copyright (c) 2008 Doug Coleman. All rights reserved. -! This software is licensed under the Simplified BSD License. +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: assocs io.files io.pathnames io.directories io.encodings.utf8 hashtables kernel namespaces sequences vocabs.loader io combinators calendar accessors math.parser @@ -79,10 +79,9 @@ ERROR: no-vocab vocab ; dup exists? [ not-scaffolding f ] [ scaffolding t ] if ; : scaffold-copyright ( -- ) - "! Copyright (c) " write now year>> number>string write - developer-name get [ "Your name" ] unless* bl write - ". All rights reserved." print - "! This software is licensed under the Simplified BSD License." print ; + "! Copyright (C) " write now year>> number>string write + developer-name get [ "Your name" ] unless* bl write "." print + "! See http://factorcode.org/license.txt for BSD license." print ; : main-file-string ( vocab -- string ) [ diff --git a/license.txt b/license.txt index 3310ddc18f..e9cd58a5e4 100644 --- a/license.txt +++ b/license.txt @@ -1,6 +1,3 @@ -Copyright (c) 2003-2009, Slava Pestov and contributing authors -All rights reserved. - Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: From d035c91e3fb21a49d34d774f71cd131e9a861178 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 24 Apr 2009 02:05:52 -0400 Subject: [PATCH 6/6] Add pidigits benchmark from language shootout --- extra/benchmark/pidigits/authors.txt | 1 + extra/benchmark/pidigits/pidigits.factor | 59 ++++++++++++++++++++++++ 2 files changed, 60 insertions(+) create mode 100644 extra/benchmark/pidigits/authors.txt create mode 100644 extra/benchmark/pidigits/pidigits.factor diff --git a/extra/benchmark/pidigits/authors.txt b/extra/benchmark/pidigits/authors.txt new file mode 100644 index 0000000000..4eec9c9a08 --- /dev/null +++ b/extra/benchmark/pidigits/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer diff --git a/extra/benchmark/pidigits/pidigits.factor b/extra/benchmark/pidigits/pidigits.factor new file mode 100644 index 0000000000..5de5cc5e99 --- /dev/null +++ b/extra/benchmark/pidigits/pidigits.factor @@ -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