5 people like it.

Bin Packing

Implementation of the 'best fit' heuristic algorithm for bin packing problems. Incudes an implementation of 'binary tree with duplicates'. See this blog post for details: http://fwaris.wordpress.com/2013/04/01/best-fit-bin-packing/ Update: Bug fixes and added 'worst fit' heuristic implementation

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
130: 
131: 
132: 
133: 
134: 
135: 
136: 
137: 
138: 
139: 
140: 
141: 
142: 
143: 
144: 
145: 
146: 
147: 
148: 
module BinPacking
#nowarn "25"

[<RequireQualifiedAccess>]
module Btd =

    //binary tree with duplicates: key-value, size, left subtree and right subtree
    type T<'a,'b> = T of ('a*'b)*int*T<'a,'b> option*T<'a,'b> option

    type private Direction = Left | Right
    type private Removed<'a,'b> = Removed of T<'a,'b> option | NotRemoved

    let empty = None

    let size t = match t with None -> 0 | Some (T(_,s,_,_)) -> s
    let private (~~) = size

    let toSeq t = 
        [Right,t] |> Seq.unfold (fun path ->
                match path with
                | [_,None] -> None // empty tree so end
                | (Right,Some(T(kv,_,_,None) as t))::rest -> Some(Some(kv),(Left,Some(t))::rest) //can't go right; yield and try to go left
                | (Right,Some(T(_,_,_,r)))::rest ->Some(None,(Right,r)::path) //go right as deep as possible
                | (Left,Some(T(_,_,None,_)))::[] -> None //can't go left and no parent so end
                | (Left,Some(T(_,_,None,_)))::(_,Some(T(kv,_,_,_) as t) )::rest -> Some(Some(kv),(Left,Some(t))::rest) //can't go left so go left at parent after yielding parent's value
                | (Left,Some(T(_,_,l,_)))::rest -> Some(None,(Right,l)::rest) //go right on the left child
                )
        |> Seq.choose (fun s -> s)

    let rec private percolate t path =
        match path with
        | [] -> t
        | (Left,T(kv,s,left,right))::rest ->  percolate (Some (T(kv,s - ~~left + ~~t, t, right))) rest
        | (Right,T(kv,s,left,right))::rest -> percolate (Some (T(kv,s - ~~right + ~~t, left, t))) rest

    let rec private insert (Some (T((ck,_),_,_,_)) as child) t path =
        match t with 
        | None -> percolate child path
        | Some (T((pk,_),_,l,r) as t2) ->
            if ck < pk then insert child l ((Left,t2)::path)
            else insert child r ((Right,t2)::path)

    let add e t = insert (Some(T(e,1,None,None))) t []

    let merge l r =
        match l,r with
        | None, t -> t
        | t, None -> t
        | Some(T(_,ls,_,_)),Some(T(_,rs,_,_)) ->
            if ls < rs then insert r l []
            else insert l r []
            
    let remove kv t =
        let rec remove ((k,v) as kv) t path =
            match t with
            | None -> NotRemoved
            | Some (T((k',v') as kv',_,l,r) as t') ->
                if kv = kv' then Removed(percolate (merge l r) path)
                elif k < k' then remove kv l ((Left,t')::path)
                else remove kv r ((Right,t')::path)
        match remove kv t [] with
        | NotRemoved -> t //failwithf "KV=%A  , T=%A" kv (t|>toSeq|>Seq.toArray)
        | Removed t -> t
    
    let findBestFit c t =
        let rec findBestFit c t currentBest =
            match t with
            | None -> currentBest
            | Some (T((k,v),_,l,r)) ->
                if c = k then Some(k,v)
                elif c < k then findBestFit c l (Some(k,v))
                else findBestFit c r currentBest
        findBestFit c t None

    let rec findWorstFit c t =
        match t with
        | None -> None
        | Some (T((k,v),_,_,None)) -> if k >= c then Some(k,v) else None
        | Some (T(_,_,_,r)) -> findWorstFit c r


type Bin<'a> = {Size:int; Id:string; Data:'a}
type Item<'a> = {Size:int; Data:'a} 

