diff options
| -rw-r--r-- | src/Rahm/Desktop/Keys.hs | 8 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout.hs | 3 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout/Explode.hs | 91 |
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) |