path: root/ipl/gprogs/binpack.icn

############################################################################
#
#	File:     binpack.icn
#
#	Subject:  Program to demonstrate some bin packing algorithms
#
#	Author:   Gregg M. Townsend
#
#	Date:     June 23, 2000
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#  Usage:  binpack [window options]
#
#  Binpack illustrates several approximation algorithms for solving the
#  one-dimensional bin packing problem.
#
#  For references, see the "info" screen.
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Links: numbers, graphics, random, vsetup
#
############################################################################

link numbers
link graphics
link random
link vsetup

$define Version "Binpack, Version 1.0  (September, 1993)"

$define MAXK 250	# max value of `k' allowed

$define FULL 61261200	# value representing a full bin
			# (least common multiple of {1 to 18, 20, and 25})

$define X0 120		# left edge of bin display
$define DY 165		# vertical spacing
$define YSCALE 155	# scaling for one display

$define BX1 10		# x-coord for first button column
$define BX2 60		# x-coord for second button column
$define BWIDTH 40	# button width
$define BHEIGHT 16	# button height
$define BSPACE 16	# button spacing


# parameter values
global maxsize		# maximum piece size
global nreload		# number of pieces on a reload
global kvalue		# constant `k' used in some algorithms

# current source set
global pieces		# list of piece sizes
global dx		# distance between bins
global bwidth		# bin width
global cdiv		# divisor for converting size to color index

# current output parameters
global bin		# list of current bin sizes
global nfilled		# number of bins (partially) filled
global xll, yll		# lower left corner of display area


# miscellany
global width		# window width
global color		# array of GCs of different colors
global glossary		# list of explanations



#   Future possibilities:
#
#   better layout -- critical controls are too crowded
#   add artificial delays for better visualization
#   implement O(n log n) algs as such instead of O(n^2)
#	n.b. this may not help because can't use Icon's native data structs



#########################  main program  #########################

procedure main(args)
   local v, r, c, gc

   randomize()				# set irreproducible mode

   v := ui(args)			# open window, set up vib-built vidgets
   r := v["root"]
   glossary := []
   addbutton(r, "BF", bestfit, "Best Fit", "picks the fullest possible bin")
   addbutton(r, "WF", worstfit, "Worst Fit", "picks the emptiest bin")
   addbutton(r, "AWF",nearworst,"Almost Worst Fit", "picks second-emptiest bin")
   addbutton(r, "FF", firstfit, "First Fit", "picks the oldest possible bin")
   addbutton(r, "LF", lastfit, "Last Fit", "picks the newest possible bin")
   addbutton(r, "NF", nextfit, "Next Fit", "tries only the current bin")
   addbutton(r, "N(k)", nextk, "Next-k Fit", "tries the k newest bins")
   addbutton(r, "H(k)", harmonic, "Harmonic Algorithm",
      "classifies into {1/1,1/2,...,1/k}")
   addbutton(r, "G(k)", gxfit, "Group-X Fit", "groups into k equal classes")
   VResize(r)

   # workaround freeing of gray highlight color seen with "binpack -Bwhite"
   BevelReset()				# work around color freeing bug

   color := []
   if WAttrib("depth") = 1 then
      put(color, &window)
   else {
      # make a set of colors for different bin heights
      # note that exactly half are reds/yellows and half are blues & darker
      every c := Blend(
            "black", 1, "deep purple-magenta", 10, "cyan-blue",
            1, "reddish-yellow", 11, "orange-red") do {
         gc := Clone(&window)
         Shade(gc, c)
         put(color, gc)
         }
      color := copy(color)		# ensure contiguous
      }

   # keep the following initializations in sync with initial slider positionm
   setmax(v["max"], 20)			# set maximum bin value
   setbins(v["bins"], -100)		# set number of bins
   setk(v["kval"], -10)			# set constant `k' value

   reload()				# initialize random bins
   status("")				# display bin count

   &error := 1
   WAttrib("resize=on")
   &error := 0

   r.V.event := 1			# disable screen erase on resize
   GetEvents(r, leftover)		# enter event loop
