{-# LANGUAGE FlexibleInstances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.FlexibleManipulate
-- Description :  Move and resize floating windows without warping the mouse.
-- Copyright   :  (c) Michael Sloan
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  <mgsloan@gmail.com>
-- Stability   :  stable
-- Portability :  unportable
--
-- Move and resize floating windows without warping the mouse.
--
-----------------------------------------------------------------------------

-- Based on the FlexibleResize code by Lukas Mai (mauke).

module XMonad.Actions.FlexibleManipulate (
        -- * Usage
        -- $usage
        mouseWindow, discrete, linear, resize, position
) where

import XMonad
import XMonad.Prelude ((<&>))
import qualified Prelude as P
import Prelude (Double, Integer, Ord (..), const, fromIntegral, fst, id, map, otherwise, round, snd, uncurry, ($), (.))

-- $usage
-- First, add this import to your @~\/.xmonad\/xmonad.hs@:
--
-- > import qualified XMonad.Actions.FlexibleManipulate as Flex
--
-- Now set up the desired mouse binding, for example:
--
-- >     , ((modm, button1), (\w -> focus w >> Flex.mouseWindow Flex.linear w))
--
-- * Flex.'linear' indicates that positions between the edges and the
--   middle indicate a combination scale\/position.
--
-- * Flex.'discrete' indicates that there are discrete pick
--   regions. (The window is divided by thirds for each axis.)
--
-- * Flex.'resize' performs only a resize of the window, based on which
--   quadrant the mouse is in.
--
-- * Flex.'position' is similar to the built-in
--   'XMonad.Operations.mouseMoveWindow'.
--
-- You can also write your own function for this parameter. It should take
-- a value between 0 and 1 indicating position, and return a value indicating
-- the corresponding position if plain Flex.'linear' was used.
--
-- For detailed instructions on editing your mouse bindings, see
-- "XMonad.Doc.Extending#Editing_mouse_bindings".

discrete, linear, resize, position :: Double -> Double

-- | Manipulate the window based on discrete pick regions; the window
--   is divided into regions by thirds along each axis.
discrete :: Double -> Double
discrete Double
x | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.33 = Double
0
           | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0.66 = Double
1
           | Bool
otherwise = Double
0.5

-- | Scale\/reposition the window by factors obtained from the mouse
--   position by linear interpolation. Dragging precisely on a corner
--   resizes that corner; dragging precisely in the middle moves the
--   window without resizing; anything else is an interpolation
--   between the two.
linear :: Double -> Double
linear = Double -> Double
forall a. a -> a
id

-- | Only resize the window, based on the window quadrant the mouse is in.
resize :: Double -> Double
resize Double
x = if Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.5 then Double
0 else Double
1

-- | Only reposition the window.
position :: Double -> Double
position = Double -> Double -> Double
forall a b. a -> b -> a
const Double
0.5

-- | Given an interpolation function, implement an appropriate window
--   manipulation action.
mouseWindow :: (Double -> Double) -> Window -> X ()
mouseWindow :: (Double -> Double) -> Window -> X ()
mouseWindow Double -> Double
f Window
w = X Bool -> X () -> X ()
whenX (Window -> X Bool
isClient Window
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    [Pnt
wpos, Pnt
wsize] <- IO [Pnt] -> X [Pnt]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Pnt] -> X [Pnt]) -> IO [Pnt] -> X [Pnt]
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO WindowAttributes
getWindowAttributes Display
d Window
w IO WindowAttributes -> (WindowAttributes -> [Pnt]) -> IO [Pnt]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> WindowAttributes -> [Pnt]
winAttrs
    SizeHints
sh <- IO SizeHints -> X SizeHints
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO SizeHints -> X SizeHints) -> IO SizeHints -> X SizeHints
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO SizeHints
getWMNormalHints Display
d Window
w
    Pnt
pointer <- IO Pnt -> X Pnt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Pnt -> X Pnt) -> IO Pnt -> X Pnt
forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
queryPointer Display
d Window
w IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
-> ((Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
    -> Pnt)
-> IO Pnt
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier) -> Pnt
forall a a a b c f g h.
(Integral a, Integral a) =>
(a, b, c, a, a, f, g, h) -> Pnt
pointerPos

    let uv :: Pnt
uv = (Pnt
pointer Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
- Pnt
wpos) Pnt -> Pnt -> Pnt
forall a. Fractional a => (a, a) -> (a, a) -> (a, a)
/ Pnt
wsize
        fc :: Pnt
fc = (Double -> Double) -> Pnt -> Pnt
forall a b. (a -> b) -> (a, a) -> (b, b)
mapP Double -> Double
f Pnt
uv
        mul :: Pnt
mul = (Double -> Double) -> Pnt -> Pnt
forall a b. (a -> b) -> (a, a) -> (b, b)
mapP (\Double
x -> Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
P.- Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
P.* Double -> Double
forall a. Num a => a -> a
P.abs(Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
P.- Double
0.5)) Pnt
fc --Fudge factors: interpolation between 1 when on edge, 2 in middle
        atl :: Pnt
atl = ((Double
1, Double
1) Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
- Pnt
fc) Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
* Pnt
mul
        abr :: Pnt
