Elm 2D Bin Packing

BinPack.elm

module BinPack exposing (..)


import Browser
import Html exposing (Html, button, div, text, input)
import Html.Attributes as H exposing (..)
import Html.Events exposing (onClick)
import Random
import Svg exposing (..)
import Svg.Attributes as S exposing (..)
import Task



type BinPack a
    = Node { w : Float, h : Float, r : BinPack a, b : BinPack a } a
    | Free { w : Float, h : Float }


foldBinPack : (a -> b -> b) -> b -> BinPack a -> b
foldBinPack f =
  foldBinPack1 (\bp prev ->
    case bp of
      Node _ v -> f v prev
      Free _ -> prev
  )


foldBinPack1 : (BinPack a -> b -> b) -> b -> BinPack a -> b
foldBinPack1 f i bp =
  case bp of
    Node { r, b } _ ->
      let
        current = f bp i
        fromR = foldBinPack1 f current r
        fromB = foldBinPack1 f fromR b
      in fromB
    Free _ -> f bp i


type alias Occupied
    = { x : Float
          , y : Float
          , w : Float
          , h : Float
          }


unfoldBinPack : ( ( a, Occupied ) -> k -> k) -> k -> BinPack a -> k
unfoldBinPack f =
    let
        helper x y v bp =
           case bp of
               Free _ -> v
               Node n i ->
                   f ( i, { x = x, y = y, w = n.w, h = n.h } )
                       <| helper x (y + n.h) (helper (x + n.w) y v n.r) n.b
    in helper 0 0


unpack : BinPack a -> List (a, Occupied)
unpack = unfoldBinPack (::) []


-- MAIN


main : Program () Model Msg
main =
    Browser.element
      { init = always init
      , update = update
      , view = view
      , subscriptions = always Sub.none
      }


container w h = Free { w = w, h = h }


node w h r b a =
    Node { w = w, h = h, r = r, b = b } a



pack : Rect -> Model -> Maybe Model
pack rect model =
    case model of
        Free f ->
            let
                fits = rect.width <= f.w && rect.height <= f.h
                pright = container (f.w - rect.width) rect.height
                pbelow = container f.w (f.h - rect.height)
            in
                if fits
                then Just <| node rect.width rect.height pright pbelow rect.color
                else Nothing
        Node n v ->
            case pack rect n.r of
                Just newR -> Just <| node n.w n.h newR n.b v
                Nothing ->
                    case pack rect n.b of
                        Just newB -> Just <| node n.w n.h n.r newB v
                        Nothing -> Nothing


pack1 : Rect -> Model -> Model
pack1 rect model =
    pack rect model |> Maybe.withDefault model

-- MODEL


type alias Color = String


type alias Rect =
    { width : Float
    , height : Float
    , color : Color
    }


type alias Model =
    BinPack Color


init : ( Model, Cmd Msg )
init =
    ( container 0 0
    , Task.succeed () 
        |> Task.perform (always Randomize)
    )


-- UPDATE


randomColor : Random.Generator Color
randomColor =
    Random.map3
        (\r g b -> 
            "rgb(" ++ String.fromFloat (r * 255) ++ 
            ","  ++ String.fromFloat (g * 255) ++ 
            ","  ++ String.fromFloat (b * 255) ++ 
            ")")
        (Random.float 0 1)
        (Random.float 0 1)
        (Random.float 0 1)        


randomRect : Random.Generator Rect
randomRect = 
    Random.map3
        Rect
        (Random.float 0 70)
        (Random.float 0 70)        
        randomColor


random : Random.Generator (List Rect)
random =
    Random.int 10 60
      |> Random.andThen 
          (\len -> Random.list len randomRect)


type Msg
  = Randomize 
  | Pack (List Rect)
  | Error Rect


update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
  case msg of
    Randomize ->
       ( container 300 300
       , Random.generate 
            Pack
            random
       )
  
    Pack rects ->
      ( rects 
          |> List.foldl pack1 model
      , Cmd.none 
      )

    Error rect ->
      ( model, Cmd.none )


-- VIEW


view : Model -> Html Msg
view model =
    let
        viewItem (color, occ)
            = Svg.rect
                [ S.x <| String.fromFloat occ.x
                , S.y <| String.fromFloat occ.y
                , S.width <| String.fromFloat occ.w
                , S.height <| String.fromFloat occ.h
                , S.fill color
                , S.strokeWidth "1"
                , S.stroke "black"
                ]
                []
    in
        div 
            []
            [ input [ H.type_ "button", onClick Randomize, H.value "Next" ] [ Html.text "Random" ]
            , svg [ S.width "300", S.height "300" ]
                 <| List.map viewItem
                 <| unpack model
            ]