extra/rosetta-code/knapsack-unbounded/knapsack-unbounded.factor

   1 ! Copyright (c) 2012 Anonymous
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators kernel math math.order
   4 math.vectors sequences sequences.product combinators.short-circuit ;
   5 IN: rosetta-code.knapsack-unbounded
   6
   7 ! http://rosettacode.org/wiki/Knapsack_problem/Unbounded
   8
   9 ! A traveller gets diverted and has to make an unscheduled stop
  10 ! in what turns out to be Shangri La. Opting to leave, he is
  11 ! allowed to take as much as he likes of the following items, so
  12 ! long as it will fit in his knapsack, and he can carry it. He
  13 ! knows that he can carry no more than 25 'weights' in total; and
  14 ! that the capacity of his knapsack is 0.25 'cubic lengths'.
  15
  16 ! Looking just above the bar codes on the items he finds their
  17 ! weights and volumes. He digs out his recent copy of a financial
  18 ! paper and gets the value of each item.
  19
  20 ! He can only take whole units of any item, but there is much
  21 ! more of any item than he could ever carry
  22
  23 ! How many of each item does he take to maximize the value of
  24 ! items he is carrying away with him?
  25
  26 ! Note:
  27
  28 ! There are four solutions that maximize the value taken. Only
  29 ! one need be given.
  30
  31 CONSTANT: values { 3000 1800 2500 }
  32 CONSTANT: weights { 0.3 0.2 2.0 }
  33 CONSTANT: volumes { 0.025 0.015 0.002 }
  34
  35 CONSTANT: max-weight 25.0
  36 CONSTANT: max-volume 0.25
  37
  38 TUPLE: bounty amounts value weight volume ;
  39
  40 : <bounty> ( items -- bounty )
  41     [ bounty new ] dip {
  42         [ >>amounts ]
  43         [ values vdot >>value ]
  44         [ weights vdot >>weight ]
  45         [ volumes vdot >>volume ]
  46     } cleave ;
  47
  48 : valid-bounty? ( bounty -- ? )
  49     { [ weight>> max-weight <= ]
  50       [ volume>> max-volume <= ] } 1&& ;
  51
  52 M:: bounty <=> ( a b -- <=> )
  53     a valid-bounty? [
  54         b valid-bounty? [
  55             a b [ value>> ] compare
  56         ] [ +gt+ ] if
  57     ] [ b valid-bounty? +lt+ +eq+ ? ] if ;
  58
  59 : find-max-amounts ( -- amounts )
  60     weights volumes [
  61         [ max-weight swap / ]
  62         [ max-volume swap / ] bi* min >integer
  63     ] 2map ;
  64
  65 : best-bounty ( -- bounty )
  66     find-max-amounts [ 1 + <iota> ] map <product-sequence>
  67     [ <bounty> ] [ max ] map-reduce ;