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

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 compute-free-pos last {
-            dup intersecting-inactive
+            { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
-            [ assign-blocked-register ]
+            { [ 2dup register-available? ] [ register-available ] }
-            [ assign-inactive-register ]
+            [ register-partially-available ]
-            if-empty
+        } cond
-        ] [ assign-free-register ]
-        if-empty
     ] if ;
 
 : handle-interval ( live-interval -- )

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 ]
+    [ reg>> >>reg add-active ]
-    [ nip delete-active ]
+    [ [ add-handled ] [ delete-active ] bi* ]
     [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
 
 : spill-new ( new existing -- )

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 ; inline
-    [ [ >>split-before ] [ >>split-after ] bi* drop ]
-    2bi ; inline
 
 ERROR: splitting-too-early ;
 
@@ -59,62 +57,21 @@ ERROR: splitting-atomic-interval ;
 
 HINTS: split-interval live-interval object ;
 
-: reuse-register ( new existing -- )
+: split-between-blocks ( new n -- before after )
-    reg>> >>reg add-active ;
+    split-interval
-
+    2dup [ compute-start/end ] bi@ ;
-: 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 ;
 
 : 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
+    1 -
+    2dup swap covers? [
         [ '[ _ insert-use-for-copy ] change-uses ] keep
-    1 - split-interval
+        split-between-blocks
-    2dup [ compute-start/end ] bi@ ;
+        2dup >>split-next drop
-
-: 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
     ] [
-        [ second split-before-use ] keep
+        split-between-blocks
-        '[ _ first reuse-register ] [ add-unhandled ] bi*
     ] if ;

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
+SYMBOL: registers
-
-: free-registers-for ( vreg -- seq )
-    reg-class>> free-registers get at ;
-
-: deallocate-register ( live-interval -- )
-    [ reg>> ] [ vreg>> ] bi free-registers-for push ;
 
 ! 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

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
 

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
 

basis/models/range/range-tests.factor

@@ -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

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 ;
 
-: <range> ( value page min max -- range )
+: <range> ( value page min max step -- range )
-    4array [ <model> ] map range new-product ;
+    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>> ;
 

basis/ui/gadgets/scrollers/scrollers-tests.factor

@@ -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
 

basis/ui/gadgets/scrollers/scrollers.factor

@@ -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 ;
 

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
@@ -236,3 +244,4 @@ PRIVATE>
             [ <down-button> f track-add ]
             [ drop <gadget> { 1 1 } >>dim f track-add ]
         } cleave ;
+

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>

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." } ;

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

core/sets/sets.factor

@@ -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 ;

extra/color-picker/color-picker.factor

@@ -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 ;

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 

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"

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

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
+
+<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 ;

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 ) ;

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 ) ;

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 ) ;

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 ) ;

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 ) ;

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