Add basic layout system

.gitignore

@@ -1,2 +1,3 @@
 dist-newstyle
 p.vim
+app/c/ruby_compiled.h

app/WM/Core.hs

@@ -4,6 +4,7 @@ import Control.Concurrent (threadDelay)
 import Control.Exception (bracket)
 import Foreign (Ptr)
 import System.Environment (getArgs)
+import WM.Layout
 import WM.Mruby
 import WM.XKutu
 

app/WM/Layout.hs

@@ -0,0 +1,173 @@
+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')

kutu.cabal

@@ -23,6 +23,7 @@ executable kutu
         WM.Core
         WM.XKutu
         WM.Mruby
+        WM.Layout
 
     build-depends:    base, bytestring