end


#  addbutton -- add a button (and a D variant) on every shelf

procedure addbutton(r, label, proc, name, defn)
   local v, n, y
   static yoff
   initial yoff := 0

   y := yoff +:= BSPACE
   while (y +:= DY) < WAttrib("height") do {
      Vbutton(r, BX1, y, r.win, label, pack, proc, V_RECT, BWIDTH, BHEIGHT)
      Vbutton(r, BX2, y, r.win, label||"D", pack, proc, V_RECT, BWIDTH, BHEIGHT)
      }
   put(glossary, left(label, 6) || left(name, 20) || defn)
   return
end



#########################  parameter setting  #########################

#  These routines are called during initialization and in response to
#  slider movement.


#  setk(v, n) -- set value of constant `k', based on 1 - 100 slider scale

procedure setk(v, n)
   if n >= 0 then				# if slider call
      n := integer(MAXK ^ ((n / 100.0) ^ 0.70))	# convert nonlinearly
   else
      n := -n					# initial call
   kvalue := roundoff(n)
   GotoXY(v.ax, v.ay + v.ah + 14)
   WWrites(left("k=" || kvalue, 8))
   return
end


#  setmax(v, n) -- set maxsize, based on 1 - 20 slider scale.

procedure setmax(v, n)
   local fract

   fract := n / 20.0
   maxsize := integer(fract * FULL)
   GotoXY(v.ax, v.ay + v.ah + 14)
   WWrites(" max size ", ((fract || "00") ? move(4)))
   return
end


#  setbins(v, n) -- set number of bins, based on 1 - 100 slider scale

procedure setbins(v, n)
   local s, max

   max := WAttrib("width") - 40 - X0		# max that will fit on screen
   if &shift then				# allow more if shifted
      max /:= 1.1 * (maxsize / (2.0 * FULL))

   if n >= 0 then				# if slider call
      n := integer(max ^ ((n / 100.0) ^ 0.40))	# convert nonlinearly
   else
      n := -n					# initial call
   n <:= 5
   n := roundoff(n, 5)				# convert to round number

   nreload := n
   s := center(nreload, 5)
   GotoXY(v.ax + (v.aw - TextWidth(s)) / 2, v.ay + v.ah + 17)
   WWrites(s)
   return
end


#  roundoff(n) -- truncate n to a nice number divisible by m (at least)

procedure roundoff(n, m)
   local d

   if n > 1000 then {
      if n > 10000 then
         d := 1000
      else if n > 5000 then
         d := 500
      else
         d := 100
      }
   else if n > 500 then
      d := 50
   else if n > 100 then
      d := 10
   else if n > 50 then
      d := 5
   n -:= n % \d
   n -:= n % \m
   return n
end


#########################  bin packing primitives  #########################


#  empty(n) -- empty shelf n

procedure empty(n)
   bin := list(*pieces, 0)
   nfilled := 0
   xll := X0
   yll := n * DY
   EraseArea(xll, yll - DY + 1, , DY)
   width := WAttrib("width")
   return
end


#  place(p, b) -- add a piece of size p to bin b

procedure place(p, b)
   local o, t, x, y0, y1
   static invfull
   initial invfull := 1.0 / FULL

   o := bin[b] | fail
   if (t := o + p) > FULL then
      fail
   bin[b] := t
   nfilled <:= b
   if (x := xll + (b - 1) * dx) < width then {
      y0 := integer(yll - YSCALE * o * invfull)
      y1 := integer(yll - YSCALE * t * invfull) + 1
      FillRectangle(color[p / cdiv + 1], x, y1, bwidth, 0 < (y0 - y1))
      }
   return
end


#  status(s) -- write string s and shelf population at end of output shelf

procedure status(s)
   local x

   x := xll + nfilled * dx + 4
   x >:= width - 40
   GotoXY(x, yll - 15)
   WWrites(s)
   GotoXY(x, yll)
   WWrites(nfilled)
   return
end



