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

Merge branch 'master' of git://factorcode.org/git/factor

db4
John Benediktsson 2009-04-05 19:36:53 -07:00
parent 1df6083785 75dd35179b
commit df174e29f5
40 changed files with 2724 additions and 218 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/binary-search/binary-search-docs.factor
View File

@ -14,7 +14,7 @@ $nl
HELP: sorted-index
{ $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } }
{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
{ $description "Outputs the index of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
{ index index-from last-index last-index-from sorted-index } related-words

4
basis/concurrency/conditions/conditions.factor
View File

@ -20,10 +20,12 @@ IN: concurrency.conditions
]
] dip later ;
ERROR: wait-timeout ;
: wait ( queue timeout status -- )
over [
[ queue-timeout [ drop ] ] dip suspend
[ "Timeout" throw ] [ cancel-alarm ] if
[ wait-timeout ] [ cancel-alarm ] if
] [
[ drop '[ _ push-front ] ] dip suspend drop
] if ;

16
basis/concurrency/mailboxes/mailboxes-tests.factor
View File

@ -1,6 +1,6 @@
IN: concurrency.mailboxes.tests
USING: concurrency.mailboxes concurrency.count-downs vectors
sequences threads tools.test math kernel strings namespaces
USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions
vectors sequences threads tools.test math kernel strings namespaces
continuations calendar destructors ;
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as
@ -75,3 +75,15 @@ continuations calendar destructors ;
[ ] [ "d" get 5 seconds await-timeout ] unit-test
[ ] [ "m" get dispose ] unit-test
[ { "foo" "bar" } ] [
<mailbox>
"foo" over mailbox-put
"bar" over mailbox-put
mailbox-get-all
] unit-test
[
<mailbox> 1 seconds mailbox-get-timeout
] [ wait-timeout? ] must-fail-with

2
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -49,7 +49,7 @@ M: mailbox dispose* threads>> notify-all ;
: mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty
[ dup mailbox-empty? ]
[ dup mailbox-empty? not ]
[ dup data>> pop-back ]
produce nip ;

0
basis/core-graphics/core-graphics-docs.factor
View File

4
basis/opengl/opengl-docs.factor
View File

@ -15,8 +15,8 @@ HELP: do-enabled
{ $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ;
HELP: do-matrix
{ $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } }
{ $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ;
{ $values { "quot" quotation } }
{ $description "Saves and restores the current matrix before and after calling the quotation." } ;
HELP: gl-line
{ $values { "a" "a pair of integers" } { "b" "a pair of integers" } }

8
basis/opengl/opengl.factor
View File

@ -44,9 +44,8 @@ MACRO: all-enabled ( seq quot -- )
MACRO: all-enabled-client-state ( seq quot -- )
[ words>values ] dip '[ _ _ (all-enabled-client-state) ] ;
: do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep
glMatrixMode glPopMatrix ; inline
: do-matrix ( quot -- )
glPushMatrix call glPopMatrix ; inline
: gl-material ( face pname params -- )
float-array{ } like glMaterialfv ;
@ -165,7 +164,7 @@ MACRO: set-draw-buffers ( buffers -- )
: delete-dlist ( id -- ) 1 glDeleteLists ;
: with-translation ( loc quot -- )
GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline
[ [ gl-translate ] dip call ] do-matrix ; inline
: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
[ first2 [ >fixnum ] bi@ ] bi@ ;
@ -177,6 +176,7 @@ MACRO: set-draw-buffers ( buffers -- )
fix-coordinates glViewport ;
: init-matrices ( -- )
#! Leaves with matrix mode GL_MODELVIEW
GL_PROJECTION glMatrixMode
glLoadIdentity
GL_MODELVIEW glMatrixMode

50
basis/opengl/textures/textures-tests.factor
View File

@ -5,56 +5,6 @@ opengl.textures.private images kernel namespaces accessors
sequences ;
IN: opengl.textures.tests
[ ] [
T{ image
{ dim { 3 5 } }
{ component-order RGB }
{ bitmap
B{
1 2 3 4 5 6 7 8 9
10 11 12 13 14 15 16 17 18
19 20 21 22 23 24 25 26 27
28 29 30 31 32 33 34 35 36
37 38 39 40 41 42 43 44 45
}
}
} "image" set
] unit-test
[
T{ image
{ dim { 4 8 } }
{ component-order RGB }
{ bitmap
B{
1 2 3 4 5 6 7 8 9 7 8 9
10 11 12 13 14 15 16 17 18 16 17 18
19 20 21 22 23 24 25 26 27 25 26 27
28 29 30 31 32 33 34 35 36 34 35 36
37 38 39 40 41 42 43 44 45 43 44 45
37 38 39 40 41 42 43 44 45 43 44 45
37 38 39 40 41 42 43 44 45 43 44 45
37 38 39 40 41 42 43 44 45 43 44 45
}
}
}
] [
"image" get power-of-2-image
] unit-test
[
T{ image
{ dim { 0 0 } }
{ component-order R32G32B32 }
{ bitmap B{ } } }
] [
T{ image
{ dim { 0 0 } }
{ component-order R32G32B32 }
{ bitmap B{ } }
} power-of-2-image
] unit-test
[
{
{ { 0 0 } { 10 0 } }

95
basis/opengl/textures/textures.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs cache colors.constants destructors fry kernel
opengl opengl.gl combinators images images.tesselation grouping
specialized-arrays.float locals sequences math math.vectors
math.matrices generalizations fry columns arrays ;
specialized-arrays.float sequences math math.vectors
math.matrices generalizations fry arrays ;
IN: opengl.textures
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
@ -19,59 +19,40 @@ M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
GENERIC: draw-texture ( texture -- )
SLOT: display-list
: draw-texture ( texture -- ) display-list>> [ glCallList ] when* ;
GENERIC: draw-scaled-texture ( dim texture -- )
<PRIVATE
TUPLE: single-texture image loc dim texture-coords texture display-list disposed ;
TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
: repeat-last ( seq n -- seq' )
over peek pad-tail concat ;
: (tex-image) ( image -- )
[ GL_TEXTURE_2D 0 GL_RGBA ] dip
[ dim>> first2 [ next-power-of-2 ] bi@ 0 ]
[ component-order>> component-order>format f ] bi
glTexImage2D ;
: power-of-2-bitmap ( rows dim size -- bitmap dim )
'[
first2
[ [ _ ] dip '[ _ group _ repeat-last ] map ]
[ repeat-last ]
bi*
] keep ;
: (tex-sub-image) ( image -- )
[ GL_TEXTURE_2D 0 0 0 ] dip
[ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
glTexSubImage2D ;
: image-rows ( image -- rows )
[ bitmap>> ]
[ dim>> first ]
[ component-order>> bytes-per-pixel ]
tri * group ; inline
: power-of-2-image ( image -- image )
dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [
clone dup
[ image-rows ]
[ dim>> [ next-power-of-2 ] map ]
[ component-order>> bytes-per-pixel ] tri
power-of-2-bitmap
[ >>bitmap ] [ >>dim ] bi*
] unless ;
:: make-texture ( image -- id )
: make-texture ( image -- id )
#! We use glTexSubImage2D to work around the power of 2 texture size
#! limitation
gen-texture [
GL_TEXTURE_BIT [
GL_TEXTURE_2D swap glBindTexture
GL_TEXTURE_2D
0
GL_RGBA
image dim>> first2
0
image component-order>> component-order>format
image bitmap>>
glTexImage2D
[ (tex-image) ] [ (tex-sub-image) ] bi
] do-attribs
] keep ;
: init-texture ( -- )
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
@ -100,20 +81,19 @@ TUPLE: single-texture image loc dim texture-coords texture display-list disposed
] with-texturing ;
: texture-coords ( texture -- coords )
[ [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ ]
[
[ dim>> ] [ image>> dim>> ] bi v/
{ { 0 0 } { 1 0 } { 1 1 } { 0 1 } }
[ v* ] with map
] keep
image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when
float-array{ } join ;
image>> upside-down?>>
{ { 0 1 } { 1 1 } { 1 0 } { 0 0 } }
{ { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ?
] bi
[ v* ] with map float-array{ } join ;
: make-texture-display-list ( texture -- dlist )
GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
: <single-texture> ( image loc dim -- texture )
[ power-of-2-image ] 2dip
single-texture new swap >>dim swap >>loc swap >>image
: <single-texture> ( image loc -- texture )
single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi
dup image>> dim>> product 0 = [
dup texture-coords >>texture-coords
dup image>> make-texture >>texture
@ -124,21 +104,19 @@ M: single-texture dispose*
[ texture>> [ delete-texture ] when* ]
[ display-list>> [ delete-dlist ] when* ] bi ;
M: single-texture draw-texture display-list>> [ glCallList ] when* ;
M: single-texture draw-scaled-texture
dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
TUPLE: multi-texture grid display-list loc disposed ;
: image-locs ( image-grid -- loc-grid )
[ first [ dim>> first ] map ] [ 0 <column> [ dim>> second ] map ] bi
[ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi
[ 0 [ + ] accumulate nip ] bi@
cross-zip flip ;
: <texture-grid> ( image-grid loc -- grid )
[ dup image-locs ] dip
'[ [ _ v+ over dim>> <single-texture> |dispose ] 2map ] 2map ;
'[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
: draw-textured-grid ( grid -- )
[ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
@ -165,18 +143,13 @@ TUPLE: multi-texture grid display-list loc disposed ;
f multi-texture boa
] with-destructors ;
M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
CONSTANT: max-texture-size { 512 512 }
PRIVATE>
: small-texture? ( dim -- ? )
max-texture-size [ <= ] 2all? ;
: <texture> ( image loc dim -- texture )
pick dim>> small-texture?
: <texture> ( image loc -- texture )
over dim>> max-texture-size [ <= ] 2all?
[ <single-texture> ]
[ drop [ max-texture-size tesselate ] dip <multi-texture> ] if ;
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;

2
basis/sorting/human/human-tests.factor
View File

@ -1,6 +1,4 @@
USING: sorting.human tools.test sorting.slots ;
IN: sorting.human.tests
\ human-sort must-infer
[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test

14
basis/sorting/slots/slots.factor
View File

@ -8,7 +8,7 @@ IN: sorting.slots
<PRIVATE
: short-circuit-comparator ( obj1 obj2 word -- comparator/? )
execute dup +eq+ eq? [ drop f ] when ;
execute dup +eq+ eq? [ drop f ] when ; inline
: slot-comparator ( seq -- quot )
[
@ -25,19 +25,19 @@ MACRO: compare-slots ( sort-specs -- <=> )
#! sort-spec: { accessors comparator }
[ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
: sort-by-slots ( seq sort-specs -- sortedseq )
'[ _ compare-slots ] sort ;
MACRO: sort-by-slots ( sort-specs -- quot )
'[ [ _ compare-slots ] sort ] ;
MACRO: compare-seq ( seq -- quot )
[ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
: sort-by ( seq sort-seq -- sortedseq )
'[ _ compare-seq ] sort ;
MACRO: sort-by ( sort-seq -- quot )
'[ [ _ compare-seq ] sort ] ;
: sort-keys-by ( seq sort-seq -- sortedseq )
MACRO: sort-keys-by ( sort-seq -- quot )
'[ [ first ] bi@ _ compare-seq ] sort ;
: sort-values-by ( seq sort-seq -- sortedseq )
MACRO: sort-values-by ( sort-seq -- quot )
'[ [ second ] bi@ _ compare-seq ] sort ;
MACRO: split-by-slots ( accessor-seqs -- quot )

2
basis/ui/backend/backend.factor
View File

@ -29,6 +29,6 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h )
: with-gl-context ( handle quot -- )
swap [ select-gl-context call ] keep
glFlush flush-gl-context gl-error ; inline
flush-gl-context gl-error ; inline
HOOK: (with-ui) ui-backend ( quot -- )

2
basis/ui/images/images.factor
View File

@ -20,7 +20,7 @@ PRIVATE>
: rendered-image ( path -- texture )
world get image-texture-cache
[ cached-image [ { 0 0 } ] keep dim>> <texture> ] cache ;
[ cached-image { 0 0 } <texture> ] cache ;
: draw-image ( image-name -- )
rendered-image draw-texture ;

4
basis/ui/text/core-text/core-text.factor
View File

@ -20,9 +20,7 @@ M: core-text-renderer flush-layout-cache
: rendered-line ( font string -- texture )
world get world-text-handle [
cached-line
[ image>> ] [ loc>> ] [ image>> dim>> ] tri
<texture>
cached-line [ image>> ] [ loc>> ] bi <texture>
] 2cache ;
M: core-text-renderer draw-string ( font string -- )

4
basis/ui/text/pango/pango.factor
View File

@ -16,9 +16,7 @@ M: pango-renderer flush-layout-cache
: rendered-layout ( font string -- texture )
world get world-text-handle [
cached-layout
[ image>> ] [ text-position vneg ] [ image>> dim>> ] tri
<texture>
cached-layout [ image>> ] [ text-position vneg ] bi <texture>
] 2cache ;
M: pango-renderer draw-string ( font string -- )

2
basis/ui/text/text.factor
View File

@ -66,7 +66,7 @@ M: string draw-text draw-string ;
M: selection draw-text draw-string ;
M: array draw-text
GL_MODELVIEW [
[
[
[ draw-string ]
[ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi

2
basis/ui/text/uniscribe/uniscribe.factor
View File

@ -16,7 +16,7 @@ M: uniscribe-renderer flush-layout-cache
: rendered-script-string ( font string -- texture )
world get world-text-handle
[ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi <texture> ]
[ cached-script-string image>> { 0 0 } <texture> ]
2cache ;
M: uniscribe-renderer draw-string ( font string -- )

5
basis/windows/uniscribe/uniscribe.factor
View File

@ -71,11 +71,8 @@ TUPLE: script-string font string metrics ssa size image disposed ;
: draw-script-string ( dc script-string -- )
[ font>> set-dc-colors ] keep (draw-script-string) ;
: script-string-bitmap-size ( script-string -- dim )
size>> dup small-texture? [ [ next-power-of-2 ] map ] when ;
:: make-script-string-image ( dc script-string -- image )
script-string script-string-bitmap-size dc
script-string size>> dc
[ dc script-string draw-script-string ] make-bitmap-image ;
: set-dc-font ( dc font -- )

0
build-support/dlls.txt
View File

4
core/alien/alien-tests.factor
View File

@ -1,6 +1,6 @@
USING: accessors alien alien.accessors alien.syntax byte-arrays arrays
kernel kernel.private namespaces tools.test sequences libc math
system prettyprint layouts alien.libraries ;
system prettyprint layouts alien.libraries sets ;
IN: alien.tests
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
@ -86,3 +86,5 @@ f initialize-test set-global
[ ] [ initialize-test get BAD-ALIEN >>alien drop ] unit-test
[ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test
[ V{ BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test

2
core/alien/alien.factor
View File

@ -49,6 +49,8 @@ M: alien equal?
2drop f
] if ;
M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )

2
core/sequences/sequences-docs.factor
View File

@ -311,7 +311,7 @@ HELP: each-index
HELP: map-index
{ $values
{ "seq" sequence } { "quot" quotation } }
{ "seq" sequence } { "quot" quotation } { "newseq" sequence } }
{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." }
{ $examples { $example "USING: sequences prettyprint math ;"
"{ 10 20 30 } [ + ] map-index ."

2
core/sequences/sequences.factor
View File

@ -506,7 +506,7 @@ PRIVATE>
[ [ 0 = ] 2dip if ] 2curry
each-index ; inline
: map-index ( seq quot -- )
: map-index ( seq quot -- newseq )
prepare-index 2map ; inline
: reduce-index ( seq identity quot -- )

6
extra/color-table/color-table.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators.smart sorting.human
models colors.constants present
models colors.constants present sorting.slots
ui ui.gadgets.tables ui.gadgets.scrollers ;
IN: color-table
@ -29,7 +29,7 @@ M: color-renderer row-value
drop named-color ;
: <color-table> ( -- table )
named-colors human-sort <model>
named-colors { human<=> } sort-by <model>
color-renderer
<table>
5 >>gap
@ -40,4 +40,4 @@ M: color-renderer row-value
: color-table-demo ( -- )
[ <color-table> <scroller> "Colors" open-window ] with-ui ;
MAIN: color-table-demo
MAIN: color-table-demo

12
extra/mason/test/test.factor
View File

@ -4,7 +4,7 @@ USING: accessors assocs benchmark bootstrap.stage2
compiler.errors generic help.html help.lint io.directories
io.encodings.utf8 io.files kernel mason.common math namespaces
prettyprint sequences sets sorting tools.test tools.time
tools.vocabs words ;
tools.vocabs words system io ;
IN: mason.test
: do-load ( -- )
@ -44,9 +44,19 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ;
: benchmark-ms ( quot -- ms )
benchmark 1000 /i ; inline
: check-boot-image ( -- )
"" to-refresh drop 2dup [ empty? not ] either?
[
"Boot image is out of date. Changed vocabs:" print
append prune [ print ] each
flush
1 exit
] [ 2drop ] if ;
: do-all ( -- )
".." [
bootstrap-time get boot-time-file to-file
check-boot-image
[ do-load do-compile-errors ] benchmark-ms load-time-file to-file
[ generate-help ] benchmark-ms html-help-time-file to-file
[ do-tests ] benchmark-ms test-time-file to-file

1261
extra/poker/arrays/arrays.factor Normal file
View File

File diff suppressed because it is too large Load Diff

1
extra/poker/authors.txt Normal file
View File

@ -0,0 +1 @@
Aaron Schaefer

16
extra/poker/poker-tests.factor Normal file
View File

@ -0,0 +1,16 @@
USING: accessors poker poker.private tools.test ;
IN: poker.tests
[ 134236965 ] [ "KD" >ckf ] unit-test
[ 529159 ] [ "5s" >ckf ] unit-test
[ 33589533 ] [ "jc" >ckf ] unit-test
[ 7462 ] [ "7C 5D 4H 3S 2C" <hand> value>> ] unit-test
[ 1601 ] [ "KD QS JC TH 9S" <hand> value>> ] unit-test
[ 9 ] [ "6C 5C 4C 3C 2C" <hand> value>> ] unit-test
[ 1 ] [ "AC KC QC JC TC" <hand> value>> ] unit-test
[ "High Card" ] [ "7C 5D 4H 3S 2C" <hand> >value ] unit-test
[ "Straight" ] [ "KD QS JC TH 9S" <hand> >value ] unit-test
[ "Straight Flush" ] [ "6C 5C 4C 3C 2C" <hand> >value ] unit-test

181
extra/poker/poker.factor Normal file
View File

@ -0,0 +1,181 @@
! Copyright (c) 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii binary-search combinators kernel locals math
math.bitwise math.order poker.arrays sequences splitting ;
IN: poker
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator:
! http://www.suffecool.net/poker/evaluator.html
<PRIVATE
! Bitfield Format for Card Values:
! +-------------------------------------+
! | xxxbbbbb bbbbbbbb ssssrrrr xxpppppp |
! +-------------------------------------+
! xxxAKQJT 98765432 CDHSrrrr xxpppppp
! +-------------------------------------+
! | 00001000 00000000 01001011 00100101 | King of Diamonds
! | 00000000 00001000 00010011 00000111 | Five of Spades
! | 00000010 00000000 10001001 00011101 | Jack of Clubs
! p = prime number value of rank (deuce = 2, trey = 3, four = 5, ..., ace = 41)
! r = rank of card (deuce = 0, trey = 1, four = 2, ..., ace = 12)
! s = bit turned on depending on suit of card
! b = bit turned on depending on rank of card
! x = bit turned off, not used
CONSTANT: CLUB 8
CONSTANT: DIAMOND 4
CONSTANT: HEART 2
CONSTANT: SPADE 1
CONSTANT: DEUCE 0
CONSTANT: TREY 1
CONSTANT: FOUR 2
CONSTANT: FIVE 3
CONSTANT: SIX 4
CONSTANT: SEVEN 5
CONSTANT: EIGHT 6
CONSTANT: NINE 7
CONSTANT: TEN 8
CONSTANT: JACK 9
CONSTANT: QUEEN 10
CONSTANT: KING 11
CONSTANT: ACE 12
CONSTANT: STRAIGHT_FLUSH 1
CONSTANT: FOUR_OF_A_KIND 2
CONSTANT: FULL_HOUSE 3
CONSTANT: FLUSH 4
CONSTANT: STRAIGHT 5
CONSTANT: THREE_OF_A_KIND 6
CONSTANT: TWO_PAIR 7
CONSTANT: ONE_PAIR 8
CONSTANT: HIGH_CARD 9
CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
"Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" }
: card-rank-prime ( rank -- n )
RANK_STR index { 2 3 5 7 11 13 17 19 23 29 31 37 41 } nth ;
: card-rank ( rank -- n )
{
{ "2" [ DEUCE ] }
{ "3" [ TREY ] }
{ "4" [ FOUR ] }
{ "5" [ FIVE ] }
{ "6" [ SIX ] }
{ "7" [ SEVEN ] }
{ "8" [ EIGHT ] }
{ "9" [ NINE ] }
{ "T" [ TEN ] }
{ "J" [ JACK ] }
{ "Q" [ QUEEN ] }
{ "K" [ KING ] }
{ "A" [ ACE ] }
} case ;
: card-suit ( suit -- n )
{
{ "C" [ CLUB ] }
{ "D" [ DIAMOND ] }
{ "H" [ HEART ] }
{ "S" [ SPADE ] }
} case ;
: card-rank-bit ( rank -- n )
RANK_STR index 1 swap shift ;
: card-bitfield ( rank rank suit rank -- n )
{
{ card-rank-bit 16 }
{ card-suit 12 }
{ card-rank 8 }
{ card-rank-prime 0 }
} bitfield ;
:: (>ckf) ( rank suit -- n )
rank rank suit rank card-bitfield ;
: >ckf ( str -- n )
#! Cactus Kev Format
>upper 1 cut (>ckf) ;
: flush? ( cards -- ? )
HEX: F000 [ bitand ] reduce 0 = not ;
: rank-bits ( cards -- q )
0 [ bitor ] reduce -16 shift ;
: lookup ( cards table -- value )
[ rank-bits ] dip nth ;
: unique5? ( cards -- ? )
unique5-table lookup 0 > ;
: map-product ( seq quot -- n )
[ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
: prime-bits ( cards -- q )
[ HEX: FF bitand ] map-product ;
: hand-value ( cards -- value )
{
{ [ dup flush? ] [ flushes-table lookup ] }
{ [ dup unique5? ] [ unique5-table lookup ] }
[
prime-bits products-table sorted-index
values-table nth
]
} cond ;
: >card-rank ( card -- str )
-8 shift HEX: F bitand RANK_STR nth ;
: >card-suit ( card -- str )
{
{ [ dup 15 bit? ] [ drop "C" ] }
{ [ dup 14 bit? ] [ drop "D" ] }
{ [ dup 13 bit? ] [ drop "H" ] }
[ drop "S" ]
} cond ;
PRIVATE>
TUPLE: hand
{ cards sequence }
{ value integer } ;
M: hand <=> [ value>> ] compare ;
M: hand equal?
over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
: <hand> ( str -- hand )
" " split [ >ckf ] map
dup hand-value hand boa ;
: hand-rank ( hand -- rank )
value>> {
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
{ [ dup 1609 > ] [ drop THREE_OF_A_KIND ] } ! 858 three-kind
{ [ dup 1599 > ] [ drop STRAIGHT ] } ! 10 straights
{ [ dup 322 > ] [ drop FLUSH ] } ! 1277 flushes
{ [ dup 166 > ] [ drop FULL_HOUSE ] } ! 156 full house
{ [ dup 10 > ] [ drop FOUR_OF_A_KIND ] } ! 156 four-kind
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
} cond ;
: >value ( hand -- str )
hand-rank VALUE_STR nth ;
: >cards ( hand -- str )
cards>> [
[ >card-rank ] [ >card-suit ] bi append
] map " " join ;

1
extra/poker/summary.txt Normal file
View File

@ -0,0 +1 @@
5-card poker hand evaluator

4
extra/project-euler/054/054-tests.factor Normal file
View File

@ -0,0 +1,4 @@
USING: project-euler.054 tools.test ;
IN: project-euler.054.tests
[ 376 ] [ euler054 ] unit-test

87
extra/project-euler/054/054.factor Normal file
View File

@ -0,0 +1,87 @@
! Copyright (c) 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io.encodings.ascii io.files kernel math.order poker
project-euler.common sequences ;
IN: project-euler.054
! http://projecteuler.net/index.php?section=problems&id=54
! DESCRIPTION
! -----------
! In the card game poker, a hand consists of five cards and are ranked, from
! lowest to highest, in the following way:
! * High Card: Highest value card.
! * One Pair: Two cards of the same value.
! * Two Pairs: Two different pairs.
! * Three of a Kind: Three cards of the same value.
! * Straight: All cards are consecutive values.
! * Flush: All cards of the same suit.
! * Full House: Three of a kind and a pair.
! * Four of a Kind: Four cards of the same value.
! * Straight Flush: All cards are consecutive values of same suit.
! * Royal Flush: Ten, Jack, Queen, King, Ace, in same suit.
! The cards are valued in the order:
! 2, 3, 4, 5, 6, 7, 8, 9, 10, Jack, Queen, King, Ace.
! If two players have the same ranked hands then the rank made up of the
! highest value wins; for example, a pair of eights beats a pair of fives (see
! example 1 below). But if two ranks tie, for example, both players have a pair
! of queens, then highest cards in each hand are compared (see example 4
! below); if the highest cards tie then the next highest cards are compared,
! and so on.
! Consider the following five hands dealt to two players:
! Hand Player 1 Player 2 Winner
! ---------------------------------------------------------
! 1 5H 5C 6S 7S KD 2C 3S 8S 8D TD
! Pair of Fives Pair of Eights Player 2
! 2 5D 8C 9S JS AC 2C 5C 7D 8S QH
! Highest card Ace Highest card Queen Player 1
! 3 2D 9C AS AH AC 3D 6D 7D TD QD
! Three Aces Flush with Diamonds Player 2
! 4 4D 6S 9H QH QC 3D 6D 7H QD QS
! Pair of Queens Pair of Queens
! Highest card Nine Highest card Seven Player 1
! 5 2H 2D 4C 4D 4S 3C 3D 3S 9S 9D
! Full House Full House
! With Three Fours With Three Threes Player 1
! The file, poker.txt, contains one-thousand random hands dealt to two players.
! Each line of the file contains ten cards (separated by a single space): the
! first five are Player 1's cards and the last five are Player 2's cards. You
! can assume that all hands are valid (no invalid characters or repeated
! cards), each player's hand is in no specific order, and in each hand there is
! a clear winner.
! How many hands does Player 1 win?
! SOLUTION
! --------
<PRIVATE
: source-054 ( -- seq )
"resource:extra/project-euler/054/poker.txt" ascii file-lines
[ [ 14 head-slice ] [ 14 tail-slice* ] bi 2array ] map ;
: player1-win? ( hand1 hand2 -- ? )
before? ; inline
PRIVATE>
: euler054 ( -- answer )
source-054 [ [ <hand> ] map first2 player1-win? ] count ;
! [ euler054 ] 100 ave-time
! 36 ms ave run time - 2.71 SD (100 trials)
SOLUTION: euler054

1000
extra/project-euler/054/poker.txt Normal file
View File

File diff suppressed because it is too large Load Diff

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

@ -1,4 +1,4 @@
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
! Copyright (c) 2007, 2008, 2009 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files io.pathnames kernel math math.parser
prettyprint project-euler.ave-time sequences vocabs vocabs.loader
@ -14,14 +14,14 @@ USING: definitions io io.files io.pathnames kernel math math.parser
project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.047 project-euler.048
project-euler.049 project-euler.052 project-euler.053 project-euler.055
project-euler.056 project-euler.057 project-euler.059 project-euler.067
project-euler.071 project-euler.073 project-euler.075 project-euler.076
project-euler.079 project-euler.092 project-euler.097 project-euler.099
project-euler.100 project-euler.116 project-euler.117 project-euler.134
project-euler.148 project-euler.150 project-euler.151 project-euler.164
project-euler.169 project-euler.173 project-euler.175 project-euler.186
project-euler.190 project-euler.203 project-euler.215 ;
project-euler.049 project-euler.052 project-euler.053 project-euler.054
project-euler.055 project-euler.056 project-euler.057 project-euler.059
project-euler.067 project-euler.071 project-euler.073 project-euler.075
project-euler.076 project-euler.079 project-euler.092 project-euler.097
project-euler.099 project-euler.100 project-euler.116 project-euler.117
project-euler.134 project-euler.148 project-euler.150 project-euler.151
project-euler.164 project-euler.169 project-euler.173 project-euler.175
project-euler.186 project-euler.190 project-euler.203 project-euler.215 ;
IN: project-euler
<PRIVATE

2
extra/spider/report/report.factor
View File

@ -14,7 +14,7 @@ SYMBOL: timings
broken-pages push ;
: record-page-timings ( url spider-result -- )
fetch-time>> 2array timings get push ;
fetched-in>> 2array timings get push ;
: record-network-failure ( url -- )
network-failures get push ;

36
extra/spider/spider.factor
View File

@ -4,43 +4,17 @@ USING: accessors fry html.parser html.parser.analyzer
http.client kernel tools.time sets assocs sequences
concurrency.combinators io threads namespaces math multiline
math.parser inspector urls logging combinators.short-circuit
continuations calendar prettyprint dlists deques locals ;
continuations calendar prettyprint dlists deques locals
spider.unique-deque ;
IN: spider
TUPLE: spider base count max-count sleep max-depth initial-links
filters spidered todo nonmatching quiet currently-spidering
#threads follow-robots ;
#threads follow-robots? robots ;
TUPLE: spider-result url depth headers
fetched-in parsed-html links processed-in fetched-at ;
TUPLE: todo-url url depth ;
: <todo-url> ( url depth -- todo-url )
todo-url new
swap >>depth
swap >>url ;
TUPLE: unique-deque assoc deque ;
: <unique-deque> ( -- unique-deque )
H{ } clone <dlist> unique-deque boa ;
: url-exists? ( url unique-deque -- ? )
[ url>> ] [ assoc>> ] bi* key? ;
: push-url ( url depth unique-deque -- )
[ <todo-url> ] dip 2dup url-exists? [
2drop
] [
[ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
[ deque>> push-back ] 2bi
] if ;
: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
: <spider> ( base -- spider )
>url
spider new
@ -89,13 +63,13 @@ TUPLE: unique-deque assoc deque ;
:: new-spidered-result ( spider url depth -- spider-result )
f url spider spidered>> set-at
[ url http-get ] benchmark :> fetch-time :> html :> headers
[ url http-get ] benchmark :> fetched-at :> html :> headers
[
html parse-html
spider currently-spidering>>
over find-all-links normalize-hrefs
] benchmark :> processing-time :> links :> parsed-html
url depth headers fetch-time parsed-html links processing-time
url depth headers fetched-at parsed-html links processing-time
now spider-result boa ;
:: spider-page ( spider url depth -- )

1
extra/spider/unique-deque/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

31
extra/spider/unique-deque/unique-deque.factor Normal file
View File

@ -0,0 +1,31 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs deques dlists kernel spider ;
IN: spider.unique-deque
TUPLE: todo-url url depth ;
: <todo-url> ( url depth -- todo-url )
todo-url new
swap >>depth
swap >>url ;
TUPLE: unique-deque assoc deque ;
: <unique-deque> ( -- unique-deque )
H{ } clone <dlist> unique-deque boa ;
: url-exists? ( url unique-deque -- ? )
[ url>> ] [ assoc>> ] bi* key? ;
: push-url ( url depth unique-deque -- )
[ <todo-url> ] dip 2dup url-exists? [
2drop
] [
[ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
[ deque>> push-back ] 2bi
] if ;
: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;

2
extra/tetris/gl/gl.factor
View File

@ -37,7 +37,7 @@ IN: tetris.gl
: draw-tetris ( width height tetris -- )
#! width and height are in pixels
GL_MODELVIEW [
[
{
[ board>> scale-board ]
[ board>> draw-board ]

55
misc/fuel/fuel-refactor.el
View File

@ -36,7 +36,7 @@
(let ((name (match-string-no-properties 2))
(body (match-string-no-properties 4))
(end (match-end 0)))
(list (split-string body nil t) name pos end)))))
(list (split-string (or body "") nil t) name pos end)))))
(defun fuel-refactor--find (code to)
(let ((candidate) (result))
@ -88,7 +88,7 @@
(defun fuel-refactor--insert-word (word stack-effect code)
(let ((start (goto-char (fuel-refactor--insertion-point))))
(open-line 1)
(insert ": " word " " stack-effect "\n" code " ;\n")
(insert ": " word " " stack-effect "\n" (or code " ") " ;\n")
(indent-region start (point))
(move-overlay fuel-stack--overlay start (point))))
@ -103,39 +103,46 @@
(delete-overlay fuel-stack--overlay)))
(defun fuel-refactor--extract (begin end)
(unless (< begin end) (error "No proper region to extract"))
(let* ((code (buffer-substring begin end))
(existing (fuel-refactor--reuse-existing code))
(code-str (or existing (fuel--region-to-string begin end)))
(let* ((rp (< begin end))
(code (and rp (buffer-substring begin end)))
(existing (and code (fuel-refactor--reuse-existing code)))
(code-str (and code (or existing (fuel--region-to-string begin end))))
(word (or (car existing) (read-string "New word name: ")))
(stack-effect (or existing
(fuel-stack--infer-effect code-str)
(and code-str (fuel-stack--infer-effect code-str))
(read-string "Stack effect: "))))
(goto-char begin)
(delete-region begin end)
(insert word)
(indent-region begin (point))
(when rp
(goto-char begin)
(delete-region begin end)
(insert word)
(indent-region begin (point)))
(save-excursion
(let ((start (or (cadr existing) (point))))
(unless existing
(fuel-refactor--insert-word word stack-effect code))
(fuel-refactor--extract-other start
(or (car (cddr existing)) (point))
code)))))
(if rp
(fuel-refactor--extract-other start
(or (car (cddr existing)) (point))
code)
(unwind-protect
(sit-for fuel-stack-highlight-period)
(delete-overlay fuel-stack--overlay)))))))
(defun fuel-refactor-extract-region (begin end)
"Extracts current region as a separate word."
(interactive "r")
(let ((begin (save-excursion
(goto-char begin)
(when (zerop (skip-syntax-backward "w"))
(skip-syntax-forward "-"))
(point)))
(end (save-excursion
(goto-char end)
(skip-syntax-forward "w")
(point))))
(fuel-refactor--extract begin end)))
(if (= begin end)
(fuel-refactor--extract begin end)
(let ((begin (save-excursion
(goto-char begin)
(when (zerop (skip-syntax-backward "w"))
(skip-syntax-forward "-"))
(point)))
(end (save-excursion
(goto-char end)
(skip-syntax-forward "w")
(point))))
(fuel-refactor--extract begin end))))
(defun fuel-refactor-extract-sexp ()
"Extracts current innermost sexp (up to point) as a separate