diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index a99fea1d24..868beee160 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -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 -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 4981a223a4..caef971ab9 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -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 -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index 40ee4083e4..e31fcedace 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index 2a1e87dcdd..737133aa32 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -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 unhandled-intervals set [ V{ } clone ] reg-class-assoc active-intervals set diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 243e83445d..072da88c07 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -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 diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 19a8f17a0c..314062591d 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -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 diff --git a/basis/models/range/range-tests.factor b/basis/models/range/range-tests.factor index e9119e8452..51f8b06ef5 100644 --- a/basis/models/range/range-tests.factor +++ b/basis/models/range/range-tests.factor @@ -3,13 +3,17 @@ USING: arrays generic kernel math models namespaces sequences assocs tools.test models.range ; ! Test -: setup-range ( -- range ) 0 0 0 255 ; +: setup-range ( -- range ) 0 0 0 255 1 ; +: setup-stepped-range ( -- range ) 0 0 0 255 2 ; ! 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 diff --git a/basis/models/range/range.factor b/basis/models/range/range.factor index c8bc8d8e54..c39c80c7d1 100644 --- a/basis/models/range/range.factor +++ b/basis/models/range/range.factor @@ -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 ; -: ( value page min max -- range ) - 4array [ ] map range new-product ; +: ( value page min max step -- range ) + 5 narray [ ] 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>> ; diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor index 4002c8b40e..5f5cc91846 100644 --- a/basis/ui/gadgets/scrollers/scrollers-tests.factor +++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor @@ -21,7 +21,7 @@ IN: ui.gadgets.scrollers.tests [ ] [ dup "g" set - 10 1 0 100 20 1 0 100 2array + 10 1 0 100 1 20 1 0 100 1 2array "v" set ] unit-test diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index 0852a6fe5d..8c73226639 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -49,7 +49,7 @@ scroller H{ } set-gestures : ( -- model ) - 0 0 0 0 0 0 0 0 2array ; + 0 0 0 0 1 0 0 0 0 1 2array ; M: viewport pref-dim* gadget-child pref-viewport-dim ; diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index d293fd7f8b..b98a0d152e 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -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> [ f track-add ] [ f track-add ] [ drop { 1 1 } >>dim f track-add ] - } cleave ; \ No newline at end of file + } cleave ; + diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index aee19279a4..37ec4f35b1 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -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> diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 298fcbeeae..0fce78dd68 100755 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -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." } ; diff --git a/core/sets/sets-tests.factor b/core/sets/sets-tests.factor old mode 100644 new mode 100755 index be195a62cd..f9f8ba9e65 --- a/core/sets/sets-tests.factor +++ b/core/sets/sets-tests.factor @@ -30,12 +30,3 @@ IN: sets.tests [ f ] [ { 1 } { } intersects? ] unit-test -[ - H{ - { 97 2 } - { 98 2 } - { 99 2 } - } -] [ - "aabbcc" histogram -] unit-test diff --git a/core/sets/sets.factor b/core/sets/sets.factor index 421d43bb3d..062b624e8f 100755 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -54,25 +54,3 @@ PRIVATE> : set= ( seq1 seq2 -- ? ) [ unique ] bi@ = ; - -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 ; diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index d7919aafd1..56a60d6fc8 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -26,7 +26,7 @@ M: color-preview model-changed horizontal 1 >>line ; : ( -- gadget model ) - 3 [ 0 0 0 255 ] replicate + 3 [ 0 0 0 255 1 ] replicate [ { 5 5 } >>gap [ add-gadget ] reduce ] [ [ range-model ] map ] bi ; diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor index 2fb115b5d0..542c48fbae 100644 --- a/extra/game-worlds/game-worlds.factor +++ b/extra/game-worlds/game-worlds.factor @@ -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 diff --git a/extra/histogram/histogram-docs.factor b/extra/histogram/histogram-docs.factor new file mode 100755 index 0000000000..d81400fc0b --- /dev/null +++ b/extra/histogram/histogram-docs.factor @@ -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" diff --git a/extra/histogram/histogram-tests.factor b/extra/histogram/histogram-tests.factor new file mode 100755 index 0000000000..f0e7b3e80e --- /dev/null +++ b/extra/histogram/histogram-tests.factor @@ -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 diff --git a/extra/histogram/histogram.factor b/extra/histogram/histogram.factor new file mode 100755 index 0000000000..70ddfd3af5 --- /dev/null +++ b/extra/histogram/histogram.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences assocs ; +IN: histogram + +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 ; diff --git a/extra/tokyo/alien/tcbdb/tcbdb.factor b/extra/tokyo/alien/tcbdb/tcbdb.factor old mode 100644 new mode 100755 index 730423c169..8739e04608 --- a/extra/tokyo/alien/tcbdb/tcbdb.factor +++ b/extra/tokyo/alien/tcbdb/tcbdb.factor @@ -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 ) ; diff --git a/extra/tokyo/alien/tcfdb/tcfdb.factor b/extra/tokyo/alien/tcfdb/tcfdb.factor old mode 100644 new mode 100755 index c624f86f40..91400aaf4e --- a/extra/tokyo/alien/tcfdb/tcfdb.factor +++ b/extra/tokyo/alien/tcfdb/tcfdb.factor @@ -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 ) ; diff --git a/extra/tokyo/alien/tchdb/tchdb.factor b/extra/tokyo/alien/tchdb/tchdb.factor old mode 100644 new mode 100755 index f143e9b304..3793846050 --- a/extra/tokyo/alien/tchdb/tchdb.factor +++ b/extra/tokyo/alien/tchdb/tchdb.factor @@ -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 ) ; diff --git a/extra/tokyo/alien/tcrdb/tcrdb.factor b/extra/tokyo/alien/tcrdb/tcrdb.factor old mode 100644 new mode 100755 index 5b7be38461..3ff3bc6428 --- a/extra/tokyo/alien/tcrdb/tcrdb.factor +++ b/extra/tokyo/alien/tcrdb/tcrdb.factor @@ -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 ) ; diff --git a/extra/tokyo/alien/tctdb/tctdb.factor b/extra/tokyo/alien/tctdb/tctdb.factor old mode 100644 new mode 100755 index 7bcb0f278d..bb65acb2f6 --- a/extra/tokyo/alien/tctdb/tctdb.factor +++ b/extra/tokyo/alien/tctdb/tctdb.factor @@ -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 ) ; diff --git a/extra/tokyo/alien/tcutil/tcutil.factor b/extra/tokyo/alien/tcutil/tcutil.factor old mode 100644 new mode 100755 index 25df54d013..ac6e242be2 --- a/extra/tokyo/alien/tcutil/tcutil.factor +++ b/extra/tokyo/alien/tcutil/tcutil.factor @@ -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