Add explode layout modifier and make it toggleable with <M-z>c

3 files changed, 101 insertions, 1 deletions

diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 57ca2e0..17b5c11 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -141,6 +141,7 @@ import XMonad.Layout.Spacing
 import XMonad.Util.Run (safeSpawn)
 import XMonad.Util.WindowProperties
 import Prelude hiding ((!!))
+import Rahm.Desktop.Layout.Explode (toggleExplode)
 
 type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ())
 
@@ -900,6 +901,13 @@ bindings = do
             noMod mediaNextDoc
             rawMask shiftMask mediaSeekFDoc
 
+          -- Explode
+          bind xK_c $ do
+            noMod -|- justMod $
+              doc "Toggle explode on the workspace" $
+                sendMessage toggleExplode
+
+
           bindOtherKeys $ \(_, _, s) ->
             logs Info "Unhandled key pressed: %s" s
 
diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs
index 8c2daf7..12658a9 100644
--- a/src/Rahm/Desktop/Layout.hs
+++ b/src/Rahm/Desktop/Layout.hs
@@ -39,6 +39,7 @@ import XMonad.Layout.MosaicAlt
   )
 import XMonad.Layout.Spacing (Border (..), spacingRaw)
 import XMonad.Layout.Spiral (spiral)
+import Rahm.Desktop.Layout.Explode (explodeable)
 
 myLayout =
     fullscreenFull $
@@ -49,7 +50,7 @@ myLayout =
 mySpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True
 
 mods =
-  poppable . mySpacing . flippable . rotateable
+  poppable . explodeable . mySpacing . flippable . rotateable
 
 myLayoutList =
   layoutList $
diff --git a/src/Rahm/Desktop/Layout/Explode.hs b/src/Rahm/Desktop/Layout/Explode.hs
new file mode 100644
index 0000000..1d25695
--- /dev/null
+++ b/src/Rahm/Desktop/Layout/Explode.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Rahm.Desktop.Layout.Explode where
+
+import Control.Arrow (Arrow (second))
+import Data.Foldable (minimumBy)
+import Data.Ord (comparing)
+import qualified Rahm.Desktop.StackSet as W
+import XMonad
+
+data Explodeable (l :: * -> *) (a :: *) = Explodeable
+  { isExploded :: Bool,
+    wrap :: l a
+  }
+  deriving (Show, Read, Eq, Ord)
+
+data ExplodeMessage where
+  ExplodeMessage :: (forall l a. Explodeable l a -> Explodeable l a) -> ExplodeMessage
+  deriving (Message)
+
+explodeable :: l a -> Explodeable l a
+explodeable = Explodeable False
+
+toggleExplode :: ExplodeMessage
+toggleExplode = ExplodeMessage $ \(Explodeable b l) -> Explodeable (not b) l
+
+instance (LayoutClass l a, Eq a) => LayoutClass (Explodeable l) a where
+  runLayout
+    (W.Workspace t (Explodeable True l) stack)
+    rect@(Rectangle x y w h) = do
+      (returned, maybeNewLayout) <- runLayout (W.Workspace t l stack) rect
+
+      let (cx, cy) = (x + (fi w `div` 2), y + (fi h `div` 2))
+          newReturned =
+            map
+              ( second $ \(Rectangle rx ry rw rh) ->
+                  let (rcx, rcy) = (rx + (fi rw `div` 2), ry + (fi rh `div` 2))
+                      (dx, dy) = norm (rcx - cx, rcy - cy)
+                      (x', y') = calcNewPoint (fi rcx, fi rcy) (fi cx, fi cy) rect
+                   in Rectangle
+                        (round (x' - (fi rcx - fi rx) + (fi w * dx) / 10))
+                        (round (y' - (fi rcy - fi ry) + (fi h * dy) / 10))
+                        rw
+                        rh
+              )
+              returned
+
+      return (newReturned, Explodeable True <$> maybeNewLayout)
+      where
+        fi :: (Integral a, Num b) => a -> b
+        fi = fromIntegral
+        norm :: (Integral a, Integral b) => (a, b) -> (Float, Float)
+        norm (fromIntegral -> x, fromIntegral -> y) = let d = sqrt (x ** 2 + y ** 2) in (x / d, y / d)
+
+        calcNewPoint (rcx, rcy) (cx, cy) (Rectangle x y w h) =
+          let (dx, dy) = (rcx - cx, rcy - cy)
+              s = dy / dx
+
+              x1, y1, x2, y2, x3, y3, x4, y4 :: Float
+
+              x1 = fi x
+              y1 = s * x1 + rcy - s * rcx + fi y
+
+              x2 = fi (x + fi w)
+              y2 = s * x2 + rcy - s * rcx + fi y
+
+              y3 = fi y
+              x3 = (y3 + s * rcx - rcy) / s
+
+              y4 = fi (y + fi h)
+              x4 = (y4 + s * rcx - rcy) / s
+
+              points = [(x1, y1), (x2, y2), (x3, y3), (x4, y4)]
+           in minimumBy
+                ( comparing
+                    ( \(x1, y1) ->
+                        (x1 - rcx) ** 2 + (y1 - rcy) ** 2
+                    )
+                )
+                points
+  runLayout (W.Workspace t (Explodeable b l) a) rect = do
+    (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect
+    return (rects, Explodeable b <$> maybeNewLayout)
+
+  -- If the message is a ExplodeMessage, handle that here.
+  handleMessage p (fromMessage -> Just (ExplodeMessage f)) =
+    return $ Just $ f p
+  -- By default just pass the message to the underlying layout.
+  handleMessage (Explodeable b l) mess = do
+    maybeNewLayout <- handleMessage l mess
+    return (Explodeable b <$> maybeNewLayout)