Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
a84146cb0d
|
|
@ -1,21 +1,66 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs heaps kernel namespaces sequences
|
||||
USING: accessors assocs heaps kernel namespaces sequences fry math
|
||||
combinators arrays sorting
|
||||
compiler.cfg.linear-scan.allocation.coalescing
|
||||
compiler.cfg.linear-scan.allocation.spilling
|
||||
compiler.cfg.linear-scan.allocation.splitting
|
||||
compiler.cfg.linear-scan.allocation.state ;
|
||||
IN: compiler.cfg.linear-scan.allocation
|
||||
|
||||
: relevant-ranges ( new inactive -- new' inactive' )
|
||||
! Slice off all ranges of 'inactive' that precede the start of 'new'
|
||||
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
|
||||
|
||||
: intersect-live-range ( range1 range2 -- n/f )
|
||||
2dup [ from>> ] bi@ > [ swap ] when
|
||||
2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
|
||||
|
||||
: intersect-live-ranges ( ranges1 ranges2 -- n )
|
||||
{
|
||||
{ [ over empty? ] [ 2drop 1/0. ] }
|
||||
{ [ dup empty? ] [ 2drop 1/0. ] }
|
||||
[
|
||||
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
|
||||
drop
|
||||
2dup [ first from>> ] bi@ <
|
||||
[ [ rest-slice ] dip ] [ rest-slice ] if
|
||||
intersect-live-ranges
|
||||
] if
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: intersect-inactive ( new inactive -- n )
|
||||
relevant-ranges intersect-live-ranges ;
|
||||
|
||||
: compute-free-pos ( new -- free-pos )
|
||||
dup vreg>>
|
||||
[ nip reg-class>> registers get at [ 1/0. ] H{ } map>assoc ]
|
||||
[ inactive-intervals-for [ [ reg>> swap ] keep intersect-inactive ] with H{ } map>assoc ]
|
||||
[ nip active-intervals-for [ reg>> 0 ] H{ } map>assoc ]
|
||||
2tri 3array assoc-combine
|
||||
>alist sort-values ;
|
||||
|
||||
: no-free-registers? ( result -- ? )
|
||||
second 0 = ; inline
|
||||
|
||||
: register-available? ( new result -- ? )
|
||||
[ end>> ] [ second ] bi* < ; inline
|
||||
|
||||
: register-available ( new result -- )
|
||||
first >>reg add-active ;
|
||||
|
||||
: register-partially-available ( new result -- )
|
||||
[ second split-before-use ] keep
|
||||
'[ _ register-available ] [ add-unhandled ] bi* ;
|
||||
|
||||
: assign-register ( new -- )
|
||||
dup coalesce? [ coalesce ] [
|
||||
dup vreg>> free-registers-for [
|
||||
dup intersecting-inactive
|
||||
[ assign-blocked-register ]
|
||||
[ assign-inactive-register ]
|
||||
if-empty
|
||||
] [ assign-free-register ]
|
||||
if-empty
|
||||
dup compute-free-pos last {
|
||||
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] }
|
||||
{ [ 2dup register-available? ] [ register-available ] }
|
||||
[ register-partially-available ]
|
||||
} cond
|
||||
] if ;
|
||||
|
||||
: handle-interval ( live-interval -- )
|
||||
|
|
|
|||
|
|
@ -39,8 +39,8 @@ IN: compiler.cfg.linear-scan.allocation.spilling
|
|||
#! with the most distant use location. Spill the existing
|
||||
#! interval, then process the new interval and the tail end
|
||||
#! of the existing interval again.
|
||||
[ reuse-register ]
|
||||
[ nip delete-active ]
|
||||
[ reg>> >>reg add-active ]
|
||||
[ [ add-handled ] [ delete-active ] bi* ]
|
||||
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
|
||||
|
||||
: spill-new ( new existing -- )
|
||||
|
|
|
|||
|
|
@ -28,9 +28,7 @@ IN: compiler.cfg.linear-scan.allocation.splitting
|
|||
'[ _ <= ] partition ;
|
||||
|
||||
: record-split ( live-interval before after -- )
|
||||
[ >>split-next drop ]
|
||||
[ [ >>split-before ] [ >>split-after ] bi* drop ]
|
||||
2bi ; inline
|
||||
[ >>split-before ] [ >>split-after ] bi* drop ; inline
|
||||
|
||||
ERROR: splitting-too-early ;
|
||||
|
||||
|
|
@ -59,62 +57,21 @@ ERROR: splitting-atomic-interval ;
|
|||
|
||||
HINTS: split-interval live-interval object ;
|
||||
|
||||
: reuse-register ( new existing -- )
|
||||
reg>> >>reg add-active ;
|
||||
|
||||
: relevant-ranges ( new inactive -- new' inactive' )
|
||||
! Slice off all ranges of 'inactive' that precede the start of 'new'
|
||||
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
|
||||
|
||||
: intersect-live-range ( range1 range2 -- n/f )
|
||||
2dup [ from>> ] bi@ > [ swap ] when
|
||||
2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
|
||||
|
||||
: intersect-live-ranges ( ranges1 ranges2 -- n )
|
||||
{
|
||||
{ [ over empty? ] [ 2drop 1/0. ] }
|
||||
{ [ dup empty? ] [ 2drop 1/0. ] }
|
||||
[
|
||||
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
|
||||
drop
|
||||
2dup [ first from>> ] bi@ <
|
||||
[ [ rest-slice ] dip ] [ rest-slice ] if
|
||||
intersect-live-ranges
|
||||
] if
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: intersect-inactive ( new inactive active-regs -- n/f )
|
||||
! If the interval's register is currently in use, we cannot
|
||||
! re-use it.
|
||||
2dup [ reg>> ] dip key?
|
||||
[ 3drop f ] [ drop relevant-ranges intersect-live-ranges ] if ;
|
||||
|
||||
: intersecting-inactive ( new -- live-intervals )
|
||||
dup vreg>>
|
||||
[ inactive-intervals-for ]
|
||||
[ active-intervals-for [ reg>> ] map unique ] bi
|
||||
'[ tuck _ intersect-inactive ] with { } map>assoc
|
||||
[ nip ] assoc-filter ;
|
||||
: split-between-blocks ( new n -- before after )
|
||||
split-interval
|
||||
2dup [ compute-start/end ] bi@ ;
|
||||
|
||||
: insert-use-for-copy ( seq n -- seq' )
|
||||
[ 1array split1 ] keep [ 1 - ] keep 2array glue ;
|
||||
dup 1 + [ nip 1array split1 ] 2keep 2array glue ;
|
||||
|
||||
: split-before-use ( new n -- before after )
|
||||
! Find optimal split position
|
||||
! Insert move instruction
|
||||
[ '[ _ insert-use-for-copy ] change-uses ] keep
|
||||
1 - split-interval
|
||||
2dup [ compute-start/end ] bi@ ;
|
||||
|
||||
: assign-inactive-register ( new live-intervals -- )
|
||||
! If there is an interval which is inactive for the entire lifetime
|
||||
! if the new interval, reuse its vreg. Otherwise, split new so that
|
||||
! the first half fits.
|
||||
sort-values last
|
||||
2dup [ end>> ] [ second ] bi* < [
|
||||
first reuse-register
|
||||
1 -
|
||||
2dup swap covers? [
|
||||
[ '[ _ insert-use-for-copy ] change-uses ] keep
|
||||
split-between-blocks
|
||||
2dup >>split-next drop
|
||||
] [
|
||||
[ second split-before-use ] keep
|
||||
'[ _ first reuse-register ] [ add-unhandled ] bi*
|
||||
split-between-blocks
|
||||
] if ;
|
||||
|
|
@ -6,13 +6,7 @@ compiler.cfg.linear-scan.live-intervals ;
|
|||
IN: compiler.cfg.linear-scan.allocation.state
|
||||
|
||||
! Mapping from register classes to sequences of machine registers
|
||||
SYMBOL: free-registers
|
||||
|
||||
: free-registers-for ( vreg -- seq )
|
||||
reg-class>> free-registers get at ;
|
||||
|
||||
: deallocate-register ( live-interval -- )
|
||||
[ reg>> ] [ vreg>> ] bi free-registers-for push ;
|
||||
SYMBOL: registers
|
||||
|
||||
! Vector of active live intervals
|
||||
SYMBOL: active-intervals
|
||||
|
|
@ -47,7 +41,7 @@ SYMBOL: handled-intervals
|
|||
: finished? ( n live-interval -- ? ) end>> swap < ;
|
||||
|
||||
: finish ( n live-interval -- keep? )
|
||||
nip [ deallocate-register ] [ add-handled ] bi f ;
|
||||
nip add-handled f ;
|
||||
|
||||
SYMBOL: check-allocation?
|
||||
|
||||
|
|
@ -121,7 +115,7 @@ SYMBOL: spill-counts
|
|||
spill-counts get [ dup 1 + ] change-at ;
|
||||
|
||||
: init-allocator ( registers -- )
|
||||
[ reverse >vector ] assoc-map free-registers set
|
||||
registers set
|
||||
[ 0 ] reg-class-assoc spill-counts set
|
||||
<min-heap> unhandled-intervals set
|
||||
[ V{ } clone ] reg-class-assoc active-intervals set
|
||||
|
|
|
|||
|
|
@ -1410,7 +1410,6 @@ USING: math.private compiler.cfg.debugger ;
|
|||
{ uses { 5 10 } }
|
||||
{ ranges V{ T{ live-range f 5 10 } } }
|
||||
}
|
||||
H{ }
|
||||
intersect-inactive
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -264,5 +264,8 @@ M: real atan fatan ;
|
|||
|
||||
: ceiling ( x -- y ) neg floor neg ; foldable
|
||||
|
||||
: floor-to ( x step -- y )
|
||||
dup zero? [ drop ] [ [ / floor ] [ * ] bi ] if ;
|
||||
|
||||
: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -3,13 +3,17 @@ USING: arrays generic kernel math models namespaces sequences assocs
|
|||
tools.test models.range ;
|
||||
|
||||
! Test <range>
|
||||
: setup-range ( -- range ) 0 0 0 255 <range> ;
|
||||
: setup-range ( -- range ) 0 0 0 255 1 <range> ;
|
||||
: setup-stepped-range ( -- range ) 0 0 0 255 2 <range> ;
|
||||
|
||||
! clamp-value should not go past range ends
|
||||
[ 0 ] [ -10 setup-range clamp-value ] unit-test
|
||||
[ 255 ] [ 2000 setup-range clamp-value ] unit-test
|
||||
[ 14 ] [ 14 setup-range clamp-value ] unit-test
|
||||
|
||||
! step-value
|
||||
[ 14 ] [ 15 setup-stepped-range step-value ] unit-test
|
||||
|
||||
! range min/max/page values should be correct
|
||||
[ 0 ] [ setup-range range-page-value ] unit-test
|
||||
[ 0 ] [ setup-range range-min-value ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,22 +1,26 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel models arrays sequences math math.order
|
||||
models.product ;
|
||||
models.product generalizations math.functions ;
|
||||
FROM: models.product => product ;
|
||||
IN: models.range
|
||||
|
||||
TUPLE: range < product ;
|
||||
|
||||
: <range> ( value page min max -- range )
|
||||
4array [ <model> ] map range new-product ;
|
||||
: <range> ( value page min max step -- range )
|
||||
5 narray [ <model> ] map range new-product ;
|
||||
|
||||
: range-model ( range -- model ) dependencies>> first ;
|
||||
: range-page ( range -- model ) dependencies>> second ;
|
||||
: range-min ( range -- model ) dependencies>> third ;
|
||||
: range-max ( range -- model ) dependencies>> fourth ;
|
||||
: range-step ( range -- model ) dependencies>> 4 swap nth ;
|
||||
|
||||
: step-value ( value range -- value' )
|
||||
range-step value>> floor-to ;
|
||||
|
||||
M: range range-value
|
||||
[ range-model value>> ] keep clamp-value ;
|
||||
[ range-model value>> ] [ clamp-value ] [ step-value ] tri ;
|
||||
|
||||
M: range range-page-value range-page value>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ IN: ui.gadgets.scrollers.tests
|
|||
|
||||
[ ] [
|
||||
<gadget> dup "g" set
|
||||
10 1 0 100 <range> 20 1 0 100 <range> 2array <product>
|
||||
10 1 0 100 1 <range> 20 1 0 100 1 <range> 2array <product>
|
||||
<viewport> "v" set
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ scroller H{
|
|||
} set-gestures
|
||||
|
||||
: <scroller-model> ( -- model )
|
||||
0 0 0 0 <range> 0 0 0 0 <range> 2array <product> ;
|
||||
0 0 0 0 1 <range> 0 0 0 0 1 <range> 2array <product> ;
|
||||
|
||||
M: viewport pref-dim* gadget-child pref-viewport-dim ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,11 +9,15 @@ IN: ui.gadgets.sliders
|
|||
|
||||
TUPLE: slider < track elevator thumb saved line ;
|
||||
|
||||
: slider-value ( gadget -- n ) model>> range-value >fixnum ;
|
||||
: slider-value ( gadget -- n ) model>> range-value ;
|
||||
: slider-page ( gadget -- n ) model>> range-page-value ;
|
||||
: slider-min ( gadget -- n ) model>> range-min-value ;
|
||||
: slider-max ( gadget -- n ) model>> range-max-value ;
|
||||
: slider-max* ( gadget -- n ) model>> range-max-value* ;
|
||||
|
||||
: slider-length ( gadget -- n ) [ slider-max ] [ slider-min ] bi - ;
|
||||
: slider-length* ( gadget -- n ) [ slider-max* ] [ slider-min ] bi - ;
|
||||
|
||||
: slide-by ( amount slider -- ) model>> move-by ;
|
||||
: slide-by-page ( amount slider -- ) model>> move-by-page ;
|
||||
|
||||
|
|
@ -34,7 +38,9 @@ CONSTANT: elevator-padding 4
|
|||
CONSTANT: min-thumb-dim 30
|
||||
|
||||
: visible-portion ( slider -- n )
|
||||
[ slider-page ] [ slider-max 1 max ] bi / 1 min ;
|
||||
[ slider-page ]
|
||||
[ slider-length 1 max ]
|
||||
bi / 1 min ;
|
||||
|
||||
: thumb-dim ( slider -- h )
|
||||
[
|
||||
|
|
@ -48,7 +54,7 @@ CONSTANT: min-thumb-dim 30
|
|||
#! x*n is the screen position of the thumb, and conversely
|
||||
#! for x/n. The '1 max' calls avoid division by zero.
|
||||
[ [ elevator-length ] [ thumb-dim ] bi - 1 max ]
|
||||
[ slider-max* 1 max ]
|
||||
[ slider-length* 1 max ]
|
||||
bi / ;
|
||||
|
||||
: slider>screen ( m slider -- n ) slider-scale * ;
|
||||
|
|
@ -131,7 +137,9 @@ elevator H{
|
|||
swap >>orientation ;
|
||||
|
||||
: thumb-loc ( slider -- loc )
|
||||
[ slider-value ] keep slider>screen elevator-padding + ;
|
||||
[ slider-value ]
|
||||
[ slider-min - ]
|
||||
[ slider>screen elevator-padding + ] tri ;
|
||||
|
||||
: layout-thumb-loc ( thumb slider -- )
|
||||
[ thumb-loc ] [ orientation>> ] bi n*v
|
||||
|
|
@ -235,4 +243,5 @@ PRIVATE>
|
|||
[ <up-button> f track-add ]
|
||||
[ <down-button> f track-add ]
|
||||
[ drop <gadget> { 1 1 } >>dim f track-add ]
|
||||
} cleave ;
|
||||
} cleave ;
|
||||
|
||||
|
|
|
|||
|
|
@ -198,7 +198,7 @@ PRIVATE>
|
|||
windows get empty? not ;
|
||||
|
||||
: ?attributes ( gadget title/attributes -- attributes )
|
||||
dup string? [ world-attributes new swap >>title ] when
|
||||
dup string? [ world-attributes new swap >>title ] [ clone ] if
|
||||
swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -20,13 +20,6 @@ $nl
|
|||
{ $subsection set= }
|
||||
"A word used to implement the above:"
|
||||
{ $subsection unique }
|
||||
"Counting elements in a sequence:"
|
||||
{ $subsection histogram }
|
||||
{ $subsection histogram* }
|
||||
"Combinators for implementing histogram:"
|
||||
{ $subsection sequence>assoc }
|
||||
{ $subsection sequence>assoc* }
|
||||
{ $subsection sequence>hashtable }
|
||||
"Adding elements to sets:"
|
||||
{ $subsection adjoin }
|
||||
{ $subsection conjoin }
|
||||
|
|
@ -134,72 +127,3 @@ HELP: gather
|
|||
{ "newseq" sequence } }
|
||||
{ $description "Maps a quotation onto a sequence, concatenates the results of the mapping, and removes duplicates." } ;
|
||||
|
||||
HELP: histogram
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "hashtable" hashtable }
|
||||
}
|
||||
{ $examples
|
||||
{ $example "! Count the number of times an element appears in a sequence."
|
||||
"USING: prettyprint sets ;"
|
||||
"\"aaabc\" histogram ."
|
||||
"H{ { 97 3 } { 98 1 } { 99 1 } }"
|
||||
}
|
||||
}
|
||||
{ $description "Returns a hashtable where the keys are the elements of the sequence and the values are the number of times they appeared in that sequence." } ;
|
||||
|
||||
HELP: histogram*
|
||||
{ $values
|
||||
{ "hashtable" hashtable } { "seq" sequence }
|
||||
{ "hashtable" hashtable }
|
||||
}
|
||||
{ $examples
|
||||
{ $example "! Count the number of times the elements of two sequences appear."
|
||||
"USING: prettyprint sets ;"
|
||||
"\"aaabc\" histogram \"aaaaaabc\" histogram* ."
|
||||
"H{ { 97 9 } { 98 2 } { 99 2 } }"
|
||||
}
|
||||
}
|
||||
{ $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ;
|
||||
|
||||
HELP: sequence>assoc
|
||||
{ $values
|
||||
{ "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" }
|
||||
{ "assoc" assoc }
|
||||
}
|
||||
{ $examples
|
||||
{ $example "! Iterate over a sequence and increment the count at each element"
|
||||
"USING: assocs prettyprint sets ;"
|
||||
"\"aaabc\" [ inc-at ] H{ } sequence>assoc ."
|
||||
"H{ { 97 3 } { 98 1 } { 99 1 } }"
|
||||
}
|
||||
}
|
||||
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } ;
|
||||
|
||||
HELP: sequence>assoc*
|
||||
{ $values
|
||||
{ "assoc" assoc } { "seq" sequence } { "quot" quotation }
|
||||
{ "assoc" assoc }
|
||||
}
|
||||
{ $examples
|
||||
{ $example "! Iterate over a sequence and add the counts to an existing assoc"
|
||||
"USING: assocs prettyprint sets kernel ;"
|
||||
"H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ."
|
||||
"H{ { 97 5 } { 98 2 } { 99 1 } }"
|
||||
}
|
||||
}
|
||||
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } " according to the passed quotation." } ;
|
||||
|
||||
HELP: sequence>hashtable
|
||||
{ $values
|
||||
{ "seq" sequence } { "quot" quotation }
|
||||
{ "hashtable" hashtable }
|
||||
}
|
||||
{ $examples
|
||||
{ $example "! Count the number of times an element occurs in a sequence"
|
||||
"USING: assocs prettyprint sets ;"
|
||||
"\"aaabc\" [ inc-at ] sequence>hashtable ."
|
||||
"H{ { 97 3 } { 98 1 } { 99 1 } }"
|
||||
}
|
||||
}
|
||||
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a hashtable according to the passed quotation." } ;
|
||||
|
|
|
|||
|
|
@ -30,12 +30,3 @@ IN: sets.tests
|
|||
|
||||
[ f ] [ { 1 } { } intersects? ] unit-test
|
||||
|
||||
[
|
||||
H{
|
||||
{ 97 2 }
|
||||
{ 98 2 }
|
||||
{ 99 2 }
|
||||
}
|
||||
] [
|
||||
"aabbcc" histogram
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -54,25 +54,3 @@ PRIVATE>
|
|||
|
||||
: set= ( seq1 seq2 -- ? )
|
||||
[ unique ] bi@ = ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (sequence>assoc) ( seq quot assoc -- assoc )
|
||||
[ swap curry each ] keep ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: sequence>assoc* ( assoc seq quot: ( obj assoc -- ) -- assoc )
|
||||
rot (sequence>assoc) ; inline
|
||||
|
||||
: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc )
|
||||
clone (sequence>assoc) ; inline
|
||||
|
||||
: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable )
|
||||
H{ } sequence>assoc ; inline
|
||||
|
||||
: histogram* ( hashtable seq -- hashtable )
|
||||
[ inc-at ] sequence>assoc* ;
|
||||
|
||||
: histogram ( seq -- hashtable )
|
||||
[ inc-at ] sequence>hashtable ;
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ M: color-preview model-changed
|
|||
horizontal <slider> 1 >>line ;
|
||||
|
||||
: <color-sliders> ( -- gadget model )
|
||||
3 [ 0 0 0 255 <range> ] replicate
|
||||
3 [ 0 0 0 255 1 <range> ] replicate
|
||||
[ <filled-pile> { 5 5 } >>gap [ <color-slider> add-gadget ] reduce ]
|
||||
[ [ range-model ] map <product> ]
|
||||
bi ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: accessors game-input game-loop kernel math ui.gadgets
|
||||
ui.gadgets.worlds ui.gestures ;
|
||||
ui.gadgets.worlds ui.gestures threads ;
|
||||
IN: game-worlds
|
||||
|
||||
TUPLE: game-world < world
|
||||
|
|
@ -9,7 +9,7 @@ TUPLE: game-world < world
|
|||
GENERIC: tick-length ( world -- millis )
|
||||
|
||||
M: game-world draw*
|
||||
swap >>tick-slice draw-world ;
|
||||
swap >>tick-slice relayout-1 yield ;
|
||||
|
||||
M: game-world begin-world
|
||||
open-game-input
|
||||
|
|
|
|||
|
|
@ -0,0 +1,83 @@
|
|||
IN: histogram
|
||||
USING: help.markup help.syntax sequences hashtables quotations assocs ;
|
||||
|
||||
HELP: histogram
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "hashtable" hashtable }
|
||||
}
|
||||
{ $examples
|
||||
{ $example "! Count the number of times an element appears in a sequence."
|
||||
"USING: prettyprint sets ;"
|
||||
"\"aaabc\" histogram ."
|
||||
"H{ { 97 3 } { 98 1 } { 99 1 } }"
|
||||
}
|
||||
}
|
||||
{ $description "Returns a hashtable where the keys are the elements of the sequence and the values are the number of times they appeared in that sequence." } ;
|
||||
|
||||
HELP: histogram*
|
||||
{ $values
|
||||
{ "hashtable" hashtable } { "seq" sequence }
|
||||
{ "hashtable" hashtable }
|
||||
}
|
||||
{ $examples
|
||||
{ $example "! Count the number of times the elements of two sequences appear."
|
||||
"USING: prettyprint sets ;"
|
||||
"\"aaabc\" histogram \"aaaaaabc\" histogram* ."
|
||||
"H{ { 97 9 } { 98 2 } { 99 2 } }"
|
||||
}
|
||||
}
|
||||
{ $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ;
|
||||
|
||||
HELP: sequence>assoc
|
||||
{ $values
|
||||
{ "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" }
|
||||
{ "assoc" assoc }
|
||||
}
|
||||
{ $examples
|
||||
{ $example "! Iterate over a sequence and increment the count at each element"
|
||||
"USING: assocs prettyprint sets ;"
|
||||
"\"aaabc\" [ inc-at ] H{ } sequence>assoc ."
|
||||
"H{ { 97 3 } { 98 1 } { 99 1 } }"
|
||||
}
|
||||
}
|
||||
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } ;
|
||||
|
||||
HELP: sequence>assoc*
|
||||
{ $values
|
||||
{ "assoc" assoc } { "seq" sequence } { "quot" quotation }
|
||||
{ "assoc" assoc }
|
||||
}
|
||||
{ $examples
|
||||
{ $example "! Iterate over a sequence and add the counts to an existing assoc"
|
||||
"USING: assocs prettyprint sets kernel ;"
|
||||
"H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ."
|
||||
"H{ { 97 5 } { 98 2 } { 99 1 } }"
|
||||
}
|
||||
}
|
||||
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } " according to the passed quotation." } ;
|
||||
|
||||
HELP: sequence>hashtable
|
||||
{ $values
|
||||
{ "seq" sequence } { "quot" quotation }
|
||||
{ "hashtable" hashtable }
|
||||
}
|
||||
{ $examples
|
||||
{ $example "! Count the number of times an element occurs in a sequence"
|
||||
"USING: assocs prettyprint sets ;"
|
||||
"\"aaabc\" [ inc-at ] sequence>hashtable ."
|
||||
"H{ { 97 3 } { 98 1 } { 99 1 } }"
|
||||
}
|
||||
}
|
||||
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a hashtable according to the passed quotation." } ;
|
||||
|
||||
ARTICLE: "histogram" "Computing histograms"
|
||||
"Counting elements in a sequence:"
|
||||
{ $subsection histogram }
|
||||
{ $subsection histogram* }
|
||||
"Combinators for implementing histogram:"
|
||||
{ $subsection sequence>assoc }
|
||||
{ $subsection sequence>assoc* }
|
||||
{ $subsection sequence>hashtable } ;
|
||||
|
||||
ABOUT: "histogram"
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
IN: histogram.tests
|
||||
USING: help.markup help.syntax tools.test histogram ;
|
||||
|
||||
[
|
||||
H{
|
||||
{ 97 2 }
|
||||
{ 98 2 }
|
||||
{ 99 2 }
|
||||
}
|
||||
] [
|
||||
"aabbcc" histogram
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences assocs ;
|
||||
IN: histogram
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (sequence>assoc) ( seq quot assoc -- assoc )
|
||||
[ swap curry each ] keep ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: sequence>assoc* ( assoc seq quot: ( obj assoc -- ) -- assoc )
|
||||
rot (sequence>assoc) ; inline
|
||||
|
||||
: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc )
|
||||
clone (sequence>assoc) ; inline
|
||||
|
||||
: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable )
|
||||
H{ } sequence>assoc ; inline
|
||||
|
||||
: histogram* ( hashtable seq -- hashtable )
|
||||
[ inc-at ] sequence>assoc* ;
|
||||
|
||||
: histogram ( seq -- hashtable )
|
||||
[ inc-at ] sequence>hashtable ;
|
||||
|
|
@ -116,7 +116,7 @@ FUNCTION: ulonglong tcbdbbnum ( TCBDB* bdb ) ;
|
|||
FUNCTION: uint tcbdbalign ( TCBDB* bdb ) ;
|
||||
FUNCTION: uint tcbdbfbpmax ( TCBDB* bdb ) ;
|
||||
FUNCTION: ulonglong tcbdbinode ( TCBDB* bdb ) ;
|
||||
FUNCTION: time_t tcbdbmtime ( TCBDB* bdb ) ;
|
||||
FUNCTION: tokyo_time_t tcbdbmtime ( TCBDB* bdb ) ;
|
||||
FUNCTION: uchar tcbdbflags ( TCBDB* bdb ) ;
|
||||
FUNCTION: uchar tcbdbopts ( TCBDB* bdb ) ;
|
||||
FUNCTION: char* tcbdbopaque ( TCBDB* bdb ) ;
|
||||
|
|
|
|||
|
|
@ -84,7 +84,7 @@ FUNCTION: uint tcfdbwidth ( TCFDB* fdb ) ;
|
|||
FUNCTION: ulonglong tcfdblimsiz ( TCFDB* fdb ) ;
|
||||
FUNCTION: ulonglong tcfdblimid ( TCFDB* fdb ) ;
|
||||
FUNCTION: ulonglong tcfdbinode ( TCFDB* fdb ) ;
|
||||
FUNCTION: time_t tcfdbmtime ( TCFDB* fdb ) ;
|
||||
FUNCTION: tokyo_time_t tcfdbmtime ( TCFDB* fdb ) ;
|
||||
FUNCTION: int tcfdbomode ( TCFDB* fdb ) ;
|
||||
FUNCTION: uchar tcfdbtype ( TCFDB* fdb ) ;
|
||||
FUNCTION: uchar tcfdbflags ( TCFDB* fdb ) ;
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ FUNCTION: uint tchdbalign ( TCHDB* hdb ) ;
|
|||
FUNCTION: uint tchdbfbpmax ( TCHDB* hdb ) ;
|
||||
FUNCTION: ulonglong tchdbxmsiz ( TCHDB* hdb ) ;
|
||||
FUNCTION: ulonglong tchdbinode ( TCHDB* hdb ) ;
|
||||
FUNCTION: time_t tchdbmtime ( TCHDB* hdb ) ;
|
||||
FUNCTION: tokyo_time_t tchdbmtime ( TCHDB* hdb ) ;
|
||||
FUNCTION: int tchdbomode ( TCHDB* hdb ) ;
|
||||
FUNCTION: uchar tchdbtype ( TCHDB* hdb ) ;
|
||||
FUNCTION: uchar tchdbflags ( TCHDB* hdb ) ;
|
||||
|
|
|
|||
|
|
@ -42,8 +42,6 @@ CONSTANT: RDBXOLCKGLB 2
|
|||
CONSTANT: RDBROCHKCON 1
|
||||
CONSTANT: RDBMONOULOG 1
|
||||
|
||||
TYPEDEF: int bool
|
||||
|
||||
FUNCTION: char* tcrdberrmsg ( int ecode ) ;
|
||||
FUNCTION: TCRDB* tcrdbnew ( ) ;
|
||||
FUNCTION: void tcrdbdel ( TCRDB* rdb ) ;
|
||||
|
|
|
|||
|
|
@ -136,7 +136,7 @@ FUNCTION: ulonglong tctdbbnum ( TCTDB* tdb ) ;
|
|||
FUNCTION: uint tctdbalign ( TCTDB* tdb ) ;
|
||||
FUNCTION: uint tctdbfbpmax ( TCTDB* tdb ) ;
|
||||
FUNCTION: ulonglong tctdbinode ( TCTDB* tdb ) ;
|
||||
FUNCTION: time_t tctdbmtime ( TCTDB* tdb ) ;
|
||||
FUNCTION: tokyo_time_t tctdbmtime ( TCTDB* tdb ) ;
|
||||
FUNCTION: uchar tctdbflags ( TCTDB* tdb ) ;
|
||||
FUNCTION: uchar tctdbopts ( TCTDB* tdb ) ;
|
||||
FUNCTION: char* tctdbopaque ( TCTDB* tdb ) ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ C-ENUM:
|
|||
TCDBTTABLE ;
|
||||
|
||||
! FIXME: on windows 64bits this isn't correct, because long is 32bits there, and time_t is int64
|
||||
TYPEDEF: long time_t
|
||||
TYPEDEF: long tokyo_time_t
|
||||
|
||||
TYPEDEF: void* TCLIST*
|
||||
|
||||
|
|
@ -36,4 +36,4 @@ FUNCTION: void tcfree ( void* ptr ) ;
|
|||
TYPEDEF: void* TCCMP
|
||||
TYPEDEF: void* TCCODEC
|
||||
TYPEDEF: void* TCPDPROC
|
||||
TYPEDEF: voud* TCITER
|
||||
TYPEDEF: void* TCITER
|
||||
|
|
|
|||
Loading…
Reference in New Issue