#########################  source set manipulation  #########################


#  reload() -- reload first shelf with random-sized pieces.

procedure reload()
   local i, j, z, p

   pieces := list(nreload)
   empty(1)
   dx := (width - 40 - X0) / nreload
   dx <:= 1
   dx >:= 20
   bwidth := 4 * dx / 5
   bwidth <:= 1
   cdiv := (maxsize + *color - 1) / *color
   every place(pieces[i := 1 to *pieces] := ?maxsize, i)
   status("new")
   return
end


#  mix() -- randomly reorder the first shelf.
#
#  if shifted, place equally-spaced using golden ratio

procedure mix()
   local i, n, p

   if &shift then {
      n := integer(*pieces / &phi + 1)
      while gcd(*pieces, n) > 1 do
         n -:= 1
      i := 0
      every p := !sort(pieces) do {
         i := (i + n) % *pieces
         pieces[i + 1] := p
         }
      }
   else
      every i := *pieces to 2 by -1 do
         pieces[?i] :=: pieces[i]

   empty(1)
   every place(pieces[i := 1 to *pieces], i)
   status("mix")
   return
end



#  order() -- sort the first shelf in descending order
#
#  if shifted, sort ascending

procedure order()
   local i

   pieces := sort(pieces)
   if not &shift then
      every i := 1 to *pieces / 2 do	# change from ascending to descending
         pieces[i] :=: pieces[-i]

   empty(1)
   every place(pieces[i := 1 to *pieces], i)
   status("sort")
   return
end



#########################  packing algorithms  #########################



#  pack(x, v) -- execute packing algorithm connected with button x

procedure pack(x, v)
   local l, n, s, i

   if x.ax = BX2 then {
      l := sort(pieces)			# if second-column button, sort first
      every i := 1 to *l/2 do		# change from ascending to descending
         l[i] :=: l[-i]
      }
   else
      l := copy(pieces)

   n := x.ay / DY + 1			# compute shelf number
   empty(n)				# clear the shelf

   s := x.id(l)				# call packing algorithm
   status(\s | x.s)			# display status
   return
end


#  nextfit(l) -- pack using next-fit algorithm

procedure nextfit(l)
   local p

   every p := !l do
      place(p, nfilled | nfilled + 1)
   return
end


#  nextk(l) -- pack using next-k-fit algorithm

procedure nextk(l)
   local p

   every p := !l do
      if nfilled <= kvalue then
         place(p, 1 to nfilled + 1)
      else
         place(p, nfilled - kvalue + 1 to nfilled + 1)
   return "N" || kvalue
end


#  firstfit(l) -- pack using first-fit algorithm

procedure firstfit(l)
   local p

   every p := !l do
      place(p, 1 to nfilled + 1)
   return
end


#  lastfit(l) -- pack using last-fit algorithm

procedure lastfit(l)
   local p

   every p := !l do
      place(p, (nfilled to 1 by -1) | (nfilled + 1))
   return
end


#  bestfit(l) -- pack using best-fit algorithm

procedure bestfit(l)
   local p, b, i, max, found

   every p := !l do {
      max := FULL - p			# fullest acceptable bin size
      found := 0			# size of best bin found so far
      b := nfilled + 1			# index of where found
      every i := 1 to nfilled do
         if found <:= (max >= bin[i]) then
            b := i
      place(p, b)			# place in best bin found
      }
   return
end


#  worstfit(l, n) -- pack using worst-fit algorithm

procedure worstfit(l, n)
   local p, b, i, found

   every p := !l do {
      found := FULL - p			# size of best bin found so far
      b := nfilled + 1			# index of where found
      every i := 1 to nfilled do
         if found >:= bin[i] then
            b := i
      place(p, b)			# place in best bin found
      }
   return
end


#  nearworst(l, n) -- pack using almost-worst-fit algorithm

procedure nearworst(l, n)
   local p, a, b, i, found

   every p := !l do {
      found := FULL - p			# size of best bin found so far
      a := b := &null
      every i := 1 to nfilled do
         if found >:= bin[i] then {
            a := b
            b := i
            }
      place(p, \a | \b | (nfilled + 1))	# place in second-best bin found
      }
   return
