{-# 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)