oscpacking-0.1.0.0: Packing.hs

{--
This file is part of the OscPacking library.
Copyright 2016 Christopher Howard.

    OscPacking is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    OscPacking is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with OscPacking.  If not, see <http://www.gnu.org/licenses/>.
--}

module Packing (
  Packing(..),
  defaultPacking,
  pack
  ) where

import Geometry
import System.Random
import Boundary

fit :: Maybe Float -> Point -> [Circle] -> Maybe Boundary -> Maybe Circle
fit cap point srtCircles boundary = fmap
  (\distance -> Circle { position = point, radius = distance })
  (foldr chooseCloser (Just (1/0)) srtCircles)
  where chooseCloser _ Nothing = Nothing
        chooseCloser circle (Just minval) =
          let d = distToCircle point circle in
          if d <= 0
            then Nothing
            else let upperlim = case cap of
                       Nothing -> 1 / 0
                       Just cap' -> cap' in
                   case boundary of
                     Nothing -> Just (min upperlim (min d minval))
                     Just boundary' -> case boundary' point of
                       Nothing -> Nothing
                       Just bDist -> Just (min bDist (min upperlim (min d minval)))

data Packing = Packing {
  boxWidth :: Float,
  boxHeight :: Float,
  capRadius :: Maybe Float,
  boundary :: Maybe Boundary,
  startingCircles :: [Circle],
  seedX :: Int,
  seedY :: Int
  }

defaultPacking :: Packing
defaultPacking = Packing {
  boxWidth = 800.0,
  boxHeight = 600.0,
  capRadius = Nothing,
  boundary = Just (rectB (20, 20) 760 560),
  startingCircles = [Circle { position = (400, 300), radius = 10 }],
  seedX = 1,
  seedY = 2
  }

rndPoints :: Float -> Float -> Int -> Int -> [Point]
rndPoints width height xseed yseed = zip xvals yvals                                     
  where (xgen, ygen) = (mkStdGen xseed, mkStdGen yseed)
        (xvals, yvals) = (randomRs (0, width) xgen, randomRs (0, height) ygen)

-- Provides /infinite/ list of Circles
pack :: Packing -> [Circle]
pack pkg = (startingCircles pkg) ++ build (startingCircles pkg) points
  where points = 
          rndPoints (boxWidth pkg) (boxHeight pkg) (seedX pkg) (seedY pkg)
        build accCircles remPoints =
          case fit (capRadius pkg) (head remPoints) accCircles (boundary pkg) of
            Nothing -> build accCircles (tail remPoints)
            Just circle -> circle : build (circle : accCircles) (tail remPoints)