let rec private fillItems (map:Map<Bin<_>,Item<_>list>, t, remaining) fitFunc =
    match remaining with
    | [] -> map, t, []
    | x::rest ->
        match t |> fitFunc x.Size with
        | None -> map,t,remaining
        | Some ((capacity,bin) as kv) -> 
            let remainingCapacity = capacity - x.Size
            let t' = t |> Btd.remove kv |> Btd.add (remainingCapacity,bin)
            let map' = 
                match map |> Map.tryFind bin with
                | None -> map |> Map.add bin [x]
                | Some l -> map |> Map.add bin (x::l)
            fillItems (map', t', rest) fitFunc


///Best fit bin packing uses the tightest possible fit
///It fills one bin and then adds another if needed
let packBestFit (availableBins:Bin<_> list) (items:Item<_> list) =

    let scheduled,capacities,unscheduled = 
        ((Map.empty,Btd.empty,items), availableBins) ||> List.fold (fun (map,t,remaining) bin ->
            match remaining with 
            | [] -> map,t,[] //no more items remaining
            | xs -> fillItems (map,t |> Btd.add (bin.Size,bin),xs) Btd.findBestFit //add a bin to tree and fill items
         ) 
    scheduled |> Map.map (fun k v -> v |> List.rev), capacities, unscheduled


///Worst fit bin packing uses the loosest possible fit
///It spreads the load across all the bins evenly
let packWorstFit (bins:Bin<_> list) (items:Item<_> list) = 

    let binTree = (Btd.empty, bins) ||> List.fold (fun t b -> t |> Btd.add (b.Size,b))
    
    let scheduled,capacities,unscheduled =
        ((Map.empty,binTree,[]),items) ||> List.fold (fun (map,t,acc) item ->
            match t |> Btd.findWorstFit item.Size with
            | Some (capacity, bin) -> 
                let remainingCapacity = capacity - item.Size
                let t' = t |> Btd.remove (capacity, bin) 
                let t'' = t' |> Btd.add (remainingCapacity,bin)
                match map |> Map.tryFind bin with
                | Some xs -> map |> Map.add bin (item::xs), t'', acc
                | None -> map |> Map.add bin [item], t'', acc
            | None -> map, t, item::acc
            )
    scheduled |> Map.map (fun k v -> v |> List.rev), capacities, unscheduled


(* usage:

let bins = [{Size=150; Id="a"; Data="a"}; {Size=235; Id="b"; Data="b"}; {Size=215;Id="c"; Data="c"}]

let rng = System.Random()
let items = [for i in 1..40 -> {Size = rng.Next(1,30); Data=i.ToString()}]

//sort items in descending order of size for best-fit decreasing order
let sortedItems = items |> List.sortBy (fun i -> -i.Size)

let schBest,_,leftOverItemsA = packBestFit bins sortedItems
let schWorst,_,leftOverItemsB = packWorstFit bins sortedItems

*)
module BinPacking
Multiple items
type RequireQualifiedAccessAttribute =
  inherit Attribute
  new : unit -> RequireQualifiedAccessAttribute

Full name: Microsoft.FSharp.Core.RequireQualifiedAccessAttribute

--------------------
new : unit -> RequireQualifiedAccessAttribute
type T<'a,'b> = | T of ('a * 'b) * int * T<'a,'b> option * T<'a,'b> option

Full name: BinPacking.Btd.T<_,_>
union case T.T: ('a * 'b) * int * T<'a,'b> option * T<'a,'b> option -> T<'a,'b>
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
type private Direction =
  | Left
  | Right

Full name: BinPacking.Btd.Direction
union case Direction.Left: Direction
union case Direction.Right: Direction
Multiple items
union case Removed.Removed: T<'a,'b> option -> Removed<'a,'b>

--------------------
type private Removed<'a,'b> =
  | Removed of T<'a,'b> option
  | NotRemoved

Full name: BinPacking.Btd.Removed<_,_>
union case Removed.NotRemoved: Removed<'a,'b>
val empty : 'a option

Full name: BinPacking.Btd.empty
union case Option.None: Option<'T>
val size : t:T<'a,'b> option -> int

Full name: BinPacking.Btd.size
val t : T<'a,'b> option
union case Option.Some: Value: 'T -> Option<'T>
val s : int
val toSeq : t:T<'a,'b> option -> seq<'a * 'b>

Full name: BinPacking.Btd.toSeq
module Seq

