From fcfb8fbedf39050cdc284e2cfb6909c76bc96907 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Dec 2007 20:57:16 -0500 Subject: [PATCH 01/20] add initial project-euler solutions and support vocabs --- extra/project-euler/001/001.factor | 38 +++ extra/project-euler/002/002.factor | 34 +++ extra/project-euler/003/003.factor | 28 +++ extra/project-euler/004/004.factor | 41 +++ extra/project-euler/005/005.factor | 26 ++ extra/project-euler/006/006.factor | 39 +++ extra/project-euler/007/007.factor | 29 +++ extra/project-euler/008/008.factor | 72 ++++++ extra/project-euler/009/009.factor | 55 +++++ extra/project-euler/010/010.factor | 57 +++++ extra/project-euler/011/011.factor | 107 ++++++++ extra/project-euler/012/012.factor | 45 ++++ extra/project-euler/013/013.factor | 233 ++++++++++++++++++ extra/project-euler/014/014.factor | 79 ++++++ extra/project-euler/015/015.factor | 33 +++ extra/project-euler/016/016.factor | 28 +++ extra/project-euler/authors.txt | 1 + extra/project-euler/ave-time/authors.txt | 1 + .../ave-time/ave-time-docs.factor | 24 ++ extra/project-euler/ave-time/ave-time.factor | 25 ++ extra/project-euler/ave-time/summary.txt | 1 + extra/project-euler/ave-time/tags.txt | 1 + extra/project-euler/common/common.factor | 61 +++++ extra/project-euler/project-euler.factor | 44 ++++ extra/project-euler/summary.txt | 1 + extra/project-euler/tags.txt | 1 + 26 files changed, 1104 insertions(+) create mode 100644 extra/project-euler/001/001.factor create mode 100644 extra/project-euler/002/002.factor create mode 100644 extra/project-euler/003/003.factor create mode 100644 extra/project-euler/004/004.factor create mode 100644 extra/project-euler/005/005.factor create mode 100644 extra/project-euler/006/006.factor create mode 100644 extra/project-euler/007/007.factor create mode 100644 extra/project-euler/008/008.factor create mode 100644 extra/project-euler/009/009.factor create mode 100644 extra/project-euler/010/010.factor create mode 100644 extra/project-euler/011/011.factor create mode 100644 extra/project-euler/012/012.factor create mode 100644 extra/project-euler/013/013.factor create mode 100644 extra/project-euler/014/014.factor create mode 100644 extra/project-euler/015/015.factor create mode 100644 extra/project-euler/016/016.factor create mode 100644 extra/project-euler/authors.txt create mode 100644 extra/project-euler/ave-time/authors.txt create mode 100644 extra/project-euler/ave-time/ave-time-docs.factor create mode 100644 extra/project-euler/ave-time/ave-time.factor create mode 100644 extra/project-euler/ave-time/summary.txt create mode 100644 extra/project-euler/ave-time/tags.txt create mode 100644 extra/project-euler/common/common.factor create mode 100644 extra/project-euler/project-euler.factor create mode 100644 extra/project-euler/summary.txt create mode 100644 extra/project-euler/tags.txt diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor new file mode 100644 index 0000000000..7d77e86fec --- /dev/null +++ b/extra/project-euler/001/001.factor @@ -0,0 +1,38 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.ranges sequences ; +IN: project-euler.001 + +! http://projecteuler.net/index.php?section=problems&id=1 + +! DESCRIPTION +! ----------- + +! If we list all the natural numbers below 10 that are multiples of 3 or 5, we +! get 3, 5, 6 and 9. The sum of these multiples is 23. + +! Find the sum of all the multiples of 3 or 5 below 1000. + + +! SOLUTION +! -------- + +! Inclusion-exclusion principle + +: euler001 ( -- answer ) + 0 999 3 sum 0 999 5 sum + 0 999 15 sum - ; + +! [ euler001 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + + +! ALTERNATE SOLUTIONS +! ------------------- + +: euler001a ( -- answer ) + 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] subset sum ; + +! [ euler001a ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler001 diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor new file mode 100644 index 0000000000..386d847e27 --- /dev/null +++ b/extra/project-euler/002/002.factor @@ -0,0 +1,34 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math sequences ; +IN: project-euler.002 + +! http://projecteuler.net/index.php?section=problems&id=2 + +! DESCRIPTION +! ----------- + +! Each new term in the Fibonacci sequence is generated by adding the previous +! two terms. By starting with 1 and 2, the first 10 terms will be: + +! 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ... + +! Find the sum of all the even-valued terms in the sequence which do not exceed one million. + + +! SOLUTION +! -------- + +: last2 ( seq -- elt last ) + reverse first2 swap ; + +: fib-up-to ( n -- seq ) + { 0 } 1 [ pick dupd < ] [ add dup last2 + ] [ ] while drop nip ; + +: euler002 ( -- answer ) + 1000000 fib-up-to [ even? ] subset sum ; + +! [ euler002 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler002 diff --git a/extra/project-euler/003/003.factor b/extra/project-euler/003/003.factor new file mode 100644 index 0000000000..87db922e5f --- /dev/null +++ b/extra/project-euler/003/003.factor @@ -0,0 +1,28 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math project-euler.common sequences ; +IN: project-euler.003 + +! http://projecteuler.net/index.php?section=problems&id=3 + +! DESCRIPTION +! ----------- + +! The prime factors of 13195 are 5, 7, 13 and 29. + +! What is the largest prime factor of the number 317584931803? + + +! SOLUTION +! -------- + +: largest-prime-factor ( n -- factor ) + prime-factors supremum ; + +: euler003 ( -- answer ) + 317584931803 largest-prime-factor ; + +! [ euler003 ] 100 ave-time +! 404 ms run / 9 ms GC ave time - 100 trials + +MAIN: euler003 diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor new file mode 100644 index 0000000000..dadde25411 --- /dev/null +++ b/extra/project-euler/004/004.factor @@ -0,0 +1,41 @@ +! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators.lib hashtables kernel math math.parser math.ranges + sequences sorting ; +IN: project-euler.004 + +! http://projecteuler.net/index.php?section=problems&id=4 + +! DESCRIPTION +! ----------- + +! A palindromic number reads the same both ways. The largest palindrome made +! from the product of two 2-digit numbers is 9009 = 91 * 99. + +! Find the largest palindrome made from the product of two 3-digit numbers. + + +! SOLUTION +! -------- + +: palindrome? ( n -- ? ) + number>string dup reverse = ; + +: cartesian-product ( seq1 seq2 -- seq1xseq2 ) + swap [ swap [ 2array ] map-with ] map-with concat ; + + + +: euler004 ( -- answer ) + 100 999 [a,b] [ 10 mod zero? not ] subset dup + cartesian-product [ product ] map prune max-palindrome ; + +! [ euler004 ] 100 ave-time +! 1608 ms run / 102 ms GC ave time - 100 trials + +MAIN: euler004 diff --git a/extra/project-euler/005/005.factor b/extra/project-euler/005/005.factor new file mode 100644 index 0000000000..ff627e4a0e --- /dev/null +++ b/extra/project-euler/005/005.factor @@ -0,0 +1,26 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions sequences ; +IN: project-euler.005 + +! http://projecteuler.net/index.php?section=problems&id=5 + +! DESCRIPTION +! ----------- + +! 2520 is the smallest number that can be divided by each of the numbers from 1 +! to 10 without any remainder. + +! What is the smallest number that is evenly divisible by all of the numbers from 1 to 20? + + +! SOLUTION +! -------- + +: euler005 ( -- answer ) + 20 1 [ 1+ lcm ] reduce ; + +! [ euler005 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler005 diff --git a/extra/project-euler/006/006.factor b/extra/project-euler/006/006.factor new file mode 100644 index 0000000000..2f09912412 --- /dev/null +++ b/extra/project-euler/006/006.factor @@ -0,0 +1,39 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.ranges sequences ; +IN: project-euler.006 + +! http://projecteuler.net/index.php?section=problems&id=6 + +! DESCRIPTION +! ----------- + +! The sum of the squares of the first ten natural numbers is, +! 1² + 2² + ... + 10² = 385 + +! The square of the sum of the first ten natural numbers is, +! (1 + 2 + ... + 10)² = 55² = 3025 + +! Hence the difference between the sum of the squares of the first ten natural +! numbers and the square of the sum is 3025 385 = 2640. + +! Find the difference between the sum of the squares of the first one hundred +! natural numbers and the square of the sum. + + +! SOLUTION +! -------- + +: sum-of-squares ( seq -- n ) + 0 [ sq + ] reduce ; + +: square-of-sums ( seq -- n ) + 0 [ + ] reduce sq ; + +: euler006 ( -- answer ) + 1 100 [a,b] dup sum-of-squares swap square-of-sums - abs ; + +! [ euler006 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler006 diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor new file mode 100644 index 0000000000..0a9cd98865 --- /dev/null +++ b/extra/project-euler/007/007.factor @@ -0,0 +1,29 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.miller-rabin ; +IN: project-euler.007 + +! http://projecteuler.net/index.php?section=problems&id=7 + +! DESCRIPTION +! ----------- + +! By listing the first six prime numbers: 2, 3, 5, 7, 11, and 13, we can see +! that the 6th prime is 13. + +! What is the 10001st prime number? + + +! SOLUTION +! -------- + +: nth-prime ( n -- n ) + 2 swap 1- [ next-prime ] times ; + +: euler007 ( -- answer ) + 10001 nth-prime ; + +! [ euler007 ] time +! 19230 ms run / 487 ms GC time + +MAIN: euler007 diff --git a/extra/project-euler/008/008.factor b/extra/project-euler/008/008.factor new file mode 100644 index 0000000000..d76f344279 --- /dev/null +++ b/extra/project-euler/008/008.factor @@ -0,0 +1,72 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math.parser project-euler.common sequences ; +IN: project-euler.008 + +! http://projecteuler.net/index.php?section=problems&id=8 + +! DESCRIPTION +! ----------- + +! Find the greatest product of five consecutive digits in the 1000-digit number. + +! 73167176531330624919225119674426574742355349194934 +! 96983520312774506326239578318016984801869478851843 +! 85861560789112949495459501737958331952853208805511 +! 12540698747158523863050715693290963295227443043557 +! 66896648950445244523161731856403098711121722383113 +! 62229893423380308135336276614282806444486645238749 +! 30358907296290491560440772390713810515859307960866 +! 70172427121883998797908792274921901699720888093776 +! 65727333001053367881220235421809751254540594752243 +! 52584907711670556013604839586446706324415722155397 +! 53697817977846174064955149290862569321978468622482 +! 83972241375657056057490261407972968652414535100474 +! 82166370484403199890008895243450658541227588666881 +! 16427171479924442928230863465674813919123162824586 +! 17866458359124566529476545682848912883142607690042 +! 24219022671055626321111109370544217506941658960408 +! 07198403850962455444362981230987879927244284909188 +! 84580156166097919133875499200524063689912560717606 +! 05886116467109405077541002256983155200055935729725 +! 71636269561882670428252483600823257530420752963450 + + +! SOLUTION +! -------- + + + +: euler008 ( -- answer ) + source-008 5 collect-consecutive [ string>digits product ] map supremum ; + +! [ euler008 ] 100 ave-time +! 11 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler008 diff --git a/extra/project-euler/009/009.factor b/extra/project-euler/009/009.factor new file mode 100644 index 0000000000..44569149d5 --- /dev/null +++ b/extra/project-euler/009/009.factor @@ -0,0 +1,55 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions namespaces sequences sorting ; +IN: project-euler.009 + +! http://projecteuler.net/index.php?section=problems&id=9 + +! DESCRIPTION +! ----------- + +! A Pythagorean triplet is a set of three natural numbers, a < b < c, for which, +! a² + b² = c² + +! For example, 3² + 4² = 9 + 16 = 25 = 5². + +! There exists exactly one Pythagorean triplet for which a + b + c = 1000. +! Find the product abc. + + +! SOLUTION +! -------- + +! Algorithm adapted from http://www.friesian.com/pythag.com + + q and both are odd integers + dup 1 = [ swap 2 + nip dup 2 - ] [ 2 - ] if ; + +: abc ( p q -- triplet ) + [ + 2dup * , ! a = p * q + 2dup sq swap sq swap - 2 / , ! b = (p² - q²) / 2 + sq swap sq swap + 2 / , ! c = (p² + q²) / 2 + ] { } make natural-sort ; + +: (ptriplet) ( target p q triplet -- target p q ) + roll dup >r swap sum = r> -roll + [ + next-pq 2dup abc (ptriplet) + ] unless ; + +: ptriplet ( target -- triplet ) + 3 1 { 3 4 5 } (ptriplet) abc nip ; + +PRIVATE> + +: euler009 ( -- answer ) + 1000 ptriplet product ; + +! [ euler009 ] 100 ave-time +! 1 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler009 diff --git a/extra/project-euler/010/010.factor b/extra/project-euler/010/010.factor new file mode 100644 index 0000000000..ed08de902c --- /dev/null +++ b/extra/project-euler/010/010.factor @@ -0,0 +1,57 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel math math.functions math.ranges namespaces sequences ; +IN: project-euler.010 + +! http://projecteuler.net/index.php?section=problems&id=10 + +! DESCRIPTION +! ----------- + +! The sum of the primes below 10 is 2 + 3 + 5 + 7 = 17. + +! Find the sum of all the primes below one million. + + +! SOLUTION +! -------- + +! Sieve of Eratosthenes + + ; + +: multiples ( max n -- seq ) + dup sq -rot ; + +: remove-multiples ( n seq -- seq ) + dup supremum rot multiples swap seq-diff ; + +: keep-going? ( limit index seq -- ? ) + nth swap sqrt < ; + +: (primes-below) ( limit index seq -- seq ) + 3dup keep-going? [ + 2dup nth swap remove-multiples + >r 1+ r> (primes-below) + ] [ + 2nip + ] if ; + +PRIVATE> + +: primes-below ( n -- seq ) + [ candidates ] keep 0 rot (primes-below) 2 add* ; + +: euler010 ( -- answer ) + 1000000 primes-below sum ; + +! TODO: solution is still too slow for 1000000, probably due to seq-diff +! calling member? for each number that we want to remove + +! [ euler010 ] time +! ? ms run / ? ms GC time + +MAIN: euler010 diff --git a/extra/project-euler/011/011.factor b/extra/project-euler/011/011.factor new file mode 100644 index 0000000000..9739ee971c --- /dev/null +++ b/extra/project-euler/011/011.factor @@ -0,0 +1,107 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces project-euler.common sequences ; +IN: project-euler.011 + +! http://projecteuler.net/index.php?section=problems&id=11 + +! DESCRIPTION +! ----------- + +! In the 20x20 grid below, four numbers along a diagonal line have been marked +! in red. + +! 08 02 22 97 38 15 00 40 00 75 04 05 07 78 52 12 50 77 91 08 +! 49 49 99 40 17 81 18 57 60 87 17 40 98 43 69 48 04 56 62 00 +! 81 49 31 73 55 79 14 29 93 71 40 67 53 88 30 03 49 13 36 65 +! 52 70 95 23 04 60 11 42 69 24 68 56 01 32 56 71 37 02 36 91 +! 22 31 16 71 51 67 63 89 41 92 36 54 22 40 40 28 66 33 13 80 +! 24 47 32 60 99 03 45 02 44 75 33 53 78 36 84 20 35 17 12 50 +! 32 98 81 28 64 23 67 10 26 38 40 67 59 54 70 66 18 38 64 70 +! 67 26 20 68 02 62 12 20 95 63 94 39 63 08 40 91 66 49 94 21 +! 24 55 58 05 66 73 99 26 97 17 78 78 96 83 14 88 34 89 63 72 +! 21 36 23 09 75 00 76 44 20 45 35 14 00 61 33 97 34 31 33 95 +! 78 17 53 28 22 75 31 67 15 94 03 80 04 62 16 14 09 53 56 92 +! 16 39 05 42 96 35 31 47 55 58 88 24 00 17 54 24 36 29 85 57 +! 86 56 00 48 35 71 89 07 05 44 44 37 44 60 21 58 51 54 17 58 +! 19 80 81 68 05 94 47 69 28 73 92 13 86 52 17 77 04 89 55 40 +! 04 52 08 83 97 35 99 16 07 97 57 32 16 26 26 79 33 27 98 66 +! 88 36 68 87 57 62 20 72 03 46 33 67 46 55 12 32 63 93 53 69 +! 04 42 16 73 38 25 39 11 24 94 72 18 08 46 29 32 40 62 76 36 +! 20 69 36 41 72 30 23 88 34 62 99 69 82 67 59 85 74 04 36 16 +! 20 73 35 29 78 31 90 01 74 31 49 71 48 86 81 16 23 57 05 54 +! 01 70 54 71 83 51 54 69 16 92 33 48 61 43 52 01 89 19 67 48 + +! The product of these numbers is 26 * 63 * 78 * 14 = 1788696. + +! What is the greatest product of four numbers in any direction (up, down, +! left, right, or diagonally) in the 20x20 grid? + + +! SOLUTION +! -------- + + ] each + ] keep [ append ] map ; + +: pad-back ( matrix -- matrix ) + [ + length [ 0 ] each + ] keep [ append ] map ; + +: diagonal/ ( -- matrix ) + horizontal reverse pad-front pad-back flip ; + +: diagonal\ ( -- matrix ) + horizontal pad-front pad-back flip ; + +: max-product ( matrix width -- n ) + [ collect-consecutive ] curry map concat + [ product ] map supremum ; inline + +PRIVATE> + +: euler011 ( -- answer ) + [ + { [ horizontal ] [ vertical ] [ diagonal/ ] [ diagonal\ ] } + [ call 4 max-product , ] each + ] { } make supremum ; + +! TODO: solution works but doesn't completely compile due to the creation of +! the diagonal matrices, there must be a cleaner way to generate those + +! [ euler011 ] 100 ave-time +! 4 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler011 diff --git a/extra/project-euler/012/012.factor b/extra/project-euler/012/012.factor new file mode 100644 index 0000000000..0d0d4161e4 --- /dev/null +++ b/extra/project-euler/012/012.factor @@ -0,0 +1,45 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math project-euler.common ; +IN: project-euler.012 + +! http://projecteuler.net/index.php?section=problems&id=12 + +! DESCRIPTION +! ----------- + +! The sequence of triangle numbers is generated by adding the natural numbers. +! So the 7th triangle number would be 1 + 2 + 3 + 4 + 5 + 6 + 7 = 28. The first +! ten terms would be: + +! 1, 3, 6, 10, 15, 21, 28, 36, 45, 55, ... + +! Let us list the factors of the first seven triangle numbers: + +! 1: 1 +! 3: 1,3 +! 6: 1,2,3,6 +! 10: 1,2,5,10 +! 15: 1,3,5,15 +! 21: 1,3,7,21 +! 28: 1,2,4,7,14,28 + +! We can see that the 7th triangle number, 28, is the first triangle number to +! have over five divisors. + +! Which is the first triangle number to have over five-hundred divisors? + + +! SOLUTION +! -------- + +: nth-triangle ( n -- n ) + dup 1+ * 2 / ; + +: euler012 ( -- answer ) + 2 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ; + +! [ euler012 ] 10 ave-time +! 5413 ms run / 1 ms GC ave time - 10 trials + +MAIN: euler012 diff --git a/extra/project-euler/013/013.factor b/extra/project-euler/013/013.factor new file mode 100644 index 0000000000..be968fc346 --- /dev/null +++ b/extra/project-euler/013/013.factor @@ -0,0 +1,233 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math.parser sequences ; +IN: project-euler.013 + +! http://projecteuler.net/index.php?section=problems&id=13 + +! DESCRIPTION +! ----------- + +! Work out the first ten digits of the sum of the following one-hundred +! 50-digit numbers. + +! 37107287533902102798797998220837590246510135740250 +! 46376937677490009712648124896970078050417018260538 +! 74324986199524741059474233309513058123726617309629 +! 91942213363574161572522430563301811072406154908250 +! 23067588207539346171171980310421047513778063246676 +! 89261670696623633820136378418383684178734361726757 +! 28112879812849979408065481931592621691275889832738 +! 44274228917432520321923589422876796487670272189318 +! 47451445736001306439091167216856844588711603153276 +! 70386486105843025439939619828917593665686757934951 +! 62176457141856560629502157223196586755079324193331 +! 64906352462741904929101432445813822663347944758178 +! 92575867718337217661963751590579239728245598838407 +! 58203565325359399008402633568948830189458628227828 +! 80181199384826282014278194139940567587151170094390 +! 35398664372827112653829987240784473053190104293586 +! 86515506006295864861532075273371959191420517255829 +! 71693888707715466499115593487603532921714970056938 +! 54370070576826684624621495650076471787294438377604 +! 53282654108756828443191190634694037855217779295145 +! 36123272525000296071075082563815656710885258350721 +! 45876576172410976447339110607218265236877223636045 +! 17423706905851860660448207621209813287860733969412 +! 81142660418086830619328460811191061556940512689692 +! 51934325451728388641918047049293215058642563049483 +! 62467221648435076201727918039944693004732956340691 +! 15732444386908125794514089057706229429197107928209 +! 55037687525678773091862540744969844508330393682126 +! 18336384825330154686196124348767681297534375946515 +! 80386287592878490201521685554828717201219257766954 +! 78182833757993103614740356856449095527097864797581 +! 16726320100436897842553539920931837441497806860984 +! 48403098129077791799088218795327364475675590848030 +! 87086987551392711854517078544161852424320693150332 +! 59959406895756536782107074926966537676326235447210 +! 69793950679652694742597709739166693763042633987085 +! 41052684708299085211399427365734116182760315001271 +! 65378607361501080857009149939512557028198746004375 +! 35829035317434717326932123578154982629742552737307 +! 94953759765105305946966067683156574377167401875275 +! 88902802571733229619176668713819931811048770190271 +! 25267680276078003013678680992525463401061632866526 +! 36270218540497705585629946580636237993140746255962 +! 24074486908231174977792365466257246923322810917141 +! 91430288197103288597806669760892938638285025333403 +! 34413065578016127815921815005561868836468420090470 +! 23053081172816430487623791969842487255036638784583 +! 11487696932154902810424020138335124462181441773470 +! 63783299490636259666498587618221225225512486764533 +! 67720186971698544312419572409913959008952310058822 +! 95548255300263520781532296796249481641953868218774 +! 76085327132285723110424803456124867697064507995236 +! 37774242535411291684276865538926205024910326572967 +! 23701913275725675285653248258265463092207058596522 +! 29798860272258331913126375147341994889534765745501 +! 18495701454879288984856827726077713721403798879715 +! 38298203783031473527721580348144513491373226651381 +! 34829543829199918180278916522431027392251122869539 +! 40957953066405232632538044100059654939159879593635 +! 29746152185502371307642255121183693803580388584903 +! 41698116222072977186158236678424689157993532961922 +! 62467957194401269043877107275048102390895523597457 +! 23189706772547915061505504953922979530901129967519 +! 86188088225875314529584099251203829009407770775672 +! 11306739708304724483816533873502340845647058077308 +! 82959174767140363198008187129011875491310547126581 +! 97623331044818386269515456334926366572897563400500 +! 42846280183517070527831839425882145521227251250327 +! 55121603546981200581762165212827652751691296897789 +! 32238195734329339946437501907836945765883352399886 +! 75506164965184775180738168837861091527357929701337 +! 62177842752192623401942399639168044983993173312731 +! 32924185707147349566916674687634660915035914677504 +! 99518671430235219628894890102423325116913619626622 +! 73267460800591547471830798392868535206946944540724 +! 76841822524674417161514036427982273348055556214818 +! 97142617910342598647204516893989422179826088076852 +! 87783646182799346313767754307809363333018982642090 +! 10848802521674670883215120185883543223812876952786 +! 71329612474782464538636993009049310363619763878039 +! 62184073572399794223406235393808339651327408011116 +! 66627891981488087797941876876144230030984490851411 +! 60661826293682836764744779239180335110989069790714 +! 85786944089552990653640447425576083659976645795096 +! 66024396409905389607120198219976047599490197230297 +! 64913982680032973156037120041377903785566085089252 +! 16730939319872750275468906903707539413042652315011 +! 94809377245048795150954100921645863754710598436791 +! 78639167021187492431995700641917969777599028300699 +! 15368713711936614952811305876380278410754449733078 +! 40789923115535562561142322423255033685442488917353 +! 44889911501440648020369068063960672322193204149535 +! 41503128880339536053299340368006977710650566631954 +! 81234880673210146739058568557934581403627822703280 +! 82616570773948327592232845941706525094512325230608 +! 22918802058777319719839450180888072429661980811197 +! 77158542502016545090413245809786882778948721859617 +! 72107838435069186155435662884062257473692284509516 +! 20849603980134001723930671666823555245252804609722 +! 53503534226472524250874054075591789781264330331690 + + +! SOLUTION +! -------- + + + +: euler013 ( -- answer ) + source-013 sum number>string 10 head string>number ; + +! [ euler013 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler013 diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor new file mode 100644 index 0000000000..7c1f0d41f9 --- /dev/null +++ b/extra/project-euler/014/014.factor @@ -0,0 +1,79 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators.lib kernel math math.ranges namespaces sequences + sorting ; +IN: project-euler.014 + +! http://projecteuler.net/index.php?section=problems&id=14 + +! DESCRIPTION +! ----------- + +! The following iterative sequence is defined for the set of positive integers: + +! n -> n / 2 (n is even) +! n -> 3n + 1 (n is odd) + +! Using the rule above and starting with 13, we generate the following +! sequence: + +! 13 -> 40 -> 20 -> 10 -> 5 -> 16 -> 8 -> 4 -> 2 -> 1 + +! It can be seen that this sequence (starting at 13 and finishing at 1) +! contains 10 terms. Although it has not been proved yet (Collatz Problem), it +! is thought that all starting numbers finish at 1. + +! Which starting number, under one million, produces the longest chain? + +! NOTE: Once the chain starts the terms are allowed to go above one million. + + +! SOLUTION +! -------- + +! Brute force + + [ nip ] [ drop ] if ; + +PRIVATE> + +: collatz ( n -- seq ) + [ [ dup 1 > ] [ dup , next-collatz ] [ ] while , ] { } make ; + +: euler014 ( -- answer ) + 1000000 0 [ 1+ collatz longest ] reduce first ; + +! [ euler014 ] time +! 52868 ms run / 483 ms GC time + + +! ALTERNATE SOLUTIONS +! ------------------- + + + +: euler014a ( -- answer ) + 500000 1000000 [a,b] 1 [ + dup worth-calculating? [ collatz longest ] [ drop ] if + ] reduce first ; + +! [ euler014a ] 10 ave-time +! 5109 ms run / 44 ms GC time + +! TODO: try using memoization + +MAIN: euler014a diff --git a/extra/project-euler/015/015.factor b/extra/project-euler/015/015.factor new file mode 100644 index 0000000000..305426902b --- /dev/null +++ b/extra/project-euler/015/015.factor @@ -0,0 +1,33 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.combinatorics ; +IN: project-euler.015 + +! http://projecteuler.net/index.php?section=problems&id=15 + +! DESCRIPTION +! ----------- + +! Starting in the top left corner of a 2x2 grid, there are 6 routes (without +! backtracking) to the bottom right corner. + +! How many routes are there through a 20x20 grid? + + +! SOLUTION +! -------- + + + +: euler015 ( -- answer ) + 20 grid-paths ; + +! [ euler015 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler015 diff --git a/extra/project-euler/016/016.factor b/extra/project-euler/016/016.factor new file mode 100644 index 0000000000..a8b2aea0b7 --- /dev/null +++ b/extra/project-euler/016/016.factor @@ -0,0 +1,28 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math.functions math.parser sequences ; +IN: project-euler.016 + +! http://projecteuler.net/index.php?section=problems&id=16 + +! DESCRIPTION +! ----------- + +! 2^15 = 32768 and the sum of its digits is 3 + 2 + 7 + 6 + 8 = 26. + +! What is the sum of the digits of the number 2^1000? + + +! SOLUTION +! -------- + +: number>digits ( n -- seq ) + number>string string>digits ; + +: euler016 ( -- answer ) + 2 1000 ^ number>digits sum ; + +! [ euler016 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler016 diff --git a/extra/project-euler/authors.txt b/extra/project-euler/authors.txt new file mode 100644 index 0000000000..4eec9c9a08 --- /dev/null +++ b/extra/project-euler/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer diff --git a/extra/project-euler/ave-time/authors.txt b/extra/project-euler/ave-time/authors.txt new file mode 100644 index 0000000000..4eec9c9a08 --- /dev/null +++ b/extra/project-euler/ave-time/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer diff --git a/extra/project-euler/ave-time/ave-time-docs.factor b/extra/project-euler/ave-time/ave-time-docs.factor new file mode 100644 index 0000000000..cc40ae4bf1 --- /dev/null +++ b/extra/project-euler/ave-time/ave-time-docs.factor @@ -0,0 +1,24 @@ +USING: arrays help.markup help.syntax math memory quotations sequences system tools.time ; +IN: project-euler.ave-time + +HELP: collect-benchmarks +{ $values { "quot" quotation } { "n" integer } { "seq" sequence } } +{ $description "Runs a quotation " { $snippet "n" } " times, collecting the wall clock time and the time spent in the garbage collector into pairs inside of a sequence." } +{ $notes "The stack effect of " { $snippet "quot" } " is inferred and only one set of outputs will remain on the stack no matter how many trials are run." + $nl + "A nicer word for interactive use is " { $link ave-time } "." } ; + +HELP: ave-time +{ $values { "quot" quotation } { "n" integer } } +{ $description "Runs a quotation " { $snippet "n" } " times, then prints the average run time and the average time spent in the garbage collector." } +{ $notes "The stack effect of " { $snippet "quot" } " is inferred and only one set of outputs will remain on the stack no matter how many trials are run." } +{ $examples + "This word can be used to compare performance of the non-optimizing and optimizing compilers." + $nl + "First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:" + { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run / 6 ms GC ave time - 10 trials" } + "Now we define a word and compile it with the optimizing word compiler. This results is faster execution:" + { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run / 13 ms GC ave time - 10 trials" } +} ; + +{ benchmark collect-benchmarks gc-time millis time ave-time } related-words diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor new file mode 100644 index 0000000000..d481b30c84 --- /dev/null +++ b/extra/project-euler/ave-time/ave-time.factor @@ -0,0 +1,25 @@ +! Copyright (c) 2007 Aaron Schaefer +! See http://factorcode.org/license.txt for BSD license. +USING: arrays effects inference io kernel math math.functions math.parser + math.statistics namespaces sequences tools.time ; +IN: project-euler.ave-time + + + +: collect-benchmarks ( quot n -- seq ) + [ + 1- [ [ benchmark ] keep -rot 2array , [ clean-stack ] keep ] times + ] curry { } make >r benchmark 2array r> swap add ; inline + +: ave-time ( quot n -- ) + [ collect-benchmarks ] keep swap ave-benchmarks [ + dup second # " ms run / " % first # " ms GC ave time - " % # " trials" % + ] "" make print flush ; inline diff --git a/extra/project-euler/ave-time/summary.txt b/extra/project-euler/ave-time/summary.txt new file mode 100644 index 0000000000..5fadfa99be --- /dev/null +++ b/extra/project-euler/ave-time/summary.txt @@ -0,0 +1 @@ +Averaging code execution times diff --git a/extra/project-euler/ave-time/tags.txt b/extra/project-euler/ave-time/tags.txt new file mode 100644 index 0000000000..ef1aab0d0e --- /dev/null +++ b/extra/project-euler/ave-time/tags.txt @@ -0,0 +1 @@ +tools diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor new file mode 100644 index 0000000000..73de3a7208 --- /dev/null +++ b/extra/project-euler/common/common.factor @@ -0,0 +1,61 @@ +USING: arrays kernel hashtables math math.functions math.miller-rabin + math.ranges namespaces sequences combinators.lib ; +IN: project-euler.common + +! A collection of words used by more than one Project Euler solution. + +r length 1+ r> - ; + +: shift-3rd ( seq obj obj -- seq obj obj ) + rot 1 tail -rot ; + +: >multiplicity ( seq -- seq ) + dup prune [ + [ 2dup [ = ] curry count 2array , ] each + ] { } make nip ; inline + +: reduce-2s ( n -- r s ) + dup even? [ factor-2s >r 1+ r> ] [ 1 swap ] if ; + +: tau-limit ( n -- n ) + sqrt floor >fixnum ; + +PRIVATE> + + +: divisor? ( n m -- ? ) + mod zero? ; + +: perfect-square? ( n -- ? ) + dup sqrt mod zero? ; + +: collect-consecutive ( seq width -- seq ) + [ + 2dup count-shifts [ 2dup head shift-3rd , ] times + ] { } make 2nip ; + +: prime-factorization ( n -- seq ) + [ + 2 [ over 1 > ] + [ 2dup divisor? [ dup , [ / ] keep ] [ next-prime ] if ] + [ ] while 2drop + ] { } make ; + +: prime-factorization* ( n -- seq ) + prime-factorization >multiplicity ; + +: prime-factors ( n -- seq ) + prime-factorization prune >array ; + +! The divisor function, counts the number of divisors +: tau ( n -- n ) + prime-factorization* flip second 1 [ 1+ * ] reduce ; + +! Optimized brute-force, is often faster than prime factorization +: tau* ( n -- n ) + reduce-2s [ perfect-square? -1 0 ? ] keep dup tau-limit [1,b] [ + dupd divisor? [ >r 2 + r> ] when + ] each drop * ; diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor new file mode 100644 index 0000000000..c35101785a --- /dev/null +++ b/extra/project-euler/project-euler.factor @@ -0,0 +1,44 @@ +! Copyright (c) 2007 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.files kernel math.parser namespaces sequences strings + vocabs vocabs.loader system project-euler.ave-time + project-euler.001 project-euler.002 project-euler.003 project-euler.004 + project-euler.005 project-euler.006 project-euler.007 project-euler.008 + project-euler.009 project-euler.010 project-euler.011 project-euler.012 + project-euler.013 project-euler.014 project-euler.015 project-euler.016 ; +IN: project-euler + +number ; + +: number>euler ( n -- str ) + number>string string>digits 3 0 pad-left [ number>string ] map concat ; + +: solution-path ( n -- str ) + number>euler dup [ + "project-euler" vocab-root ?resource-path % + os "windows" = [ + "\\project-euler\\" % % "\\" % % ".factor" % + ] [ + "/project-euler/" % % "/" % % ".factor" % + ] if + ] "" make ; + +PRIVATE> + +: problem-solved? ( n -- ? ) + solution-path exists? ; + +: run-project-euler ( -- ) + problem-prompt dup problem-solved? [ + dup number>euler "project-euler." swap append run + "Answer: " swap number>string append print + "Source: " swap solution-path append print + ] [ + drop "That problem has not been solved yet..." print + ] if ; + +MAIN: run-project-euler diff --git a/extra/project-euler/summary.txt b/extra/project-euler/summary.txt new file mode 100644 index 0000000000..add3da577f --- /dev/null +++ b/extra/project-euler/summary.txt @@ -0,0 +1 @@ +Project Euler example solutions diff --git a/extra/project-euler/tags.txt b/extra/project-euler/tags.txt new file mode 100644 index 0000000000..1e107f52e4 --- /dev/null +++ b/extra/project-euler/tags.txt @@ -0,0 +1 @@ +examples From afc6100c545621896833226d7971fa7b26f091a6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Dec 2007 16:21:05 -0600 Subject: [PATCH 02/20] add IN: temporary to tests file --- extra/delegate/delegate-tests.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index 01ef33b922..dd9a77aa21 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -1,4 +1,5 @@ USING: delegate kernel arrays tools.test ; +IN: temporary TUPLE: hello this that ; C: hello From d45ed669f81b9ece4a59bc4869af4e6faf6c08e6 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Dec 2007 11:39:42 +1300 Subject: [PATCH 03/20] Add digit, number and string parser to peg --- extra/peg/peg.factor | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 7fa1fb90e5..411a47b9bd 100644 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle - vectors arrays combinators.lib memoize ; + vectors arrays combinators.lib memoize math.parser ; IN: peg TUPLE: parse-result remaining ast ; @@ -265,3 +265,16 @@ MEMO: delay ( parser -- parser ) MEMO: list-of ( items separator -- parser ) hide over 2array seq repeat0 [ concat ] action 2array seq [ unclip 1vector swap first append ] action ; + +MEMO: 'digit' ( -- parser ) + [ digit? ] satisfy [ digit> ] action ; + +MEMO: 'integer' ( -- parser ) + 'digit' repeat1 [ 10 swap digits>integer ] action ; + +MEMO: 'string' ( -- parser ) + [ + [ CHAR: " = ] satisfy hide , + [ CHAR: " = not ] satisfy repeat0 , + [ CHAR: " = ] satisfy hide , + ] { } make seq [ first >string ] action ; From b5186937a4315265f95d129008e06fa4951bb7ea Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Dec 2007 12:48:45 +1300 Subject: [PATCH 04/20] Port fjsc to use pegs instead of parser combinators --- extra/fjsc/fjsc-tests.factor | 50 +++--- extra/fjsc/fjsc.factor | 232 ++++++++++++++------------ extra/fjsc/resources/bootstrap.factor | 7 +- extra/fjsc/resources/bootstrap.js | 6 + extra/webapps/fjsc/fjsc.factor | 6 +- 5 files changed, 166 insertions(+), 135 deletions(-) diff --git a/extra/fjsc/fjsc-tests.factor b/extra/fjsc/fjsc-tests.factor index 1c70c0c325..ccb004581a 100755 --- a/extra/fjsc/fjsc-tests.factor +++ b/extra/fjsc/fjsc-tests.factor @@ -1,54 +1,54 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test parser-combinators lazy-lists fjsc ; +USING: kernel tools.test peg fjsc ; IN: temporary -{ T{ ast-expression f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "55 2abc1 100" 'expression' parse-1 +{ T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ + "55 2abc1 100" 'expression' parse parse-result-ast ] unit-test -{ T{ ast-quotation f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "[ 55 2abc1 100 ]" 'quotation' parse-1 +{ T{ ast-quotation f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ + "[ 55 2abc1 100 ]" 'quotation' parse parse-result-ast ] unit-test -{ T{ ast-array f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "{ 55 2abc1 100 }" 'array' parse-1 +{ T{ ast-array f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ + "{ 55 2abc1 100 }" 'array' parse parse-result-ast ] unit-test -{ T{ ast-stack-effect f { } { "d" "e" "f" } } } [ - "( -- d e f )" 'stack-effect' parse-1 +{ T{ ast-stack-effect f V{ } V{ "d" "e" "f" } } } [ + "( -- d e f )" 'stack-effect' parse parse-result-ast ] unit-test -{ T{ ast-stack-effect f { "a" "b" "c" } { "d" "e" "f" } } } [ - "( a b c -- d e f )" 'stack-effect' parse-1 +{ T{ ast-stack-effect f V{ "a" "b" "c" } V{ "d" "e" "f" } } } [ + "( a b c -- d e f )" 'stack-effect' parse parse-result-ast ] unit-test -{ T{ ast-stack-effect f { "a" "b" "c" } { } } } [ - "( a b c -- )" 'stack-effect' parse-1 +{ T{ ast-stack-effect f V{ "a" "b" "c" } V{ } } } [ + "( a b c -- )" 'stack-effect' parse parse-result-ast ] unit-test -{ T{ ast-stack-effect f { } { } } } [ - "( -- )" 'stack-effect' parse-1 +{ T{ ast-stack-effect f V{ } V{ } } } [ + "( -- )" 'stack-effect' parse parse-result-ast ] unit-test -{ } [ - ": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse car drop +{ f } [ + ": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse not ] unit-test -{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [ - "\"abcd\"" 'statement' parse-1 +{ T{ ast-expression f V{ T{ ast-string f "abcd" } } } } [ + "\"abcd\"" 'statement' parse parse-result-ast ] unit-test -{ T{ ast-expression f { T{ ast-use f "foo" } } } } [ - "USE: foo" 'statement' parse-1 +{ T{ ast-expression f V{ T{ ast-use f "foo" } } } } [ + "USE: foo" 'statement' parse parse-result-ast ] unit-test -{ T{ ast-expression f { T{ ast-in f "foo" } } } } [ - "IN: foo" 'statement' parse-1 +{ T{ ast-expression f V{ T{ ast-in f "foo" } } } } [ + "IN: foo" 'statement' parse parse-result-ast ] unit-test -{ T{ ast-expression f { T{ ast-using f { "foo" "bar" } } } } } [ - "USING: foo bar ;" 'statement' parse-1 +{ T{ ast-expression f V{ T{ ast-using f V{ "foo" "bar" } } } } } [ + "USING: foo bar ;" 'statement' parse parse-result-ast ] unit-test diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index 22031afb25..e469b61617 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -1,50 +1,38 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel lazy-lists parser-combinators parser-combinators.simple - strings promises sequences math math.parser namespaces words - quotations arrays hashtables io io.streams.string assocs ; +USING: kernel peg strings promises sequences math math.parser + namespaces words quotations arrays hashtables io + io.streams.string assocs memoize ; IN: fjsc TUPLE: ast-number value ; -C: ast-number - TUPLE: ast-identifier value vocab ; -C: ast-identifier - TUPLE: ast-string value ; -C: ast-string - TUPLE: ast-quotation values ; -C: ast-quotation - TUPLE: ast-array elements ; -C: ast-array - TUPLE: ast-define name stack-effect expression ; -C: ast-define - TUPLE: ast-expression values ; -C: ast-expression - TUPLE: ast-word value vocab ; -C: ast-word - TUPLE: ast-comment ; -C: ast-comment - TUPLE: ast-stack-effect in out ; -C: ast-stack-effect - TUPLE: ast-use name ; -C: ast-use - TUPLE: ast-using names ; -C: ast-using - TUPLE: ast-in name ; -C: ast-in - TUPLE: ast-hashtable elements ; + +C: ast-number +C: ast-identifier +C: ast-string +C: ast-quotation +C: ast-array +C: ast-define +C: ast-expression +C: ast-word +C: ast-comment +C: ast-stack-effect +C: ast-use +C: ast-using +C: ast-in C: ast-hashtable : identifier-middle? ( ch -- bool ) @@ -56,7 +44,7 @@ C: ast-hashtable digit? not and and and and and ; -LAZY: 'identifier-ends' ( -- parser ) +MEMO: 'identifier-ends' ( -- parser ) [ [ blank? not ] keep [ CHAR: " = not ] keep @@ -65,99 +53,137 @@ LAZY: 'identifier-ends' ( -- parser ) [ letter? not ] keep identifier-middle? not and and and and and - ] satisfy ; + ] satisfy repeat0 ; -LAZY: 'identifier-middle' ( -- parser ) - [ identifier-middle? ] satisfy ; +MEMO: 'identifier-middle' ( -- parser ) + [ identifier-middle? ] satisfy repeat1 ; -LAZY: 'identifier' ( -- parser ) - 'identifier-ends' - 'identifier-middle' <&> - 'identifier-ends' <:&> - [ concat >string f ] <@ ; +MEMO: 'identifier' ( -- parser ) + [ + 'identifier-ends' , + 'identifier-middle' , + 'identifier-ends' , + ] { } make seq [ + concat >string f + ] action ; DEFER: 'expression' -LAZY: 'effect-name' ( -- parser ) +MEMO: 'effect-name' ( -- parser ) [ [ blank? not ] keep + [ CHAR: ) = not ] keep CHAR: - = not - and - ] satisfy [ >string ] <@ ; + and and + ] satisfy repeat1 [ >string ] action ; -LAZY: 'stack-effect' ( -- parser ) - "(" token sp - 'effect-name' sp <*> &> - "--" token sp <& - 'effect-name' sp <*> <&> - ")" token sp <& [ first2 ] <@ ; +MEMO: 'stack-effect' ( -- parser ) + [ + "(" token hide , + 'effect-name' sp repeat0 , + "--" token sp hide , + 'effect-name' sp repeat0 , + ")" token sp hide , + ] { } make seq [ + first2 + ] action ; -LAZY: 'define' ( -- parser ) - ":" token sp - 'identifier' sp [ ast-identifier-value ] <@ &> - 'stack-effect' sp <&> - 'expression' <:&> - ";" token sp <& [ first3 ] <@ ; +MEMO: 'define' ( -- parser ) + [ + ":" token sp hide , + 'identifier' sp [ ast-identifier-value ] action , + 'stack-effect' sp optional , + 'expression' , + ";" token sp hide , + ] { } make seq [ first3 ] action ; -LAZY: 'quotation' ( -- parser ) - "[" token sp - 'expression' [ ast-expression-values ] <@ &> - "]" token sp <& [ ] <@ ; +MEMO: 'quotation' ( -- parser ) + [ + "[" token sp hide , + 'expression' [ ast-expression-values ] action , + "]" token sp hide , + ] { } make seq [ first ] action ; -LAZY: 'array' ( -- parser ) - "{" token sp - 'expression' [ ast-expression-values ] <@ &> - "}" token sp <& [ ] <@ ; +MEMO: 'array' ( -- parser ) + [ + "{" token sp hide , + 'expression' [ ast-expression-values ] action , + "}" token sp hide , + ] { } make seq [ first ] action ; -LAZY: 'word' ( -- parser ) - "\\" token sp - 'identifier' sp &> [ ast-identifier-value f ] <@ ; +MEMO: 'word' ( -- parser ) + [ + "\\" token sp hide , + 'identifier' sp , + ] { } make seq [ first ast-identifier-value f ] action ; -LAZY: 'atom' ( -- parser ) - 'identifier' 'integer' [ ] <@ <|> 'string' [ ] <@ <|> ; +MEMO: 'atom' ( -- parser ) + [ + 'identifier' , + 'integer' [ ] action , + 'string' [ ] action , + ] { } make choice ; -LAZY: 'comment' ( -- parser ) - "#!" token sp - "!" token sp <|> [ - dup CHAR: \n = swap CHAR: \r = or not - ] satisfy <*> <&> [ drop ] <@ ; +MEMO: 'comment' ( -- parser ) + [ + [ + "#!" token sp , + "!" token sp , + ] { } make choice hide , + [ + dup CHAR: \n = swap CHAR: \r = or not + ] satisfy repeat0 , + ] { } make seq [ drop ] action ; -LAZY: 'USE:' ( -- parser ) - "USE:" token sp - 'identifier' sp &> [ ast-identifier-value ] <@ ; +MEMO: 'USE:' ( -- parser ) + [ + "USE:" token sp hide , + 'identifier' sp , + ] { } make seq [ first ast-identifier-value ] action ; -LAZY: 'IN:' ( -- parser ) - "IN:" token sp - 'identifier' sp &> [ ast-identifier-value ] <@ ; +MEMO: 'IN:' ( -- parser ) + [ + "IN:" token sp hide , + 'identifier' sp , + ] { } make seq [ first ast-identifier-value ] action ; -LAZY: 'USING:' ( -- parser ) - "USING:" token sp - 'identifier' sp [ ast-identifier-value ] <@ <+> &> - ";" token sp <& [ ] <@ ; +MEMO: 'USING:' ( -- parser ) + [ + "USING:" token sp hide , + 'identifier' sp [ ast-identifier-value ] action repeat1 , + ";" token sp hide , + ] { } make seq [ first ] action ; -LAZY: 'hashtable' ( -- parser ) - "H{" token sp - 'expression' [ ast-expression-values ] <@ &> - "}" token sp <& [ ] <@ ; +MEMO: 'hashtable' ( -- parser ) + [ + "H{" token sp hide , + 'expression' [ ast-expression-values ] action , + "}" token sp hide , + ] { } make seq [ first ] action ; -LAZY: 'parsing-word' ( -- parser ) - 'USE:' - 'USING:' <|> - 'IN:' <|> ; +MEMO: 'parsing-word' ( -- parser ) + [ + 'USE:' , + 'USING:' , + 'IN:' , + ] { } make choice ; -LAZY: 'expression' ( -- parser ) - 'comment' - 'parsing-word' sp <|> - 'quotation' sp <|> - 'define' sp <|> - 'array' sp <|> - 'hashtable' sp <|> - 'word' sp <|> - 'atom' sp <|> - <*> [ ] <@ ; +MEMO: 'expression' ( -- parser ) + [ + [ + 'comment' , + 'parsing-word' sp , + 'quotation' sp , + 'define' sp , + 'array' sp , + 'hashtable' sp , + 'word' sp , + 'atom' sp , + ] { } make choice repeat0 [ ] action + ] delay ; -LAZY: 'statement' ( -- parser ) +MEMO: 'statement' ( -- parser ) 'expression' ; GENERIC: (compile) ( ast -- ) @@ -328,7 +354,7 @@ M: wrapper (parse-factor-quotation) ( object -- ast ) GENERIC: fjsc-parse ( object -- ast ) M: string fjsc-parse ( object -- ast ) - 'expression' parse-1 ; + 'expression' parse parse-result-ast ; M: quotation fjsc-parse ( object -- ast ) [ @@ -345,11 +371,11 @@ M: quotation fjsc-parse ( object -- ast ) ] string-out ; : fjsc-compile* ( string -- string ) - 'statement' parse-1 fjsc-compile ; + 'statement' parse parse-result-ast fjsc-compile ; : fc* ( string -- string ) [ - 'statement' parse-1 ast-expression-values do-expressions + 'statement' parse parse-result-ast ast-expression-values do-expressions ] { } make [ write ] each ; diff --git a/extra/fjsc/resources/bootstrap.factor b/extra/fjsc/resources/bootstrap.factor index 13fef4aa57..db63f15f1c 100644 --- a/extra/fjsc/resources/bootstrap.factor +++ b/extra/fjsc/resources/bootstrap.factor @@ -3,10 +3,6 @@ USE: kernel-internals : bind ( ns quot -- ) swap >n call n> drop ; -: alert ( string -- ) - #! Display the string in an alert box - window { } "" "alert" { "string" } alien-invoke ; - "browser-dom" set-in : elements ( string -- result ) @@ -38,3 +34,6 @@ USE: kernel-internals drop "Click done!" alert ] callcc0 ; +: alert ( string -- ) + #! Display the string in an alert box + window { } "" "alert" { "string" } alien-invoke ; diff --git a/extra/fjsc/resources/bootstrap.js b/extra/fjsc/resources/bootstrap.js index 43d100ec73..032829c363 100644 --- a/extra/fjsc/resources/bootstrap.js +++ b/extra/fjsc/resources/bootstrap.js @@ -513,6 +513,12 @@ factor.add_word("alien", "set-alien-property", "primitive", function(next) { factor.call_next(next); }); +factor.add_word("alien", "uneval", "primitive", function(next) { + var stack = factor.cont.data_stack; + stack.push(uneval(stack.pop())); + factor.call_next(next); +}); + factor.add_word("words", "vocabs", "primitive", function(next) { var stack = factor.cont.data_stack; var result = []; diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor index b21e91bc8f..19dab4ed1b 100755 --- a/extra/webapps/fjsc/fjsc.factor +++ b/extra/webapps/fjsc/fjsc.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel furnace fjsc parser-combinators namespaces +USING: kernel furnace fjsc peg namespaces lazy-lists io io.files furnace.validator sequences http.client http.server http.server.responders webapps.file html ; @@ -11,7 +11,7 @@ IN: webapps.fjsc #! Compile the factor code as a string, outputting the http #! response containing the javascript. serving-text - 'expression' parse-1 fjsc-compile + 'expression' parse parse-result-ast fjsc-compile write flush ; ! The 'compile' action results in an URL that looks like @@ -25,7 +25,7 @@ IN: webapps.fjsc : compile-url ( url -- ) #! Compile the factor code at the given url, return the javascript. dup "http:" head? [ "Unable to access remote sites." throw ] when - "http://" host rot 3append http-get 2nip compile "();" write flush ; + "http://" "Host" header-param rot 3append http-get 2nip compile "();" write flush ; \ compile-url { { "url" v-required } From 9a5335e7189a6368d998f167dc0d414c5607f08f Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Dec 2007 16:46:25 +1300 Subject: [PATCH 05/20] Fix IN: in parser-combinators.replace --- extra/parser-combinators/replace/replace.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/parser-combinators/replace/replace.factor b/extra/parser-combinators/replace/replace.factor index 541bde7ac7..8adce4f160 100755 --- a/extra/parser-combinators/replace/replace.factor +++ b/extra/parser-combinators/replace/replace.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel math io io.streams.string sequences strings lazy-lists combinators parser-combinators.simple ; -IN: parser-combinators +IN: parser-combinators.replace : tree-write ( object -- ) { From 7817af0104dde231376e2ed807a5fe7c45f7131b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Dec 2007 16:48:58 +1300 Subject: [PATCH 06/20] Fix IN: in parser-combinators.simple --- extra/parser-combinators/simple/simple.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/parser-combinators/simple/simple.factor b/extra/parser-combinators/simple/simple.factor index c5b84d86c6..3b59068dd6 100755 --- a/extra/parser-combinators/simple/simple.factor +++ b/extra/parser-combinators/simple/simple.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel strings math sequences lazy-lists words -math.parser promises ; -IN: parser-combinators +math.parser promises parser-combinators ; +IN: parser-combinators.simple : 'digit' ( -- parser ) [ digit? ] satisfy [ digit> ] <@ ; From 42e20874fe285bdeb5778f5f51391a896614096b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Dec 2007 16:50:08 +1300 Subject: [PATCH 07/20] Fix USING: in parser-combinators.replace --- extra/parser-combinators/replace/replace.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/parser-combinators/replace/replace.factor b/extra/parser-combinators/replace/replace.factor index 8adce4f160..d783fde061 100755 --- a/extra/parser-combinators/replace/replace.factor +++ b/extra/parser-combinators/replace/replace.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math io io.streams.string sequences strings -lazy-lists combinators parser-combinators.simple ; +lazy-lists combinators parser-combinators parser-combinators.simple ; IN: parser-combinators.replace : tree-write ( object -- ) From 6bd283ffa3188191b088c297d4536ad7c75d133c Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Dec 2007 17:06:21 +1300 Subject: [PATCH 08/20] Convert parser-combinators.replace to pegs --- extra/peg/replace/replace-docs.factor | 43 ++++++++++++++++++++++++++ extra/peg/replace/replace-tests.factor | 18 +++++++++++ extra/peg/replace/replace.factor | 32 +++++++++++++++++++ 3 files changed, 93 insertions(+) create mode 100644 extra/peg/replace/replace-docs.factor create mode 100644 extra/peg/replace/replace-tests.factor create mode 100755 extra/peg/replace/replace.factor diff --git a/extra/peg/replace/replace-docs.factor b/extra/peg/replace/replace-docs.factor new file mode 100644 index 0000000000..35f13e8ecd --- /dev/null +++ b/extra/peg/replace/replace-docs.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup peg peg.replace ; + +HELP: tree-write +{ $values + { "object" "an object" } } +{ $description + "Write the object to the standard output stream, unless " + "it is an array, in which case recurse through the array " + "writing each object to the stream." } +{ $example "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ; + +HELP: search +{ $values + { "string" "a string" } + { "parser" "a peg based parser" } + { "seq" "a sequence" } +} +{ $description + "Returns a sequence containing the parse results of all substrings " + "from the input string that successfully parse using the " + "parser." +} + +{ $example "\"one 123 two 456\" 'integer' search" "V{ 123 456 }" } +{ $example "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2array choice search" "V{ 123 \"hello\" 456 }" } +{ $see-also replace } ; + +HELP: replace +{ $values + { "string" "a string" } + { "parser" "a peg based parser" } + { "result" "a string" } +} +{ $description + "Returns a copy of the original string but with all substrings that " + "successfully parse with the given parser replaced with " + "the result of that parser." +} +{ $example "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace" "\"one 246 two 912\"" } +{ $see-also search } ; + diff --git a/extra/peg/replace/replace-tests.factor b/extra/peg/replace/replace-tests.factor new file mode 100644 index 0000000000..91c91f4fc4 --- /dev/null +++ b/extra/peg/replace/replace-tests.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +USING: kernel math math.parser arrays tools.test peg peg.replace ; +IN: temporary + +{ V{ 123 456 } } [ + "abc 123 def 456" 'integer' search +] unit-test + +{ V{ 123 "hello" 456 } } [ + "one 123 \"hello\" two 456" 'integer' 'string' 2array choice search +] unit-test + +{ "abc 246 def 912" } [ + "abc 123 def 456" 'integer' [ 2 * number>string ] action replace +] unit-test + diff --git a/extra/peg/replace/replace.factor b/extra/peg/replace/replace.factor new file mode 100755 index 0000000000..5440a8e45f --- /dev/null +++ b/extra/peg/replace/replace.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math io io.streams.string sequences strings +combinators peg memoize arrays ; +IN: peg.replace + +: tree-write ( object -- ) + { + { [ dup number? ] [ write1 ] } + { [ dup string? ] [ write ] } + { [ dup sequence? ] [ [ tree-write ] each ] } + { [ t ] [ write ] } + } cond ; + +MEMO: any-char-parser ( -- parser ) + [ drop t ] satisfy ; + +: search ( string parser -- seq ) + any-char-parser [ drop f ] action 2array choice repeat0 parse dup [ + parse-result-ast [ ] subset + ] [ + drop { } + ] if ; + + +: (replace) ( string parser -- seq ) + any-char-parser 2array choice repeat0 parse parse-result-ast [ ] subset ; + +: replace ( string parser -- result ) + [ (replace) [ tree-write ] each ] string-out ; + + From 6a8bfad475bd17d404cf76d59097f9024df69b1c Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Dec 2007 17:09:12 +1300 Subject: [PATCH 09/20] Rename peg.replace to peg.search --- .../{replace/replace-docs.factor => search/search-docs.factor} | 2 +- .../replace-tests.factor => search/search-tests.factor} | 2 +- extra/peg/{replace/replace.factor => search/search.factor} | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) rename extra/peg/{replace/replace-docs.factor => search/search-docs.factor} (96%) rename extra/peg/{replace/replace-tests.factor => search/search-tests.factor} (85%) rename extra/peg/{replace/replace.factor => search/search.factor} (97%) diff --git a/extra/peg/replace/replace-docs.factor b/extra/peg/search/search-docs.factor similarity index 96% rename from extra/peg/replace/replace-docs.factor rename to extra/peg/search/search-docs.factor index 35f13e8ecd..d6dc5e543b 100644 --- a/extra/peg/replace/replace-docs.factor +++ b/extra/peg/search/search-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup peg peg.replace ; +USING: help.syntax help.markup peg peg.search ; HELP: tree-write { $values diff --git a/extra/peg/replace/replace-tests.factor b/extra/peg/search/search-tests.factor similarity index 85% rename from extra/peg/replace/replace-tests.factor rename to extra/peg/search/search-tests.factor index 91c91f4fc4..53dcbd99f5 100644 --- a/extra/peg/replace/replace-tests.factor +++ b/extra/peg/search/search-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel math math.parser arrays tools.test peg peg.replace ; +USING: kernel math math.parser arrays tools.test peg peg.search ; IN: temporary { V{ 123 456 } } [ diff --git a/extra/peg/replace/replace.factor b/extra/peg/search/search.factor similarity index 97% rename from extra/peg/replace/replace.factor rename to extra/peg/search/search.factor index 5440a8e45f..86b6e114cf 100755 --- a/extra/peg/replace/replace.factor +++ b/extra/peg/search/search.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel math io io.streams.string sequences strings combinators peg memoize arrays ; -IN: peg.replace +IN: peg.search : tree-write ( object -- ) { From a376cb6cc35f160dd12a7d33f0025efc837ddab8 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Dec 2007 17:10:45 +1300 Subject: [PATCH 10/20] Add summary, author and tags to peg.search --- extra/peg/search/authors.txt | 1 + extra/peg/search/summary.txt | 1 + extra/peg/search/tags.txt | 1 + 3 files changed, 3 insertions(+) create mode 100644 extra/peg/search/authors.txt create mode 100644 extra/peg/search/summary.txt create mode 100644 extra/peg/search/tags.txt diff --git a/extra/peg/search/authors.txt b/extra/peg/search/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/peg/search/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/peg/search/summary.txt b/extra/peg/search/summary.txt new file mode 100644 index 0000000000..ad27ade319 --- /dev/null +++ b/extra/peg/search/summary.txt @@ -0,0 +1 @@ +Search and replace using parsing expression grammars diff --git a/extra/peg/search/tags.txt b/extra/peg/search/tags.txt new file mode 100644 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/peg/search/tags.txt @@ -0,0 +1 @@ +parsing From b655d4c759cc577b12e0b02c01f19ec75692db81 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Dec 2007 17:11:37 +1300 Subject: [PATCH 11/20] Add tags to peg, peg.ebnf and peg.pl0 --- extra/peg/ebnf/tags.txt | 1 + extra/peg/pl0/tags.txt | 1 + extra/peg/tags.txt | 1 + 3 files changed, 3 insertions(+) create mode 100644 extra/peg/ebnf/tags.txt create mode 100644 extra/peg/pl0/tags.txt create mode 100644 extra/peg/tags.txt diff --git a/extra/peg/ebnf/tags.txt b/extra/peg/ebnf/tags.txt new file mode 100644 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/peg/ebnf/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/peg/pl0/tags.txt b/extra/peg/pl0/tags.txt new file mode 100644 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/peg/pl0/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/peg/tags.txt b/extra/peg/tags.txt new file mode 100644 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/peg/tags.txt @@ -0,0 +1 @@ +parsing From 0bf1355657cdae298932b7778334f2e9691d92ee Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 20 Dec 2007 17:12:48 +1300 Subject: [PATCH 12/20] Remove parser-combinators.replace --- .../replace/replace-docs.factor | 76 ------------------- .../parser-combinators/replace/replace.factor | 37 --------- 2 files changed, 113 deletions(-) delete mode 100644 extra/parser-combinators/replace/replace-docs.factor delete mode 100755 extra/parser-combinators/replace/replace.factor diff --git a/extra/parser-combinators/replace/replace-docs.factor b/extra/parser-combinators/replace/replace-docs.factor deleted file mode 100644 index fe73f5d3c2..0000000000 --- a/extra/parser-combinators/replace/replace-docs.factor +++ /dev/null @@ -1,76 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup parser-combinators -parser-combinators.replace ; - -HELP: tree-write -{ $values - { "object" "an object" } } -{ $description - "Write the object to the standard output stream, unless " - "it is an array, in which case recurse through the array " - "writing each object to the stream." } -{ $example "USE: parser-combinators" "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ; - -HELP: search -{ $values - { "string" "a string" } - { "parser" "a parser combinator based parser" } - { "seq" "a sequence" } -} -{ $description - "Returns a sequence containing the parse results of all substrings " - "from the input string that successfully parse using the " - "parser." -} - -{ $example "USE: parser-combinators" "\"one 123 two 456\" 'integer' search ." "{ 123 456 }" } -{ $example "USE: parser-combinators" "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' <|> search ." "{ 123 \"hello\" 456 }" } -{ $see-also search* replace replace* } ; - -HELP: search* -{ $values - { "string" "a string" } - { "parsers" "a sequence of parser combinator based parsers" } - { "seq" "a sequence" } -} -{ $description - "Returns a sequence containing the parse results of all substrings " - "from the input string that successfully parse using any of the " - "parsers in the 'parsers' sequence." -} - -{ $example "USE: parser-combinators" "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2array search* ." "{ 123 \"hello\" 456 }" } -{ $see-also search replace replace* } ; - -HELP: replace -{ $values - { "string" "a string" } - { "parser" "a parser combinator based parser" } - { "result" "a string" } -} -{ $description - "Returns a copy of the original string but with all substrings that " - "successfully parse with the given parser replaced with " - "the result of that parser." -} -{ $example "USING: parser-combinators math.parser ;" "\"one 123 two 456\" 'integer' [ 2 * number>string ] <@ replace ." "\"one 246 two 912\"" } -{ $example "USE: parser-combinators" "\"hello *world* from *factor*\" 'bold' [ \"\" swap \"\" 3append ] <@ replace ." "\"hello world from factor\"" } -{ $example "USE: parser-combinators" "\"hello *world* from _factor_\"\n 'bold' [ \"\" swap \"\" 3append ] <@\n 'italic' [ \"\" swap \"\" 3append ] <@ <|>\n replace ." "\"hello world from factor\"" } -{ $see-also search search* replace* } ; - -HELP: replace* -{ $values - { "string" "a string" } - { "parsers" "a sequence of parser combinator based parsers" } - { "result" "a string" } -} -{ $description - "Returns a copy of the original string but with all substrings that " - "successfully parse with the given parsers replaced with " - "the result of that parser. Each parser is done in sequence so that " - "the parse results of the first parser can be replaced by later parsers." -} -{ $example "USE: parser-combinators" "\"*hello _world_*\"\n 'bold' [ \"\" swap \"\" 3append ] <@\n 'italic' [ \"\" swap \"\" 3append ] <@ 2array\n replace* ." "\"hello world\"" } -{ $see-also search search* replace* } ; - diff --git a/extra/parser-combinators/replace/replace.factor b/extra/parser-combinators/replace/replace.factor deleted file mode 100755 index d783fde061..0000000000 --- a/extra/parser-combinators/replace/replace.factor +++ /dev/null @@ -1,37 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel math io io.streams.string sequences strings -lazy-lists combinators parser-combinators parser-combinators.simple ; -IN: parser-combinators.replace - -: tree-write ( object -- ) - { - { [ dup number? ] [ write1 ] } - { [ dup string? ] [ write ] } - { [ dup sequence? ] [ [ tree-write ] each ] } - { [ t ] [ write ] } - } cond ; - -: search ( string parser -- seq ) - any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [ - drop { } - ] [ - car parse-result-parsed [ ] subset - ] if ; - -: search* ( string parsers -- seq ) - unclip [ <|> ] reduce any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [ - drop { } - ] [ - car parse-result-parsed [ ] subset - ] if ; - -: (replace) ( string parser -- seq ) - any-char-parser <|> <*> parse-1 ; - -: replace ( string parser -- result ) - [ (replace) [ tree-write ] each ] string-out ; - -: replace* ( string parsers -- result ) - swap [ replace ] reduce ; - From b4575a9bff6a357343a7a8c2ffb2a7e0dc7b89a5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 19 Dec 2007 23:34:30 -0600 Subject: [PATCH 13/20] Templating now runs in quiet mode session ids are now 4 bignum number>string string>sha-256-string add assoc-heaps sessions are stored in an assoc-heap --- core/heaps/heaps-tests.factor | 16 ++++++- core/heaps/heaps.factor | 41 +++++++++++++--- extra/assoc-heaps/assoc-heaps-tests.factor | 46 ++++++++++++++++++ extra/assoc-heaps/assoc-heaps.factor | 48 +++++++++++++++++++ extra/furnace/furnace.factor | 24 ++++++---- extra/furnace/sessions/sessions.factor | 17 +++++-- .../http/server/templating/templating.factor | 1 + extra/webapps/pastebin/pastebin.factor | 2 +- 8 files changed, 172 insertions(+), 23 deletions(-) create mode 100644 extra/assoc-heaps/assoc-heaps-tests.factor create mode 100644 extra/assoc-heaps/assoc-heaps.factor diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 03e0816c19..de661fad92 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -1,7 +1,8 @@ ! Copyright 2007 Ryan Murphy ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math tools.test heaps heaps.private ; +USING: arrays kernel math namespaces tools.test +heaps heaps.private ; IN: temporary [ heap-pop ] unit-test-fails @@ -33,3 +34,16 @@ IN: temporary [ 0 ] [ heap-length ] unit-test [ 1 ] [ t 1 pick heap-push heap-length ] unit-test + +[ { { 1 2 } { 3 4 } { 5 6 } } ] [ + T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } + [ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make +] unit-test +[ { { 1 2 } } ] [ + T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } + [ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make +] unit-test +[ { } ] [ + T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } + [ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make +] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 73a37660f6..f01b436e90 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -3,6 +3,19 @@ USING: kernel math sequences arrays assocs ; IN: heaps +MIXIN: priority-queue + +GENERIC: heap-push ( value key heap -- ) +GENERIC: heap-push-all ( assoc heap -- ) +GENERIC: heap-peek ( heap -- value key ) +GENERIC: heap-pop* ( heap -- ) +GENERIC: heap-pop ( heap -- value key ) +GENERIC: heap-delete ( key heap -- ) +GENERIC: heap-delete* ( key heap -- old ? ) +GENERIC: heap-empty? ( heap -- ? ) +GENERIC: heap-length ( heap -- n ) +GENERIC# heap-pop-while 2 ( heap pred quot -- ) + ( -- max-heap ) max-heap ; +INSTANCE: min-heap priority-queue +INSTANCE: max-heap priority-queue + -: heap-push ( value key heap -- ) +M: priority-queue heap-push ( value key heap -- ) >r swap 2array r> [ heap-data push ] keep [ heap-data ] keep up-heap ; -: heap-push-all ( assoc heap -- ) +M: priority-queue heap-push-all ( assoc heap -- ) [ swapd heap-push ] curry assoc-each ; -: heap-peek ( heap -- value key ) +M: priority-queue heap-peek ( heap -- value key ) heap-data first first2 swap ; -: heap-pop* ( heap -- ) +M: priority-queue heap-pop* ( heap -- ) dup heap-data length 1 > [ [ heap-data pop ] keep [ heap-data set-first ] keep @@ -106,8 +122,19 @@ PRIVATE> heap-data pop* ] if ; -: heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ; +M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ; -: heap-empty? ( heap -- ? ) heap-data empty? ; +M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ; -: heap-length ( heap -- n ) heap-data length ; +M: priority-queue heap-length ( heap -- n ) heap-data length ; + +: (heap-pop-while) ( heap pred quot -- ) + pick heap-empty? [ + 3drop + ] [ + [ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep + roll [ (heap-pop-while) ] [ 3drop ] if + ] if ; + +M: priority-queue heap-pop-while ( heap pred quot -- ) + [ heap-pop ] swap [ t ] 3compose (heap-pop-while) ; diff --git a/extra/assoc-heaps/assoc-heaps-tests.factor b/extra/assoc-heaps/assoc-heaps-tests.factor new file mode 100644 index 0000000000..656e7fc15c --- /dev/null +++ b/extra/assoc-heaps/assoc-heaps-tests.factor @@ -0,0 +1,46 @@ +USING: assocs assoc-heaps heaps heaps.private kernel tools.test ; +IN: temporary + +[ +T{ + assoc-heap + f + H{ { 2 1 } } + T{ min-heap T{ heap f V{ { 1 2 } } } } +} +] [ H{ } clone 1 2 pick heap-push ] unit-test + +[ +T{ + assoc-heap + f + H{ { 1 0 } { 2 1 } } + T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } } +} +] [ H{ } clone 1 2 pick heap-push 0 1 pick heap-push ] unit-test + +[ T{ assoc-heap f H{ } T{ min-heap T{ heap f V{ } } } } ] +[ + H{ } clone + 1 2 pick heap-push 0 1 pick heap-push + dup heap-pop 2drop dup heap-pop 2drop +] unit-test + + +[ 0 1 ] [ +T{ + assoc-heap + f + H{ { 1 0 } { 2 1 } } + T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } } +} heap-pop +] unit-test + +[ 1 2 ] [ +T{ + assoc-heap + f + H{ { 1 0 } { 2 1 } } + T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } } +} heap-pop +] unit-test diff --git a/extra/assoc-heaps/assoc-heaps.factor b/extra/assoc-heaps/assoc-heaps.factor new file mode 100644 index 0000000000..0c44950923 --- /dev/null +++ b/extra/assoc-heaps/assoc-heaps.factor @@ -0,0 +1,48 @@ +USING: assocs heaps kernel sequences ; +IN: assoc-heaps + +TUPLE: assoc-heap assoc heap ; + +INSTANCE: assoc-heap assoc +INSTANCE: assoc-heap priority-queue + +C: assoc-heap + +: ( assoc -- obj ) ; +: ( assoc -- obj ) ; + +M: assoc-heap at* ( key assoc-heap -- value ? ) + assoc-heap-assoc at* ; + +M: assoc-heap assoc-size ( assoc-heap -- n ) + assoc-heap-assoc assoc-size ; + +TUPLE: assoc-heap-key-exists ; + +: check-key-exists ( key assoc-heap -- ) + assoc-heap-assoc key? + [ \ assoc-heap-key-exists construct-empty throw ] when ; + +M: assoc-heap set-at ( value key assoc-heap -- ) + [ check-key-exists ] 2keep + [ assoc-heap-assoc set-at ] 3keep + assoc-heap-heap swapd heap-push ; + +M: assoc-heap heap-empty? ( assoc-heap -- ? ) + assoc-heap-assoc assoc-empty? ; + +M: assoc-heap heap-length ( assoc-heap -- n ) + assoc-heap-assoc assoc-size ; + +M: assoc-heap heap-peek ( assoc-heap -- value key ) + assoc-heap-heap heap-peek ; + +M: assoc-heap heap-push ( value key assoc-heap -- ) + set-at ; + +M: assoc-heap heap-push-all ( assoc assoc-heap -- ) + swap [ rot set-at ] curry* each ; + +M: assoc-heap heap-pop ( assoc-heap -- value key ) + dup assoc-heap-heap heap-pop swap + rot dupd assoc-heap-assoc delete-at ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 6d6ce6b4bf..e745e28ad5 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs debugger furnace.sessions furnace.validator -hashtables html.elements http http.server.responders -http.server.templating -io.files kernel namespaces quotations sequences splitting words -strings vectors webapps.callback ; +USING: arrays assocs calendar debugger furnace.sessions furnace.validator +hashtables heaps html.elements http http.server.responders +http.server.templating io.files kernel math namespaces +quotations sequences splitting words strings vectors +webapps.callback ; USING: continuations io prettyprint ; IN: furnace @@ -57,13 +57,17 @@ SYMBOL: validation-errors ] if* ] curry* map ; +: expire-sessions ( -- ) + sessions get-global + [ nip session-last-seen 20 minutes ago <=> 0 > ] + [ 2drop ] heap-pop-while ; + : lookup-session ( hash -- session ) - "furnace-session-id" over at* [ - sessions get-global at - [ nip ] [ "furnace-session-id" over delete-at lookup-session ] if* + "furnace-session-id" over at sessions get-global at [ + nip ] [ - drop new-session rot "furnace-session-id" swap set-at - ] if ; + new-session rot "furnace-session-id" swap set-at + ] if* ; : quot>query ( seq action -- hash ) >r >array r> "action-params" word-prop diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index d253ae165b..523598efe7 100644 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -1,15 +1,23 @@ -USING: assocs calendar init kernel math.parser namespaces random ; +USING: assoc-heaps assocs calendar crypto.sha2 heaps +init kernel math.parser namespaces random ; IN: furnace.sessions SYMBOL: sessions -[ H{ } clone sessions set-global ] "furnace.sessions" add-init-hook +[ + H{ } clone + sessions set-global +] "furnace.sessions" add-init-hook : new-session-id ( -- str ) - 1 big-random number>string ; + 4 big-random number>string string>sha-256-string + dup sessions get-global at [ drop new-session-id ] when ; TUPLE: session created last-seen user-agent namespace ; +M: session <=> ( session1 session2 -- n ) + [ session-last-seen ] 2apply <=> ; + : ( -- obj ) now dup H{ } clone [ set-session-created set-session-last-seen set-session-namespace ] @@ -21,8 +29,9 @@ TUPLE: session created last-seen user-agent namespace ; : get-session ( id -- obj/f ) sessions get-global at* [ "no session found 1" throw ] unless ; +! Delete from the assoc only, the heap will timeout : destroy-session ( id -- ) - sessions get-global delete-at ; + sessions get-global assoc-heap-assoc delete-at ; : session> ( str -- obj ) session get session-namespace at ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index d76e11287c..cd587799c2 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -76,6 +76,7 @@ DEFER: <% delimiter : run-template-file ( filename -- ) [ [ + "quiet" on file-vocabs parser-notes off templating-vocab use+ diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 13d6846aa3..0a7dc559c3 100755 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -1,6 +1,6 @@ USING: calendar furnace furnace.validator io.files kernel namespaces sequences store http.server.responders html -math.parser rss xml.writer ; +math.parser rss xml.writer xmode.code2html ; IN: webapps.pastebin TUPLE: pastebin pastes ; From 858237c0f879acc362805822f1f850c0e2646f25 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 21 Dec 2007 05:42:25 +0100 Subject: [PATCH 14/20] Reimplement leach so that stack is clean when executing the quotation The previous implementation let garbage on the stack (such as the lazy list cdr) before executing the quotation. This prevents easy implementation of reduce-like words using leach. --- extra/lazy-lists/lazy-lists.factor | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index 2e3dc9154a..c629408704 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -100,11 +100,7 @@ M: lazy-cons list? ( object -- bool ) dup car swap cdr ; : leach ( list quot -- ) - swap dup nil? [ - 2drop - ] [ - uncons swap pick call swap leach - ] if ; + swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline TUPLE: memoized-cons original car cdr nil? ; From d5cd2fd66bab124c1820b777f04167aa903dcdcd Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 21 Dec 2007 01:34:16 +0100 Subject: [PATCH 15/20] Add lazy-while and lazy-until to lazy-lists --- extra/lazy-lists/authors.txt | 1 + extra/lazy-lists/lazy-lists-docs.factor | 10 ++++++ extra/lazy-lists/lazy-lists.factor | 42 +++++++++++++++++++++++++ 3 files changed, 53 insertions(+) diff --git a/extra/lazy-lists/authors.txt b/extra/lazy-lists/authors.txt index 6d23bcac92..f6ba9ba80d 100644 --- a/extra/lazy-lists/authors.txt +++ b/extra/lazy-lists/authors.txt @@ -1,2 +1,3 @@ Chris Double +Samuel Tardieu Matthew Willis diff --git a/extra/lazy-lists/lazy-lists-docs.factor b/extra/lazy-lists/lazy-lists-docs.factor index e8acb397df..b66eb6367f 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/extra/lazy-lists/lazy-lists-docs.factor @@ -114,6 +114,16 @@ HELP: lsubset { $description "Perform a similar functionality to that of the " { $link subset } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } { $see-also leach lmap lmap-with ltake lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ; +HELP: lwhile +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } } +{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } +{ $see-also luntil } ; + +HELP: luntil +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } } +{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } +{ $see-also lwhile } ; + HELP: list>vector { $values { "list" "a cons object" } { "vector" "the list converted to a vector" } } { $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." } diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index c629408704..1fb7a18cba 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -206,6 +206,48 @@ M: lazy-take nil? ( lazy-take -- bool ) M: lazy-take list? ( object -- bool ) drop t ; +TUPLE: lazy-until cons quot ; + +C: lazy-until + +: luntil ( list quot -- result ) + ; + +M: lazy-until car ( lazy-until -- car ) + lazy-until-cons car ; + +M: lazy-until cdr ( lazy-until -- cdr ) + [ lazy-until-cons uncons ] keep lazy-until-quot + rot over call [ 2drop nil ] [ luntil ] if ; + +M: lazy-until nil? ( lazy-until -- bool ) + lazy-until-cons nil? ; + +M: lazy-until list? ( lazy-until -- bool ) + drop t ; + +TUPLE: lazy-while cons quot ; + +C: lazy-while + +: lwhile ( list quot -- result ) + +; + +M: lazy-while car ( lazy-while -- car ) + lazy-while-cons car ; + +M: lazy-while cdr ( lazy-while -- cdr ) + dup lazy-while-cons cdr dup nil? + [ 2drop nil ] [ swap lazy-while-quot lwhile ] if ; + +M: lazy-while nil? ( lazy-while -- bool ) + dup lazy-while-cons nil? + [ nip ] [ [ car ] keep lazy-while-quot call not ] if* ; + +M: lazy-while list? ( lazy-while -- bool ) + drop t ; + TUPLE: lazy-subset cons quot ; C: lazy-subset From 074ef1e1070f3eefac0bb0aae79a1f4846967217 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 21 Dec 2007 13:03:59 +0100 Subject: [PATCH 16/20] New math.erato library: sieve of Eratosthene --- extra/math/erato/authors.txt | 1 + extra/math/erato/erato-docs.factor | 14 ++++++++++++ extra/math/erato/erato-tests.factor | 6 +++++ extra/math/erato/erato.factor | 34 +++++++++++++++++++++++++++++ extra/math/erato/summary.txt | 1 + 5 files changed, 56 insertions(+) create mode 100644 extra/math/erato/authors.txt create mode 100644 extra/math/erato/erato-docs.factor create mode 100644 extra/math/erato/erato-tests.factor create mode 100644 extra/math/erato/erato.factor create mode 100644 extra/math/erato/summary.txt diff --git a/extra/math/erato/authors.txt b/extra/math/erato/authors.txt new file mode 100644 index 0000000000..f3b0233f74 --- /dev/null +++ b/extra/math/erato/authors.txt @@ -0,0 +1 @@ +Samuel Tardieu diff --git a/extra/math/erato/erato-docs.factor b/extra/math/erato/erato-docs.factor new file mode 100644 index 0000000000..e5dc82daf7 --- /dev/null +++ b/extra/math/erato/erato-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax ; +IN: math.erato + +HELP: +{ $values { "n" "a positive number" } { "erato" "a prime numbers generator" } } +{ $description "Build a prime numbers generator for primes between 2 and " { $snippet "n" } " (inclusive)." } ; + +HELP: next-prime +{ $values { "erato" "a generator" } { "prime/f" "a prime number or f" } } +{ $description "Compute the next prime number using the given generator. If there are no more prime numbers under the limit used when building the generator, f is returned instead." } ; + +HELP: lerato +{ $values { "n" "a positive number" } { "lazy-list" "a lazy prime numbers generator" } } +{ $description "Builds a lazy list containing the prime numbers between 2 and " { $snippet "n" } " (inclusive). Lazy lists are described in " { $link "lazy-lists" } "." } ; diff --git a/extra/math/erato/erato-tests.factor b/extra/math/erato/erato-tests.factor new file mode 100644 index 0000000000..6e961b979c --- /dev/null +++ b/extra/math/erato/erato-tests.factor @@ -0,0 +1,6 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: lazy-lists math.erato tools.test ; +IN: temporary + +[ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor new file mode 100644 index 0000000000..eb081f1938 --- /dev/null +++ b/extra/math/erato/erato.factor @@ -0,0 +1,34 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: bit-arrays kernel lazy-lists math math.functions math.ranges sequences ; +IN: math.erato + +TUPLE: erato limit bits latest ; + + ] keep + erato-bits [ set-nth ] curry f -rot curry* each + ] [ + 2drop + ] if ; + +PRIVATE> + +: ( n -- erato ) + dup 1 + 1 over set-bits erato construct-boa ; + +: next-prime ( erato -- prime/f ) + [ erato-latest 1+ ] keep [ set-erato-latest ] 2keep + 2dup erato-limit <= + [ + 2dup erato-bits nth [ dupd mark-multiples ] [ nip next-prime ] if + ] [ + 2drop f + ] if ; + +: lerato ( n -- lazy-list ) + [ next-prime ] keep [ nip next-prime ] curry lfrom-by [ ] lwhile ; diff --git a/extra/math/erato/summary.txt b/extra/math/erato/summary.txt new file mode 100644 index 0000000000..e8982fa3e0 --- /dev/null +++ b/extra/math/erato/summary.txt @@ -0,0 +1 @@ +Sieve of Eratosthene From 9809e573a983428136ea34af41f97cfe64669034 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 21 Dec 2007 13:05:45 +0100 Subject: [PATCH 17/20] Much faster solution to projet-euler.010 by using lazy lists --- extra/project-euler/010/010.factor | 38 +++++------------------------- 1 file changed, 6 insertions(+), 32 deletions(-) diff --git a/extra/project-euler/010/010.factor b/extra/project-euler/010/010.factor index ed08de902c..c032c5b684 100644 --- a/extra/project-euler/010/010.factor +++ b/extra/project-euler/010/010.factor @@ -1,6 +1,7 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.functions math.ranges namespaces sequences ; +USING: arrays kernel lazy-lists math math.erato math.functions math.ranges + namespaces sequences ; IN: project-euler.010 ! http://projecteuler.net/index.php?section=problems&id=10 @@ -16,42 +17,15 @@ IN: project-euler.010 ! SOLUTION ! -------- -! Sieve of Eratosthenes - - ; - -: multiples ( max n -- seq ) - dup sq -rot ; - -: remove-multiples ( n seq -- seq ) - dup supremum rot multiples swap seq-diff ; - -: keep-going? ( limit index seq -- ? ) - nth swap sqrt < ; - -: (primes-below) ( limit index seq -- seq ) - 3dup keep-going? [ - 2dup nth swap remove-multiples - >r 1+ r> (primes-below) - ] [ - 2nip - ] if ; - -PRIVATE> - -: primes-below ( n -- seq ) - [ candidates ] keep 0 rot (primes-below) 2 add* ; +! Sieve of Eratosthenes and lazy summing : euler010 ( -- answer ) - 1000000 primes-below sum ; + 0 1000000 lerato [ + ] leach ; ! TODO: solution is still too slow for 1000000, probably due to seq-diff ! calling member? for each number that we want to remove ! [ euler010 ] time -! ? ms run / ? ms GC time +! 2401 ms run / 10 ms GC time MAIN: euler010 From 8e87d56e24f7d951be873fe063e17a1b28e13a36 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Fri, 21 Dec 2007 17:43:26 +0100 Subject: [PATCH 18/20] Factor solution to project Euler problem 17 --- extra/project-euler/017/017.factor | 65 ++++++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) create mode 100644 extra/project-euler/017/017.factor diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor new file mode 100644 index 0000000000..7568872743 --- /dev/null +++ b/extra/project-euler/017/017.factor @@ -0,0 +1,65 @@ +! Copyright (c) 2007 Samuel Tardieu. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math namespaces sequences strings ; +IN: project-euler.017 + +! http://projecteuler.net/index.php?section=problems&id=17 + +! DESCRIPTION +! ----------- + +! If the numbers 1 to 5 are written out in words: one, two, three, four, five; +! there are 3 + 3 + 5 + 4 + 4 = 19 letters used in total. + +! If all the numbers from 1 to 1000 (one thousand) inclusive were written out +! in words, how many letters would be used? + +! NOTE: Do not count spaces or hyphens. For example, 342 (three hundred and +! forty-two) contains 23 letters and 115 (one hundred and fifteen) contains +! 20 letters. + +! SOLUTION +! -------- + + + +: >english ( n -- str ) + [ make-english ] "" make ; + +: euler017 ( -- answer ) + 1000 [ 1 + >english [ letter? ] subset length ] map sum ; + +! [ euler017 ] 100 ave-time +! 9 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler017 From fd8253c2626d4b9851da845895dc278d70a87be9 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 22 Dec 2007 00:28:46 +0100 Subject: [PATCH 19/20] Sieve of eratosthene optimizations --- extra/math/erato/erato-docs.factor | 8 ------- extra/math/erato/erato.factor | 34 +++++++++++++++++------------- 2 files changed, 19 insertions(+), 23 deletions(-) diff --git a/extra/math/erato/erato-docs.factor b/extra/math/erato/erato-docs.factor index e5dc82daf7..6e84c84057 100644 --- a/extra/math/erato/erato-docs.factor +++ b/extra/math/erato/erato-docs.factor @@ -1,14 +1,6 @@ USING: help.markup help.syntax ; IN: math.erato -HELP: -{ $values { "n" "a positive number" } { "erato" "a prime numbers generator" } } -{ $description "Build a prime numbers generator for primes between 2 and " { $snippet "n" } " (inclusive)." } ; - -HELP: next-prime -{ $values { "erato" "a generator" } { "prime/f" "a prime number or f" } } -{ $description "Compute the next prime number using the given generator. If there are no more prime numbers under the limit used when building the generator, f is returned instead." } ; - HELP: lerato { $values { "n" "a positive number" } { "lazy-list" "a lazy prime numbers generator" } } { $description "Builds a lazy list containing the prime numbers between 2 and " { $snippet "n" } " (inclusive). Lazy lists are described in " { $link "lazy-lists" } "." } ; diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index eb081f1938..4993f39e44 100644 --- a/extra/math/erato/erato.factor +++ b/extra/math/erato/erato.factor @@ -3,32 +3,36 @@ USING: bit-arrays kernel lazy-lists math math.functions math.ranges sequences ; IN: math.erato -TUPLE: erato limit bits latest ; - ] keep - erato-bits [ set-nth ] curry f -rot curry* each - ] [ - 2drop - ] if ; +TUPLE: erato limit bits latest ; -PRIVATE> +: ind ( n -- i ) + 2/ 1- ; inline + +: is-prime ( n erato -- bool ) + >r ind r> erato-bits nth ; inline + +: indices ( n erato -- range ) + erato-limit ind over 3 * ind swap rot ; + +: mark-multiples ( n erato -- ) + over sq over erato-limit <= + [ [ indices ] keep erato-bits [ f -rot set-nth ] curry each ] [ 2drop ] if ; : ( n -- erato ) - dup 1 + 1 over set-bits erato construct-boa ; + dup ind 1+ 1 over set-bits erato construct-boa ; : next-prime ( erato -- prime/f ) - [ erato-latest 1+ ] keep [ set-erato-latest ] 2keep + [ erato-latest 2 + ] keep [ set-erato-latest ] 2keep 2dup erato-limit <= [ - 2dup erato-bits nth [ dupd mark-multiples ] [ nip next-prime ] if + 2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if ] [ 2drop f ] if ; +PRIVATE> + : lerato ( n -- lazy-list ) - [ next-prime ] keep [ nip next-prime ] curry lfrom-by [ ] lwhile ; + 2 [ drop next-prime ] curry* lfrom-by [ ] lwhile ; From a66f7672dc93879b39ee13baf1626f7d91914576 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 22 Dec 2007 00:29:12 +0100 Subject: [PATCH 20/20] Update project-euler.010 timings --- extra/project-euler/010/010.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/010/010.factor b/extra/project-euler/010/010.factor index c032c5b684..7518eb2f6f 100644 --- a/extra/project-euler/010/010.factor +++ b/extra/project-euler/010/010.factor @@ -26,6 +26,6 @@ IN: project-euler.010 ! calling member? for each number that we want to remove ! [ euler010 ] time -! 2401 ms run / 10 ms GC time +! 765 ms run / 7 ms GC time MAIN: euler010