abr = Pnt
fc Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
* Pnt
mul
    (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
ex Position
ey -> do
        let offset :: Pnt
offset = (Position -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
ex, Position -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
ey) Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
- Pnt
pointer
            npos :: Pnt
npos = Pnt
wpos Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
+ Pnt
offset Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
* Pnt
atl
            nbr :: Pnt
nbr = (Pnt
wpos Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
+ Pnt
wsize) Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
+ Pnt
offset Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
* Pnt
abr
            ntl :: Pnt
ntl = Pnt -> Pnt -> Pnt
forall a. Ord a => (a, a) -> (a, a) -> (a, a)
minP (Pnt
nbr Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
- (Double
32, Double
32)) Pnt
npos    --minimum size
            nwidth :: D
nwidth = SizeHints -> (Integer, Integer) -> D
forall a. Integral a => SizeHints -> (a, a) -> D
applySizeHintsContents SizeHints
sh ((Integer, Integer) -> D) -> (Integer, Integer) -> D
forall a b. (a -> b) -> a -> b
$ (Double -> Integer) -> Pnt -> (Integer, Integer)
forall a b. (a -> b) -> (a, a) -> (b, b)
mapP (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round :: Double -> Integer) (Pnt
nbr Pnt -> Pnt -> Pnt
forall a. Num a => (a, a) -> (a, a) -> (a, a)
- Pnt
ntl)
        IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
moveResizeWindow Display
d Window
w (Double -> Position
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Position) -> Double -> Position
forall a b. (a -> b) -> a -> b
$ Pnt -> Double
forall a b. (a, b) -> a
fst Pnt
ntl) (Double -> Position
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Position) -> Double -> Position
forall a b. (a -> b) -> a -> b
$ Pnt -> Double
forall a b. (a, b) -> b
snd Pnt
ntl) (Dimension -> Dimension -> IO ()) -> D -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
`uncurry` D
nwidth
        Window -> X ()
float Window
w)
        (Window -> X ()
float Window
w)

    Window -> X ()
float Window
w

  where
    pointerPos :: (a, b, c, a, a, f, g, h) -> Pnt
pointerPos (a
_,b
_,c
_,a
px,a
py,f
_,g
_,h
_) = (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
px,a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
py) :: Pnt
    winAttrs :: WindowAttributes -> [Pnt]
    winAttrs :: WindowAttributes -> [Pnt]
winAttrs WindowAttributes
x = [Double] -> [Pnt]
forall a. [a] -> [(a, a)]
pairUp ([Double] -> [Pnt]) -> [Double] -> [Pnt]
forall a b. (a -> b) -> a -> b
$ ((WindowAttributes -> CInt) -> Double)
-> [WindowAttributes -> CInt] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Double)
-> ((WindowAttributes -> CInt) -> CInt)
-> (WindowAttributes -> CInt)
-> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((WindowAttributes -> CInt) -> WindowAttributes -> CInt
forall a b. (a -> b) -> a -> b
$ WindowAttributes
x)) [WindowAttributes -> CInt
wa_x, WindowAttributes -> CInt
wa_y, WindowAttributes -> CInt
wa_width, WindowAttributes -> CInt
wa_height]


-- I'd rather I didn't have to do this, but I hate writing component 2d math
type Pnt = (Double, Double)

pairUp :: [a] -> [(a,a)]
pairUp :: [a] -> [(a, a)]
pairUp [] = []
pairUp [a
_] = []
pairUp (a
x:a
y:[a]
xs) = (a
x, a
y) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
pairUp [a]
xs

mapP :: (a -> b) -> (a, a) -> (b, b)
mapP :: (a -> b) -> (a, a) -> (b, b)
mapP a -> b
f (a
x, a
y) = (a -> b
f a
x, a -> b
f a
y)
zipP :: (a -> b -> c) -> (a,a) -> (b,b) -> (c,c)
zipP :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
zipP a -> b -> c
f (a
ax,a
ay) (b
bx,b
by) = (a -> b -> c
f a
ax b
bx, a -> b -> c
f a
ay b
by)

minP :: Ord a => (a,a) -> (a,a) -> (a,a)
minP :: (a, a) -> (a, a) -> (a, a)
minP = (a -> a -> a) -> (a, a) -> (a, a) -> (a, a)
forall a b c. (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
zipP a -> a -> a
forall a. Ord a => a -> a -> a
min

infixl 6  +, -
infixl 7  *, /

(+), (-), (*) :: (P.Num a) => (a,a) -> (a,a) -> (a,a)
+ :: (a, a) -> (a, a) -> (a, a)
(+) = (a -> a -> a) -> (a, a) -> (a, a) -> (a, a)
forall a b c. (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
zipP a -> a -> a
forall a. Num a => a -> a -> a
(P.+)
(-) = (a -> a -> a) -> (a, a) -> (a, a) -> (a, a)
forall a b c. (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
zipP a -> a -> a
forall a. Num a => a -> a -> a
(P.-)
* :: (a, a) -> (a, a) -> (a, a)
(*) = (a -> a -> a) -> (a, a) -> (a, a) -> (a, a)
forall a b c. (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
zipP a -> a -> a
forall a. Num a => a -> a -> a
(P.*)
(/) :: (P.Fractional a) => (a,a) -> (a,a) -> (a,a)
/ :: (a, a) -> (a, a) -> (a, a)
(/) = (a -> a -> a) -> (a, a) -> (a, a) -> (a, a)
forall a b c. (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
zipP a -> a -> a
forall a. Fractional a => a -> a -> a
(P./)