module Layout.Floorplan where
import Control.Arrow ((***))
import Control.Monad.Writer
import Data.Hardware.Internal
data Alignment
= BottomLeft
| TopRight
deriving (Eq, Show)
newtype Elasticity = Elasticity Int
deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
data Distance
= Dist Length
deriving (Eq, Show)
data Block spaceSize s b
= Space spaceSize (Maybe s)
| Box Size Orientation Name b
deriving (Eq, Show)
type RelBlock s b = Block Distance s b
type AbsBlock s b = Block (Angle,Length) s b
data Placement
= Unspecified
| Stack Alignment Alignment
| Row Direction Alignment
deriving (Eq, Show)
data Floorplan s b
= Block (RelBlock s b)
| Comb Placement [Floorplan s b]
deriving (Eq, Show)
type AbsFloorplan s b = [(Position, AbsBlock s b)]
class Transformable a
where
flipX :: a -> a
flipY :: a -> a
rotate_ :: Int -> a -> a
instance Transformable Direction
where
flipX Rightwards = Leftwards
flipX Leftwards = Rightwards
flipX dir = dir
flipY Upwards = Downwards
flipY Downwards = Upwards
flipY dir = dir
rotate_ n dir = iterate rot dir !! n
where
rot Rightwards = Upwards
rot Leftwards = Downwards
rot Upwards = Leftwards
rot Downwards = Rightwards
instance Transformable Orientation
where
flipX (flipped,dir) = (not flipped, dir)
flipY (flipped,Upwards) = (not flipped, Downwards)
flipY (flipped,Downwards) = (not flipped, Upwards)
flipY (flipped,Leftwards) = (not flipped, Rightwards)
flipY (flipped,Rightwards) = (not flipped, Leftwards)
rotate_ n (flipped,dir) = (flipped, rotate_ n dir)
instance Transformable (RelBlock s b)
where
flipX (Box sz ori nm b) = Box sz (flipX ori) nm b
flipX bl = bl
flipY (Box sz ori nm b) = Box sz (flipY ori) nm b
flipY bl = bl
rotate_ n (Box wh@(w,h) ori nm b) = Box wh' (rotate_ n ori) nm b
where
wh' = if even n then wh else (h,w)
rotate_ n bl = bl
instance Transformable Placement
where
flipX (Stack alx aly) = Stack (flipAlignment alx) aly
flipX (Row Rightwards al) = Row Leftwards al
flipX (Row Leftwards al) = Row Rightwards al
flipX (Row up_down al) = Row up_down (flipAlignment al)
flipX pl = pl
flipY (Stack alx aly) = Stack alx (flipAlignment aly)
flipY (Row Upwards al) = Row Downwards al
flipY (Row Downwards al) = Row Upwards al
flipY (Row left_right al) = Row left_right (flipAlignment al)
flipY pl = pl
rotate_ n pl = iterate rot pl !! n
where
rot (Stack alx aly) = Stack (flipAlignment aly) alx
rot (Row Rightwards al) = Row Upwards (flipAlignment al)
rot (Row Leftwards al) = Row Downwards (flipAlignment al)
rot (Row Upwards al) = Row Leftwards al
rot (Row Downwards al) = Row Rightwards al
rot pl = pl
instance Transformable (Floorplan s b)
where
flipX (Block bl) = Block (flipX bl)
flipX (Comb pl fps) = Comb (flipX pl) (map flipX fps)
flipY (Block bl) = Block (flipY bl)
flipY (Comb pl fps) = Comb (flipY pl) (map flipY fps)
rotate_ n (Block bl) = Block (rotate_ n bl)
rotate_ n (Comb pl fps) = Comb (rotate_ n pl) $ map (rotate_ n) fps
flipAlignment BottomLeft = TopRight
flipAlignment TopRight = BottomLeft
rotate :: Transformable a => Int -> a -> a
rotate n = rotate_ ((n`mod`4 + 4) `mod` 4)
absolutizeBlock :: Placement -> RelBlock s b -> (AbsBlock s b, Size)
absolutizeBlock _ (Box sz ori nm b) = (Box sz ori nm b, sz)
absolutizeBlock (Row dir _) (Space (Dist d) ms) = case ang of
Horizontal -> (Space (ang,d) ms, (d,Length 0))
Vertical -> (Space (ang,d) ms, (Length 0,d))
where
ang = directionAngle dir
absolutizeBlock _ (Space _ ms) =
(Space (Horizontal, Length 0) ms, (Length 0, Length 0))
align :: Alignment -> Length -> Length -> Length
align BottomLeft _ _ = Length 0
align _ smaller larger = larger `subLen` smaller
translateBlocks :: Position -> AbsFloorplan s b -> AbsFloorplan s b
translateBlocks (x,y) = map (transP *** id)
where
transP (x',y') = (x'`addLen`x, y'`addLen`y)
absolutize_
:: Placement
-> Position
-> Floorplan s b
-> Writer (AbsFloorplan s b) Size
absolutize_ pl pos (Block bl) = do
tell [(pos,abl)]
return sz
where
(abl,sz) = absolutizeBlock pl bl
absolutize_ _ pos (Comb pl' [fp]) = absolutize_ pl' pos fp
absolutize_ pl pos (Comb (Row Leftwards al) fps) = absolutize_ pl pos $
Comb (Row Rightwards al) $ reverse fps
absolutize_ pl pos (Comb (Row Downwards al) fps) = absolutize_ pl pos $
Comb (Row Upwards al) $ reverse fps
absolutize_ _ _ (Comb _ []) = return (Length 0, Length 0)
absolutize_ pl (x,y) (Comb pl'@(Row Rightwards al) (fp:fps))
| h1 < h2 = do
tell $ translateBlocks (Length 0, align al h1 h2) afp1
tell afp2
return (w1`addLen`w2, h2)
| otherwise = do
tell afp1
tell $ translateBlocks (Length 0, align al h2 h1) afp2
return (w1`addLen`w2, h1)
where
((w1,h1),afp1) = runWriter $ absolutize_ pl' (x,y) fp
((w2,h2),afp2) = runWriter $ absolutize_ pl (x`addLen`w1, y) (Comb pl' fps)
absolutize_ pl (x,y) (Comb pl'@(Row Upwards al) (fp:fps))
| w1 < w2 = do
tell $ translateBlocks (align al w1 w2, Length 0) afp1
tell afp2
return (w2, h1`addLen`h2)
| otherwise = do
tell afp1
tell $ translateBlocks (align al w2 w1, Length 0) afp2
return (w1, h1`addLen`h2)
where
((w1,h1),afp1) = runWriter $ absolutize_ pl' (x,y) fp
((w2,h2),afp2) = runWriter $ absolutize_ pl (x, y`addLen`h1) (Comb pl' fps)
absolutize_ pl (x,y) (Comb pl'@(Stack alx aly) (fp:fps)) =
case (compare w1 w2, compare h1 h2) of
(LT,LT) -> do
tell $ translateBlocks (align alx w1 w2, align aly h1 h2) afp1
tell afp2
return (w2,h2)
(GT,GT) -> do
tell afp1
tell $ translateBlocks (align alx w2 w1, align aly h2 h1) afp2
return (w1,h1)
(LT,_) -> do
tell $ translateBlocks (align alx w1 w2, Length 0) afp1
tell $ translateBlocks (Length 0, align aly h2 h1) afp2
return (w2,h1)
_ -> do
tell $ translateBlocks (Length 0, align aly h1 h2) afp1
tell $ translateBlocks (align alx w2 w1, Length 0) afp2
return (w1,h2)
where
((w1,h1),afp1) = runWriter $ absolutize_ pl' (x,y) fp
((w2,h2),afp2) = runWriter $ absolutize_ pl (x,y) (Comb pl' fps)
absolutize_ pl pos fp@(Comb Unspecified fps) = return rt
where
areaFP fp = uncurry mulLen2 $ fst $ runWriter $ absolutize_ pl pos fp
totArea = sum $ map areaFP fps
side = Length $ round $ sqrt $ toDouble totArea
rt = (side,side)
absolutize :: Floorplan s b -> (AbsFloorplan s b, Size)
absolutize fp = (afp,topRight)
where
(topRight,afp) = runWriter $ absolutize_ Unspecified (Length 0, Length 0) fp
blockCenter :: (Position, AbsBlock s b) -> Position
blockCenter ((x,y), Space (Horizontal,len) _) = (addLen x (len`divLen`2), y)
blockCenter ((x,y), Space (Vertical, len) _) = (x, addLen y (len`divLen`2))
blockCenter ((x,y), Box (w,h) _ _ _) =
(addLen x (w`divLen`2), addLen y (h`divLen`2))