epq-old/app/WM/Layout.hs

module WM.Layout where

data DropPosition
  = LeftOf
  | RightOf
  | UpOf
  | DownOf
  deriving (Show, Eq)

data Vec2 = Vec2
  { vx :: Float,
    vy :: Float
  }
  deriving (Show, Eq)

data Rect = Rect
  { pos :: Vec2,
    size :: Vec2
  }
  deriving (Show, Eq)

data Direction
  = Horizontal
  | Vertical
  deriving (Show, Eq)

data Tile
  = Window Int
  | Split
      { direction :: Direction,
        lRatio :: Float,
        left :: Tile,
        right :: Tile
      }
  deriving (Show)

data Crumb
  = LeftCrumb Direction Float Tile Rect
  | RightCrumb Direction Float Tile Rect
  deriving (Show)

type Zipper = (Tile, [Crumb])

clamp :: Float -> Float
clamp x = max 0.05 (min 0.95 x)

findId :: Int -> Rect -> Tile -> Maybe Zipper
findId target rootRect tile = go tile rootRect []
  where
    go (Window w_id) _ crumbs
      | w_id == target = Just (Window w_id, crumbs)
      | otherwise = Nothing
    go (Split dir ratio l r) rect@(Rect (Vec2 x y) (Vec2 w h)) crumbs =
      case dir of
        Horizontal ->
          let w1 = w * ratio
              leftRect = Rect (Vec2 x y) (Vec2 w1 h)
              rightRect = Rect (Vec2 (x + w1) y) (Vec2 (w - w1) h)
           in case go l leftRect (LeftCrumb dir ratio r rect : crumbs) of
                Just result -> Just result
                Nothing -> go r rightRect (RightCrumb dir ratio l rect : crumbs)
        Vertical ->
          let h1 = h * ratio
              topRect = Rect (Vec2 x y) (Vec2 w h1)
              bottomRect = Rect (Vec2 x (y + h1)) (Vec2 w (h - h1))
           in case go l topRect (LeftCrumb dir ratio r rect : crumbs) of
                Just result -> Just result
                Nothing -> go r bottomRect (RightCrumb dir ratio l rect : crumbs)

up :: Zipper -> Maybe Zipper
up (_, []) = Nothing
up (focus, LeftCrumb dir ratio rightSibling _ : rest) =
  Just (Split dir ratio focus rightSibling, rest)
up (focus, RightCrumb dir ratio leftSibling _ : rest) =
  Just (Split dir ratio leftSibling focus, rest)

top :: Zipper -> Tile
top z =
  case up z of
    Nothing -> fst z
    Just z' -> top z'

contains :: Rect -> Vec2 -> Bool
contains (Rect (Vec2 x y) (Vec2 w h)) (Vec2 px py) =
  px >= x
    && px <= x + w
    && py >= y
    && py <= y + h

findAt :: Maybe Tile -> Rect -> Vec2 -> Maybe (Zipper, Vec2)
findAt Nothing _ _ = Nothing
findAt (Just tile) rect p = go tile rect [] p
  where
    go (Window w_id) re@(Rect (Vec2 x y) _) crumbs point
      | contains re point =
          Just ((Window w_id, crumbs), Vec2 (vx point - x) (vy point - y))
      | otherwise = Nothing
    go (Split dir ratio l r) re@(Rect (Vec2 x y) (Vec2 w h)) crumbs point
      | not (contains re point) = Nothing
      | otherwise = case dir of
          Horizontal ->
            let w1 = w * ratio
                leftRect = Rect (Vec2 x y) (Vec2 w1 h)
                rightRect = Rect (Vec2 (x + w1) y) (Vec2 (w - w1) h)
             in if contains leftRect point
                  then go l leftRect (LeftCrumb dir ratio r re : crumbs) point
                  else go r rightRect (RightCrumb dir ratio l re : crumbs) point
          Vertical ->
            let h1 = h * ratio
                upRect = Rect (Vec2 x y) (Vec2 w h1)
                downRect = Rect (Vec2 x (y + h1)) (Vec2 w (h - h1))
             in if contains upRect point
                  then go l upRect (LeftCrumb dir ratio r re : crumbs) point
                  else go r downRect (RightCrumb dir ratio l re : crumbs) point

resize :: Vec2 -> Zipper -> Zipper
resize delta z = go True True z z
  where
    go :: Bool -> Bool -> Zipper -> Zipper -> Zipper
    go _ _ (_, []) lastChanged = lastChanged
    go resizeH resizeV (focus, crumb : rest) lastChanged =
      case crumb of
        LeftCrumb dir ratio sibling rect ->
          let (newRatio, newH, newV, changed) = adjust dir ratio rect resizeH resizeV
              parent = Split dir newRatio focus sibling
              next = (parent, rest)
           in go newH newV next (if changed then next else lastChanged)
        RightCrumb dir ratio sibling rect ->
          let (newRatio, newH, newV, changed) = adjust dir ratio rect resizeH resizeV
              parent = Split dir newRatio sibling focus
              next = (parent, rest)
           in go newH newV next (if changed then next else lastChanged)
    adjust Horizontal ratio (Rect _ (Vec2 w _)) hFlag vFlag
      | hFlag = (clamp (ratio + vx delta / w), False, vFlag, True)
      | otherwise = (ratio, hFlag, vFlag, False)
    adjust Vertical ratio (Rect _ (Vec2 _ h)) hFlag vFlag
      | vFlag = (clamp (ratio + vy delta / h), hFlag, False, True)
      | otherwise = (ratio, hFlag, vFlag, False)

layout :: Maybe Tile -> Rect -> [(Int, Rect)]
layout Nothing _ = []
layout (Just (Window w_id)) rect = [(w_id, rect)]
layout (Just (Split Horizontal ratio l r)) (Rect (Vec2 x y) (Vec2 w h)) =
  let w1 = w * ratio
      leftRect = Rect (Vec2 x y) (Vec2 w1 h)
      rightRect = Rect (Vec2 (x + w1) y) (Vec2 (w - w1) h)
   in layout (Just l) leftRect ++ layout (Just r) rightRect
layout (Just (Split Vertical ratio l r)) (Rect (Vec2 x y) (Vec2 w h)) =
  let h1 = h * ratio
      upRect = Rect (Vec2 x y) (Vec2 w h1)
      downRect = Rect (Vec2 x (y + h1)) (Vec2 w (h - h1))
   in layout (Just l) upRect ++ layout (Just r) downRect

dropTile :: Tile -> DropPosition -> Zipper -> Tile
dropTile new pos (focus, crumbs) = top (go new pos (focus, crumbs))
  where
    go n dir (f, c)
      | dir == LeftOf = (Split Horizontal 0.5 n f, c)
      | dir == RightOf = (Split Horizontal 0.5 f n, c)
      | dir == UpOf = (Split Vertical 0.5 n f, c)
      | dir == DownOf = (Split Vertical 0.5 f n, c)
      | otherwise = (f, c)

remove :: Tile -> Int -> Maybe Tile
remove (Window cIdx) idx
  | idx == cIdx = Nothing
  | otherwise = Just (Window cIdx)
remove (Split dir ratio l r) idx =
  case (remove l idx, remove r idx) of
    (Nothing, Nothing) -> Nothing
    (Just l', Nothing) -> Just l'
    (Nothing, Just r') -> Just r'
    (Just l', Just r') -> Just (Split dir ratio l' r')