from Microsoft.FSharp.Collections
val unfold : generator:('State -> ('T * 'State) option) -> state:'State -> seq<'T>

Full name: Microsoft.FSharp.Collections.Seq.unfold
val path : (Direction * T<'a,'b> option) list
val kv : 'a * 'b
val t : T<'a,'b>
val rest : (Direction * T<'a,'b> option) list
val r : T<'a,'b> option
val l : T<'a,'b> option
val choose : chooser:('T -> 'U option) -> source:seq<'T> -> seq<'U>

Full name: Microsoft.FSharp.Collections.Seq.choose
val s : ('a * 'b) option
val private percolate : t:T<'a,'b> option -> path:(Direction * T<'a,'b>) list -> T<'a,'b> option

Full name: BinPacking.Btd.percolate
val path : (Direction * T<'a,'b>) list
val left : T<'a,'b> option
val right : T<'a,'b> option
val rest : (Direction * T<'a,'b>) list
val private insert : T<'a,'b> option -> t:T<'a,'b> option -> path:(Direction * T<'a,'b>) list -> T<'a,'b> option (requires comparison)

Full name: BinPacking.Btd.insert
val ck : 'a (requires comparison)
val child : T<'a,'b> option (requires comparison)
val t : T<'a,'b> option (requires comparison)
val path : (Direction * T<'a,'b>) list (requires comparison)
val pk : 'a (requires comparison)
val l : T<'a,'b> option (requires comparison)
val r : T<'a,'b> option (requires comparison)
val t2 : T<'a,'b> (requires comparison)
val add : 'a * 'b -> t:T<'a,'b> option -> T<'a,'b> option (requires comparison)

Full name: BinPacking.Btd.add
val e : 'a * 'b (requires comparison)
val merge : l:T<'a,'b> option -> r:T<'a,'b> option -> T<'a,'b> option (requires comparison)

Full name: BinPacking.Btd.merge
val ls : int
val rs : int
val remove : 'a * 'b -> t:T<'a,'b> option -> T<'a,'b> option (requires comparison and equality)

Full name: BinPacking.Btd.remove
val kv : 'a * 'b (requires comparison and equality)
val t : T<'a,'b> option (requires comparison and equality)
val remove : ('c * 'd -> T<'c,'d> option -> (Direction * T<'c,'d>) list -> Removed<'c,'d>) (requires comparison and equality)
val k : 'c (requires comparison)
val v : 'd (requires equality)
val kv : 'c * 'd (requires comparison and equality)
val t : T<'c,'d> option (requires comparison and equality)
val path : (Direction * T<'c,'d>) list (requires comparison and equality)
val k' : 'c (requires comparison)
val v' : 'd (requires equality)
val kv' : 'c * 'd (requires comparison and equality)
val l : T<'c,'d> option (requires comparison and equality)
val r : T<'c,'d> option (requires comparison and equality)
val t' : T<'c,'d> (requires comparison and equality)
val findBestFit : c:'a -> t:T<'a,'b> option -> ('a * 'b) option (requires comparison)

Full name: BinPacking.Btd.findBestFit
val c : 'a (requires comparison)
val findBestFit : ('c -> T<'c,'d> option -> ('c * 'd) option -> ('c * 'd) option) (requires comparison)
val c : 'c (requires comparison)
val t : T<'c,'d> option (requires comparison)
val currentBest : ('c * 'd) option (requires comparison)
val v : 'd
val l : T<'c,'d> option (requires comparison)
val r : T<'c,'d> option (requires comparison)
val findWorstFit : c:'a -> t:T<'a,'b> option -> ('a * 'b) option (requires comparison)

Full name: BinPacking.Btd.findWorstFit
val k : 'a (requires comparison)
val v : 'b
type Bin<'a> =
  {Size: int;
   Id: string;
   Data: 'a;}

Full name: BinPacking.Bin<_>
Bin.Size: int
Bin.Id: string
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string
Multiple items
Bin.Data: 'a

--------------------
namespace Microsoft.FSharp.Data
type Item<'a> =
  {Size: int;
   Data: 'a;}

Full name: BinPacking.Item<_>
Item.Size: int
Multiple items
Item.Data: 'a

--------------------
namespace Microsoft.FSharp.Data
val private fillItems : map:Map<Bin<'a>,Item<'b> list> * t:Btd.T<int,Bin<'a>> option * remaining:Item<'b> list -> fitFunc:(int -> Btd.T<int,Bin<'a>> option -> (int * Bin<'a>) option) -> Map<Bin<'a>,Item<'b> list> * Btd.T<int,Bin<'a>> option * Item<'b> list (requires comparison)

Full name: BinPacking.fillItems
val map : Map<Bin<'a>,Item<'b> list> (requires comparison)
Multiple items
module Map

from Microsoft.FSharp.Collections

--------------------
type Map<'Key,'Value (requires comparison)> =
  interface IEnumerable
  interface IComparable
  interface IEnumerable<KeyValuePair<'Key,'Value>>
  interface ICollection<KeyValuePair<'Key,'Value>>
  interface IDictionary<'Key,'Value>
  new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>
  member Add : key:'Key * value:'Value -> Map<'Key,'Value>
  member ContainsKey : key:'Key -> bool
  override Equals : obj -> bool
  member Remove : key:'Key -> Map<'Key,'Value>
  ...

Full name: Microsoft.FSharp.Collections.Map<_,_>

--------------------
new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
val t : Btd.T<int,Bin<'a>> option (requires comparison)
val remaining : Item<'b> list
val fitFunc : (int -> Btd.T<int,Bin<'a>> option -> (int * Bin<'a>) option) (requires comparison)
val x : Item<'b>
val rest : Item<'b> list
val capacity : int
val bin : Bin<'a> (requires comparison)
val kv : int * Bin<'a> (requires comparison)
val remainingCapacity : int
val t' : Btd.T<int,Bin<'a>> option (requires comparison)
module Btd

from BinPacking
val remove : 'a * 'b -> t:Btd.T<'a,'b> option -> Btd.T<'a,'b> option (requires comparison and equality)

Full name: BinPacking.Btd.remove
val add : 'a * 'b -> t:Btd.T<'a,'b> option -> Btd.T<'a,'b> option (requires comparison)

Full name: BinPacking.Btd.add
val map' : Map<Bin<'a>,Item<'b> list> (requires comparison)
val tryFind : key:'Key -> table:Map<'Key,'T> -> 'T option (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.tryFind
val add : key:'Key -> value:'T -> table:Map<'Key,'T> -> Map<'Key,'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.add
val l : Item<'b> list
val packBestFit : availableBins:Bin<'a> list -> items:Item<'b> list -> Map<Bin<'a>,Item<'b> list> * Btd.T<int,Bin<'a>> option * Item<'b> list (requires comparison)

Full name: BinPacking.packBestFit


Best fit bin packing uses the tightest possible fit
It fills one bin and then adds another if needed
val availableBins : Bin<'a> list (requires comparison)
val items : Item<'b> list
val scheduled : Map<Bin<'a>,Item<'b> list> (requires comparison)
val capacities : Btd.T<int,Bin<'a>> option (requires comparison)
val unscheduled : Item<'b> list
val empty<'Key,'T (requires comparison)> : Map<'Key,'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.empty
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val fold : folder:('State -> 'T -> 'State) -> state:'State -> list:'T list -> 'State

Full name: Microsoft.FSharp.Collections.List.fold
val xs : Item<'b> list
val findBestFit : c:'a -> t:Btd.T<'a,'b> option -> ('a * 'b) option (requires comparison)

Full name: BinPacking.Btd.findBestFit
val map : mapping:('Key -> 'T -> 'U) -> table:Map<'Key,'T> -> Map<'Key,'U> (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.map
val k : Bin<'a> (requires comparison)
val v : Item<'b> list
val rev : list:'T list -> 'T list

Full name: Microsoft.FSharp.Collections.List.rev
val packWorstFit : bins:Bin<'a> list -> items:Item<'b> list -> Map<Bin<'a>,Item<'b> list> * Btd.T<int,Bin<'a>> option * Item<'b> list (requires comparison)

Full name: BinPacking.packWorstFit


Worst fit bin packing uses the loosest possible fit
It spreads the load across all the bins evenly
val bins : Bin<'a> list (requires comparison)
val binTree : Btd.T<int,Bin<'a>> option (requires comparison)
val b : Bin<'a> (requires comparison)
val acc : Item<'b> list
val item : Item<'b>
val findWorstFit : c:'a -> t:Btd.T<'a,'b> option -> ('a * 'b) option (requires comparison)

Full name: BinPacking.Btd.findWorstFit
val t'' : Btd.T<int,Bin<'a>> option (requires comparison)

More information

Link:http://fssnip.net/hG
Posted:4 years ago
Author:Faisal Waris
Tags: scheduling , optimization , bin packing , binary tree