diff --git a/.gitignore b/.gitignore index 3fb7ebd..07b98ee 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ dist-newstyle p.vim +app/c/ruby_compiled.h diff --git a/app/WM/Core.hs b/app/WM/Core.hs index dce4b5b..1ccd2f7 100644 --- a/app/WM/Core.hs +++ b/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 diff --git a/app/WM/Layout.hs b/app/WM/Layout.hs new file mode 100644 index 0000000..a05d6e1 --- /dev/null +++ b/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') diff --git a/kutu.cabal b/kutu.cabal index 33e791f..1790835 100644 --- a/kutu.cabal +++ b/kutu.cabal @@ -23,6 +23,7 @@ executable kutu WM.Core WM.XKutu WM.Mruby + WM.Layout build-depends: base, bytestring