math.binpack: make binpacking much faster by caching total weight per bin.

extra/math/binpack/binpack-docs.factor

@@ -3,17 +3,13 @@
 
 USING: help.syntax help.markup kernel assocs sequences quotations ;
 
-IN: math.binpack 
+IN: math.binpack
 
 HELP: binpack
-{ $values { "assoc" assoc } { "n" "number of bins" } { "bins" "packed bins" } }
-{ $description "Packs the (key, value) pairs into the specified number of bins, using the value as a weight." } ;
-
-HELP: binpack*
-{ $values { "items" sequence } { "n" "number of bins" } { "bins" "packed bins" } } 
+{ $values { "items" sequence } { "#bins" "number of bins" } { "bins" "packed bins" } } 
 { $description "Packs a sequence of numbers into the specified number of bins." } ;
 
-HELP: binpack!
-{ $values { "items" sequence } { "quot" quotation } { "n" "number of bins" } { "bins" "packed bins" } } 
+HELP: map-binpack
+{ $values { "items" sequence } { "quot" { $quotation ( item -- weight ) } } { "#bins" "number of bins" } { "bins" "packed bins" } } 
 { $description "Packs a sequence of items into the specified number of bins, using the quotation to determine the weight." } ;
 

extra/math/binpack/binpack-tests.factor

@@ -1,13 +1,24 @@
 ! Copyright (C) 2008 John Benediktsson
 ! See http://factorcode.org/license.txt for BSD license
 
-USING: kernel tools.test math.binpack ;
+USING: kernel tools.test sequences ;
 
-[ t ] [ { V{ } } { } 1 binpack = ] unit-test
+IN: math.binpack
 
-[ t ] [ { { 3 } { 2 1 } } { 1 2 3 } 2 binpack* = ] unit-test
+{ { { } } } [ { } 1 binpack ] unit-test
 
-[ t ] [ { { 1000 } { 100 60 30 7 } { 70 60 40 23 3 } } 
-        { 100 23 40 60 1000 30 60 07 70 03 } 3 binpack* = ] unit-test
+{ { { 3 } { 2 1 } } } [ { 1 2 3 } 2 binpack ] unit-test
 
+{ { { 1000 } { 100 60 30 7 } { 70 60 40 23 3 } } }
+[ { 100 23 40 60 1000 30 60 07 70 03 } 3 binpack ] unit-test
 
+{
+    {
+        { "violet" "orange" }
+        { "indigo" "green" }
+        { "yellow" "blue" "red" }
+    }
+} [
+    { "red" "orange" "yellow" "green" "blue" "indigo" "violet" }
+    [ length ] 3 map-binpack
+] unit-test

extra/math/binpack/binpack.factor

@@ -1,24 +1,36 @@
 ! Copyright (C) 2008 John Benediktsson
 ! See http://factorcode.org/license.txt for BSD license
 
-USING: sequences kernel arrays vectors accessors assocs shuffle sorting locals math math.functions ;
+USING: arrays assocs kernel locals math math.functions sequences
+sorting sorting.extras vectors fry ;
+USE: accessors
 
-IN: math.binpack 
+IN: math.binpack
 
-: (binpack) ( bins item -- )
-    [ [ values sum ] map ] keep
-    zip sort-keys values first push ;
+<PRIVATE
 
-:: binpack ( assoc n -- bins )
-    assoc sort-values <reversed> :> values
-    values length :> #values
-    n #values n / ceiling <array> [ <vector> ] map :> bins
-    values [ bins (binpack) ] each
-    bins ;
+TUPLE: bin items total ;
 
-: binpack* ( items n -- bins )
-    [ dup zip ] dip binpack [ keys ] map ;
+: <bin> ( -- bin )
+    V{ } clone 0 bin boa ; inline
 
-: binpack! ( items quot n -- bins ) 
-    [ dupd map zip ] dip binpack [ keys ] map ; inline
+: smallest-bin ( bins -- bin )
+    [ total>> ] infimum-by ; inline
 
+: add-to-bin ( item bin -- )
+    [ items>> push ]
+    [ [ second ] dip [ + ] change-total drop ] 2bi ;
+
+:: (binpack) ( alist #bins -- bins )
+    alist sort-values <reversed> :> items
+    #bins [ <bin> ] replicate :> bins
+    items [ bins smallest-bin add-to-bin ] each
+    bins [ items>> keys ] map ;
+
+PRIVATE>
+
+: binpack ( items #bins -- bins )
+    [ dup zip ] dip (binpack) ;
+
+: map-binpack ( items quot: ( item -- weight ) #bins -- bins )
+    [ dupd map zip ] dip (binpack) ; inline