steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge git://www.rfc1149.net/factor 

Conflicts:

	extra/project-euler/project-euler.factor
db4
Aaron Schaefer 2008-01-06 10:55:46 -05:00
parent 03fa8a4887 4fa639a50b
commit 7636671b8c
19 changed files with 243 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/heaps/heaps.factor
View File

@ -6,7 +6,6 @@ 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 )
@ -107,7 +106,7 @@ M: priority-queue heap-push ( value key heap -- )
[ heap-data ] keep
up-heap ;
M: priority-queue heap-push-all ( assoc heap -- )
: heap-push-all ( assoc heap -- )
[ swapd heap-push ] curry assoc-each ;
M: priority-queue heap-peek ( heap -- value key )

7
core/io/files/files.factor
View File

@ -3,7 +3,7 @@
IN: io.files
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting ;
system combinators splitting sbufs ;
HOOK: <file-reader> io-backend ( path -- stream )
@ -157,3 +157,8 @@ HOOK: binary-roots io-backend ( -- seq )
PRIVATE>
: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;
: file-lines ( path -- seq ) <file-reader> lines ;
: file-contents ( path -- str )
dup <file-reader> swap file-length <sbuf> [ stream-copy ] keep >string ;

5
core/io/io.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces sequences strings
continuations assocs io.files io.styles sbufs ;
continuations assocs io.styles sbufs ;
IN: io
GENERIC: stream-close ( stream -- )
@ -90,6 +90,3 @@ SYMBOL: stdio
: contents ( stream -- str )
2048 <sbuf> [ stream-copy ] keep >string ;
: file-contents ( path -- str )
dup <file-reader> swap file-length <sbuf> [ stream-copy ] keep >string ;

9
extra/assoc-heaps/assoc-heaps-tests.factor
View File

@ -44,3 +44,12 @@ T{
T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } }
} heap-pop
] unit-test
[
T{
assoc-heap
f
H{ { 1 2 } { 3 4 } }
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } } } }
}
] [ H{ { 1 2 } { 3 4 } } H{ } clone <assoc-min-heap> [ heap-push-all ] keep ] unit-test

3
extra/assoc-heaps/assoc-heaps.factor
View File

@ -40,9 +40,6 @@ M: assoc-heap heap-peek ( assoc-heap -- value key )
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 ;

5
extra/combinators/lib/lib.factor
View File

@ -161,3 +161,8 @@ MACRO: map-call-with2 ( quots -- )
r> length [ narray ] curry append ;
MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ;
MACRO: construct-slots ( assoc tuple-class -- tuple )
[ construct-empty ] curry swap [
[ dip ] curry swap 1quotation [ keep ] curry compose
] { } assoc>map concat compose ;

12
extra/macros/macros.factor
View File

@ -2,18 +2,18 @@
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel sequences words effects inference.transforms
combinators assocs definitions quotations namespaces ;
combinators assocs definitions quotations namespaces memoize ;
IN: macros
: (:)
: (:) ( -- word definition effect-in )
CREATE dup reset-generic parse-definition
over "declared-effect" word-prop effect-in length ;
: (MACRO:)
>r
2dup "macro" set-word-prop
2dup [ call ] append define-compound
: (MACRO:) ( word definition effect-in -- )
>r 2dup "macro" set-word-prop
2dup over "declared-effect" word-prop memoize-quot
[ call ] append define-compound
r> define-transform ;
: MACRO:

6
extra/memoize/memoize.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel hashtables sequences arrays words namespaces
parser math assocs effects definitions ;
parser math assocs effects definitions quotations ;
IN: memoize
: packer ( n -- quot )
@ -46,3 +46,7 @@ PREDICATE: compound memoized "memoize" word-prop ;
M: memoized definer drop \ MEMO: \ ; ;
M: memoized definition "memo-quot" word-prop ;
: memoize-quot ( quot effect -- memo-quot )
gensym swap dupd "declared-effect" set-word-prop
dup rot define-memoized 1quotation ;

