Packing.hs

{-|
Module      : Graphics.OscPacking.Packing
Description : Core packing functionality
Copyright   : (c) Christopher Howard, 2016
License     : GPL-3
Maintainer  : ch.howard@zoho.com
-}

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

import Prelude (tail, head, (++), Maybe (..), zip, Int, Float, min, (/), (<=), foldr, fmap)
import Graphics.OscPacking.Geometry
import System.Random (mkStdGen, randomRs)
import Graphics.OscPacking.Boundary

-- |Attempt to create a new Circle at specified Point. If the Point is
-- inside an existing circle, or does not fit a specified Boundary,
-- return Nothing
fit :: Maybe Float -- ^ An optional maximum radius for new circles
       -> Point -- ^ The point where we will attempt to place the circle
       -> [Circle] -- ^ the circles into which we are attempting to fit the new circle
       -> Maybe Boundary -- ^ An optional 'Boundary' for circle placement
       -> Maybe Circle
fit cap point srtCircles bound = 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 bound of
                     Nothing -> Just (min upperlim (min d minval))
                     Just bound' -> case bound' point of
                       Nothing -> Nothing
                       Just bDist -> Just (min bDist (min upperlim (min d minval)))

-- |The initializing parameters for a particular packing image, minus
-- the actual display parameters such as color.
data Packing = Packing {
  boxWidth :: Float,
  boxHeight :: Float,
  capRadius :: Maybe Float,
  boundary :: Maybe Boundary,
  startingCircles :: [Circle],
  seedX :: Int,
  seedY :: Int
  }

-- |Some sensible default parameters provided for convenience.
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
  }


-- |Generates an infinite list of random points within some area.
rndPoints :: Float -- ^ width
             -> Float -- ^ height
             -> Int -- ^ seed value of x-value generator
             -> Int -- ^ seed value of y-value generator
             -> [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)

-- |Generates an infinite list of circles, using a packing algorithm
pack :: Packing -- ^ initialization parameters
        -> [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)