diff --git a/extra/math/binpack/binpack-docs.factor b/extra/math/binpack/binpack-docs.factor index d995cab59d..48786b5bdd 100644 --- a/extra/math/binpack/binpack-docs.factor +++ b/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." } ; diff --git a/extra/math/binpack/binpack-tests.factor b/extra/math/binpack/binpack-tests.factor index d0d4630484..06101450fb 100644 --- a/extra/math/binpack/binpack-tests.factor +++ b/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 diff --git a/extra/math/binpack/binpack.factor b/extra/math/binpack/binpack.factor index 5f1ec0c017..0d797db05e 100644 --- a/extra/math/binpack/binpack.factor +++ b/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 ; + :> values - values length :> #values - n #values n / ceiling [ ] map :> bins - values [ bins (binpack) ] each - bins ; +TUPLE: bin items total ; -: binpack* ( items n -- bins ) - [ dup zip ] dip binpack [ keys ] map ; +: ( -- 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 :> items + #bins [ ] 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