55
extra/project-euler/011/011.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces project-euler.common sequences ;
USING: kernel namespaces project-euler.common sequences splitting ;
IN: project-euler.011
! http://projecteuler.net/index.php?section=problems&id=11
@ -45,40 +45,40 @@ IN: project-euler.011
: horizontal ( -- matrix )
{
{ 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 }
} ;
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
} 20 group ;
: vertical ( -- matrix )
horizontal flip ;
: pad-front ( matrix -- matrix )
[
length [ 0 <repetition> ] each
] keep [ append ] map ;
length [ 0 <repetition> ] map
] keep [ append ] 2map ;
: pad-back ( matrix -- matrix )
<reversed> [
length [ 0 <repetition> ] each
] keep [ <reversed> append ] map ;
length [ 0 <repetition> ] map
] keep [ <reversed> append ] 2map ;
: diagonal/ ( -- matrix )
horizontal reverse pad-front pad-back flip ;
@ -98,9 +98,6 @@ PRIVATE>
[ 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

36
extra/project-euler/018/018.factor
View File

@ -51,24 +51,24 @@ IN: project-euler.018
<PRIVATE
: pyramid ( -- seq )
{
75
95 64
17 47 82
18 35 87 10
20 04 82 47 65
19 01 23 75 03 34
88 02 77 73 07 63 67
99 65 04 28 06 16 70 92
41 41 26 56 83 40 80 70 33
41 48 72 33 47 32 37 16 94 29
53 71 44 65 25 43 91 52 97 51 14
70 11 33 28 77 73 17 78 39 68 17 57
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
}
15 [ 1+ cut swap ] map nip ;
{
75
95 64
17 47 82
18 35 87 10
20 04 82 47 65
19 01 23 75 03 34
88 02 77 73 07 63 67
99 65 04 28 06 16 70 92
41 41 26 56 83 40 80 70 33
41 48 72 33 47 32 37 16 94 29
53 71 44 65 25 43 91 52 97 51 14
70 11 33 28 77 73 17 78 39 68 17 57
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
}
15 [ 1+ cut swap ] map nip ;
PRIVATE>

41
extra/project-euler/169/169.factor Normal file
View File

@ -0,0 +1,41 @@
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
IN: project-euler.169
USING: combinators kernel math math.functions memoize ;
! http://projecteuler.net/index.php?section=problems&id=169
! DESCRIPTION
! -----------
! Define f(0)=1 and f(n) to be the number of different ways n can be
! expressed as a sum of integer powers of 2 using each power no more
! than twice.
! For example, f(10)=5 since there are five different ways to express 10:
! 1 + 1 + 8
! 1 + 1 + 4 + 4
! 1 + 1 + 2 + 2 + 4
! 2 + 4 + 4
! 2 + 8
! What is f(1025)?
! SOLUTION
! --------
MEMO: fn ( n -- x )
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
{ [ t ] [ 2/ [ fn ] keep 1- fn + ] }
} cond ;
: euler169 ( -- result )
10 25 ^ fn ;
! [ euler169 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
MAIN: euler169

34
extra/project-euler/173/173.factor Normal file
View File

@ -0,0 +1,34 @@
! 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.173
! http://projecteuler.net/index.php?section=problems&id=173
! DESCRIPTION
! -----------
! We shall define a square lamina to be a square outline with a square
! "hole" so that the shape possesses vertical and horizontal
! symmetry. For example, using exactly thirty-two square tiles we can
! form two different square laminae: [see URL for figure]
! With one-hundred tiles, and not necessarily using all of the tiles at
! one time, it is possible to form forty-one different square laminae.
! Using up to one million tiles how many different square laminae can be
! formed?
! SOLUTION
! --------
: laminaes ( upper -- n )
4 / dup sqrt [1,b] 0 rot [ over /mod drop - - ] curry reduce ;
: euler173 ( -- answer )
1000000 laminaes ;
! [ euler173 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
MAIN: euler173

54
extra/project-euler/175/175.factor Normal file
View File

@ -0,0 +1,54 @@
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math math.parser math.ranges sequences vectors ;
IN: project-euler.175
! http://projecteuler.net/index.php?section=problems&id=175
! DESCRIPTION
! -----------
! Define f(0)=1 and f(n) to be the number of ways to write n as a sum of
! powers of 2 where no power occurs more than twice.
! For example, f(10)=5 since there are five different ways to express
! 10: 10 = 8+2 = 8+1+1 = 4+4+2 = 4+2+2+1+1 = 4+4+1+1
! It can be shown that for every fraction p/q (p0, q0) there exists at
! least one integer n such that f(n)/f(n-1)=p/q.
! For instance, the smallest n for which f(n)/f(n-1)=13/17 is 241. The
! binary expansion of 241 is 11110001. Reading this binary number from
! the most significant bit to the least significant bit there are 4
! one's, 3 zeroes and 1 one. We shall call the string 4,3,1 the
! Shortened Binary Expansion of 241.
! Find the Shortened Binary Expansion of the smallest n for which
! f(n)/f(n-1)=123456789/987654321.
! Give your answer as comma separated integers, without any whitespaces.
! SOLUTION
! --------
: add-bits ( vec n b -- )
over zero? [
3drop
] [
pick length 1 bitand = [ over pop + ] when swap push
] if ;
: compute ( vec ratio -- )
{
{ [ dup integer? ] [ 1- 0 add-bits ] }
{ [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
{ [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
} cond ;
: euler175 ( -- result )
V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ;
! [ euler175 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
MAIN: euler175

8
extra/project-euler/project-euler.factor
View File

@ -1,15 +1,15 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files kernel math.parser sequences vocabs
vocabs.loader project-euler.ave-time project-euler.common
vocabs.loader project-euler.ave-time project-euler.common math
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
project-euler.017 project-euler.018 project-euler.019 project-euler.020
project-euler.021 project-euler.022 project-euler.023 project-euler.024
project-euler.025
project-euler.067 project-euler.134 ;
project-euler.025 project-euler.067 project-euler.134 project-euler.169
project-euler.173 project-euler.175 ;
IN: project-euler
<PRIVATE
@ -33,7 +33,7 @@ PRIVATE>
: run-project-euler ( -- )
problem-prompt dup problem-solved? [
dup number>euler "project-euler." swap append run
"Answer: " swap number>string append print
"Answer: " swap dup number? [ number>string ] when append print
"Source: " swap solution-path append print
] [
drop "That problem has not been solved yet..." print

4
extra/rss/rss-tests.factor
View File

@ -10,7 +10,7 @@ USING: rss io kernel io.files tools.test ;
f
"Meerkat"
"http://meerkat.oreillynet.com"
V{
{
T{
entry
f
@ -26,7 +26,7 @@ USING: rss io kernel io.files tools.test ;
f
"dive into mark"
"http://example.org/"
V{
{
T{
entry
f

30
extra/rss/rss.factor
View File

@ -85,22 +85,26 @@ C: <entry> entry
] if ;
! Atom generation
: simple-tag, ( content name -- )
[ , ] tag, ;
: simple-tag*, ( content name attrs -- )
[ , ] tag*, ;
: entry, ( entry -- )
<< entry >> [
<< title >> [ dup entry-title , ]
<< link [ dup entry-link ] == href // >>
<< published >> [ dup entry-pub-date , ]
<< content >> [ entry-description , ]
] ;
"entry" [
dup entry-title "title" { { "type" "html" } } simple-tag*,
"link" over entry-link "href" associate contained*,
dup entry-pub-date "published" simple-tag,
entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
] tag, ;
: feed>xml ( feed -- xml )
<XML
<< feed [ "http://www.w3.org/2005/Atom" ] == xmlns >> [
<< title >> [ dup feed-title , ]
<< link [ dup feed-link ] == href // >>
feed-entries [ entry, ] each
]
XML> ;
"feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
dup feed-title "title" simple-tag,
"link" over feed-link "href" associate contained*,
feed-entries [ entry, ] each
] make-xml* ;
: write-feed ( feed -- )
feed>xml write-xml ;

7
extra/sequences/lib/lib-tests.factor
View File

@ -46,3 +46,10 @@ math.functions tools.test strings ;
[ { { 0 0 } { 1 0 } { 0 1 } { 1 1 } } ] [ 2 2 exact-strings ] unit-test
[ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test
[ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test
[ f ] [ { } ?first ] unit-test
[ f ] [ { } ?fourth ] unit-test
[ 1 ] [ { 1 2 3 } ?first ] unit-test
[ 2 ] [ { 1 2 3 } ?second ] unit-test
[ 3 ] [ { 1 2 3 } ?third ] unit-test
[ f ] [ { 1 2 3 } ?fourth ] unit-test

5
extra/sequences/lib/lib.factor
View File

@ -126,3 +126,8 @@ PRIVATE>
: human-sort ( seq -- newseq )
[ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc
sort-values keys ;
: ?first ( seq -- first/f ) 0 swap ?nth ; inline
: ?second ( seq -- second/f ) 1 swap ?nth ; inline
: ?third ( seq -- third/f ) 2 swap ?nth ; inline
: ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline

3
extra/trees/splay/authors.txt
View File

@ -1 +1,2 @@
Mackenzie Straight, Daniel Ehrenberg
Mackenzie Straight
Daniel Ehrenberg