end


#  harmonic(l, n) -- pack using (unmodified) harmonic algorithm

procedure harmonic(l, n)
   local curr, maxv, i, p, b

   curr := list(kvalue)			# current bin for each class
   maxv := list(kvalue)			# maximum for each class
   every i := 1 to kvalue do
      maxv[i] := FULL / (kvalue - i + 1)

   every p := !l do {
      p <= maxv[i := 1 to kvalue]	# find class index i
      b := curr[i]
      if /b | (bin[b] + p > FULL) then
         place(p, curr[i] := nfilled + 1)
      else
         place(p, b)
      }
   return "H" || kvalue
end


#  gxfit(l, n) -- pack using group-x(k)-fit algorithm

procedure gxfit(l, n)
   local stk, maxv, i, s, p, b, d

   stk := []				# stacks of bins, one for each group
   maxv := []				# maximum for each group

   # make k equally sized groups
   d := FULL / kvalue
   every i := 1 to kvalue do {
      put(stk, [])
      put(maxv, i * d - 1)
      }

   every p := !l do {
      # find group index i for piece
      (p <= maxv[i := (1 to kvalue) | 0]) & (*stk[i] > 0)
      b := pop(stk[i]) | (nfilled + 1)
      place(p, b)
      # now put bin back on a stack, if not too full
      if (FULL - bin[b]) >= maxv[i := (kvalue - 1 to 1 by -1)] then
         push(stk[i], b)
      }
   return "G" || kvalue
end



#########################  event miscellany  #########################



#===<<vib:begin>>===	modify using vib; do not remove this marker line
procedure ui(win, cbk)
return vsetup(win, cbk,
   [":Sizer:lucidasanstypewriter-bold-12::0,0,860,675:Bin Packing",],
   ["bins:Slider:h::10,48,100,15:0,100,40",setbins],
   ["infob:Button:regular::10,111,40,17:info",info],
   ["kval:Slider:h::10,135,100,15:0,100,30",setk],
   ["max:Slider:h::10,10,100,15:1,20,20",setmax],
   ["mix:Button:regular::10,68,30,17:mix",mix],
   ["new:Button:regular::80,68,30,17:new",reload],
   ["quit:Button:regular::70,110,40,17:quit",quit],
   ["sort:Button:regular::10,87,35,17:sort",order],
   )
end
#===<<vib:end>>===	end of section maintained by vib



#  leftover() -- handle events that fall outside the vidgets
#
#  Exits when certain keys are pressed and ignores other events.

procedure leftover(e)
   case e of {
      QuitEvents():	exit()
      &meta & !"nN":	reload()
      &meta & !"mM":	mix()
      &meta & !"sS":	order()
      &meta & !"iI":	info()
      }
   return
end


#  quit() -- handle "quit" button press

procedure quit(x, v)
   exit()
end


#  info() -- handle "info" button press

procedure info(x, v)
   static text
   initial {
      text := ["",
         Version,
         "by Gregg Townsend, The University of Arizona",
         "",
         "",
         "Glossary:",
         ""]
      every put(text, "   " || !glossary)
      put(text,
         "",
         "A `D' suffix indicates a variation where the input is sorted",
         "in descending order before applying the algorithm.",
         "",
         "",
         "For more information about bin packing algorithms, see:",
         "",
         "   `Approximation Algorithms for Bin-Packing -- An Updated Survey'",
         "   by E.G. Coffman, Jr., M.R. Garey, and D.S. Johnson, in",
         "   Algorithm Design for Computer System Design, ed. by",
         "   Ausiello, Lucertini, and Serafini, Springer-Verlag, 1984",
         "",
         "   `Fast Algorithms for Bin Packing' by David S. Johnson,",
         "   Journal of Computer and System Sciences 8, 272-314 (1974)",
         "")
      }
   Notice ! text
   return
end