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      -- Absolute distance
       -- *** | Fill Elasticity  -- Relative distance
     deriving (Eq, Show)

data Block spaceSize s b
       = Space spaceSize (Maybe s)
       | Box Size Orientation Name b
     deriving (Eq, Show)
  -- Space *may* have some extra info. A Box is *always* associated with extra
  -- info (use () if not needed).

type RelBlock s b = Block Distance s b
  -- Space has only a distance. Angle is determined by the context.

type AbsBlock s b = Block (Angle,Length) s b
  -- Space is a horizontal or vertical line.

data Placement
       = Unspecified
       | Stack Alignment Alignment  -- Stacked on the same position
       | 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 (icast h, icast 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)
  -- *** Could use unsafeCoerce to avoid reconstruction.

absolutizeBlock (Row dir _) (Space (Dist d) ms) = case ang of
    Horizontal -> (Space (ang,d) ms, (icast d, 0))
    Vertical   -> (Space (ang,d) ms, (0, icast d))
  where
    ang = directionAngle dir

absolutizeBlock _ (Space _ ms) = (Space (Horizontal,0) ms, (0,0))



align :: Integral i => Alignment -> i -> i -> i
align BottomLeft _ _    = 0
align _  smaller larger = larger - smaller

translateBlocks :: Position -> AbsFloorplan s b -> AbsFloorplan s b
translateBlocks (x,y) = map (transP *** id)
  where
    transP (x',y') = (x'+x,y'+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 (0,0)

absolutize_ pl (x,y) (Comb pl'@(Row Rightwards al) (fp:fps))

    | h1 < h2 = do
        tell $ translateBlocks (0, align al h1 h2) afp1
        tell afp2
        return (w1+w2, h2)

    | otherwise = do
        tell afp1
        tell $ translateBlocks (0, align al h2 h1) afp2
        return (w1+w2, h1)

  where
    ((w1,h1),afp1) = runWriter $ absolutize_ pl' (x,y) fp
    ((w2,h2),afp2) = runWriter $ absolutize_ pl (x+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, 0) afp1
        tell afp2
        return (w2, h1+h2)

    | otherwise = do
        tell afp1
        tell $ translateBlocks (align al w2 w1, 0) afp2
        return (w1, h1+h2)

  where
    ((w1,h1),afp1) = runWriter $ absolutize_ pl' (x,y) fp
    ((w2,h2),afp2) = runWriter $ absolutize_ pl (x, y+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, 0) afp1
          tell $ translateBlocks (0, align aly h2 h1) afp2
          return (w2,h1)

        _ -> do
          tell $ translateBlocks (0, align aly h1 h2) afp1
          tell $ translateBlocks (align alx w2 w1, 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
    -- *** Should do something more...
  where
    areaFP fp = icast x * icast y :: Int
      where
        (x,y) = fst $ runWriter $ absolutize_ pl pos fp

    totArea = sum $ map areaFP fps

    side :: Int
    side = fromInteger
          $ round
          $ sqrt
          $ fromIntegral
          $ totArea

    rt = (icast side, icast side)

  -- The Placement argument is the placement of the node immediately above the
  -- current one. It is only used for blocks.

  -- *** The same block may be translated over and over again. If the size of
  --     each sub-floorplan was known in advance, this could be avioded (by
  --     adjusting the position argument to absolutize_ for alignment).



absolutize :: Floorplan s b -> (AbsFloorplan s b, Size)
absolutize fp = (afp,topRight)
  where
    (topRight,afp) = runWriter $ absolutize_ Unspecified (0,0) fp

blockCenter :: (Position, AbsBlock s b) -> Position
blockCenter ((x,y), Space (Horizontal,len) _) = (x + icast len`div`2, y)
blockCenter ((x,y), Space (Vertical,  len) _) = (x, y + icast len`div`2)
blockCenter ((x,y), Box (w,h) _ _ _)          = (x + w`div`2, y + h`div`2)