path: root/XMonad/Stockholm/Rhombus.hs

module XMonad.Stockholm.Rhombus
    ( MatchMethod(..)
    , rhombus
    , RhombusConfig(..)
    , RhombusState(..)
    ) where

import Control.Monad (zipWithM_)
import Data.Char
import Data.List
import Data.Ord
import Data.Map (fromList)
import Data.Maybe (fromJust)
import XMonad hiding (keys)
import XMonad.StackSet hiding (filter, tag)
import XMonad.Util.Font
import XMonad.Util.XUtils

import XMonad.Stockholm.Submap
import XMonad.Stockholm.XUtils
import XMonad.Stockholm.Font


data MatchMethod = MatchInfix | MatchPrefix

data RhombusConfig = RhombusConfig
    { rc_font           :: String
    , rc_cellwidth      :: Dimension
    , rc_margin         :: Dimension
    , rc_matchmethod    :: MatchMethod
    , rc_wrap           :: Bool
    , rc_colors         :: Bool -> Bool -> Bool -> (String, String, String)
    , rc_paint          :: RhombusConfig -> Display -> Pixmap -> GC -> String -> Rectangle -> Bool -> Bool -> Bool -> X ()
    , rc_missAction     :: X ()
    }


-- TODO currently xft is broken
instance Default RhombusConfig where
    def = RhombusConfig
        { rc_font = "xft:Sans-8"
        , rc_cellwidth = 100
        , rc_margin = 0
        , rc_matchmethod = MatchInfix
        , rc_wrap = True
        , rc_colors = stupidColors
        , rc_paint = noPaint
        , rc_missAction = return ()
        }
      where
        stupidColors _ _ _ = ("red", "magenta", "yellow")
        noPaint _ _ _ _ _ _ _ _ _ = return ()

data RhombusState = RhombusState
    { rs_window     :: Window
    , rs_search     :: String
    , rs_font       :: XMonadFont
    , rs_focus      :: (Position, Position)
    , rs_strings    :: [String]
    }


reachableCoords :: RhombusState -> [(Position, Position)]
reachableCoords RhombusState{rs_strings=xs} = take (length xs) wave


matchingReachableCoords :: RhombusConfig -> RhombusState -> [(Position, Position)]
matchingReachableCoords rc rs =
    snd $ unzip
        $ filter (isXOf (rc_matchmethod rc) (rs_search rs) . fst)
        $ zip (rs_strings rs) (reachableCoords rs)


match :: MatchMethod -> String -> [String] -> Maybe String
match m s ws = do
    let cands = filter (isXOf m s) ws
    if length cands == 1
        then Just $ head cands
        else Nothing

rhombus :: RhombusConfig -> (String -> X ()) -> [String] -> X ()
rhombus rc viewFunc as = withGrabbedKeyboard $ do
    rs <- newRhombus rc as
    --redraw rc rs
    showWindow (rs_window rs)
    rhombusMode viewFunc rc rs


rhombusMode :: (String -> X ()) -> RhombusConfig -> RhombusState -> X ()
rhombusMode viewFunc rc rs =
    case match (rc_matchmethod rc) (rs_search rs) (init $ rs_strings rs) of
        Nothing -> redraw rc rs >> submapString defAction keys
        Just i -> removeRhombus rs >> viewFunc i
    where
    defAction (ch:[]) | isPrint ch =
        incSearchPushChar ch rs >>= rhombusMode viewFunc rc

    defAction _ =
        rc_missAction rc >> rhombusMode viewFunc rc rs

    keys = fromList $
        [ ((0   , xK_BackSpace  ), incSearchPopChar rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Escape     ), removeRhombus rs)
        , ((0   , xK_Menu       ), removeRhombus rs)
        , ((0   , xK_Left       ), goto rc (-1, 0) rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Right      ), goto rc ( 1, 0) rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Up         ), goto rc ( 0,-1) rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Down       ), goto rc ( 0, 1) rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Tab        ), gotoNextMatch rc rs >>= rhombusMode viewFunc rc)
        , ((_S  , xK_Tab        ), gotoPrevMatch rc rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Return     ), removeRhombus rs >> return (selectFocused rs) >>= viewFunc)
        ]

    _S = shiftMask


goto :: RhombusConfig -> (Position, Position) -> RhombusState -> X RhombusState
goto rc xy rs =
    maybe (rc_missAction rc >> return rs) return $ op xy rs
  where
    op = if rc_wrap rc then wrapFocus else moveFocus


moveFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState
moveFocus (dx, dy) rs@RhombusState{rs_focus=(x,y)} = do
    let foc' = (x + dx, y + dy)
    if elem foc' (reachableCoords rs)
        then Just rs { rs_focus = foc' }
        else Nothing


wrapFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState

wrapFocus (0, dy) rs@RhombusState{rs_focus=foc} = do
    let column = sortBy (comparing snd) $ filter ((==) (fst foc) . fst) (reachableCoords rs)
    i <- elemIndex foc column
    return rs { rs_focus = column `modIndex` (i + fromIntegral dy) }

wrapFocus (dx, 0) rs@RhombusState{rs_focus=foc} = do
    let column = sortBy (comparing fst) $ filter ((==) (snd foc) . snd) (reachableCoords rs)
    i <- elemIndex foc column
    return rs { rs_focus = column `modIndex` (i + fromIntegral dx) }

wrapFocus _ _ = Nothing


gotoPrevMatch :: RhombusConfig -> RhombusState -> X RhombusState
gotoPrevMatch rc rs@RhombusState{rs_focus=foc} = do
    case reverse (matchingReachableCoords rc rs) of
        [] -> rc_missAction rc >> return rs
        xs -> return rs
            { rs_focus = maybe (head xs)
                               (modIndex xs . (+1))
                               (foc `elemIndex` xs)
            }


gotoNextMatch :: RhombusConfig -> RhombusState -> X RhombusState
gotoNextMatch rc rs@RhombusState{rs_focus=foc} = do
    case matchingReachableCoords rc rs of
        [] -> rc_missAction rc >> return rs
        xs -> return rs
            { rs_focus = maybe (head xs)
                               (modIndex xs . (+1))
                               (foc `elemIndex` xs)
            }


selectFocused :: RhombusState -> String
selectFocused rs =
    -- TODO the rhombus must never "focus" something inexistent
    fromJust $ lookup (rs_focus rs) $ zip wave (rs_strings rs)


incSearchPushChar :: Char -> RhombusState -> X RhombusState
incSearchPushChar c rs = return rs { rs_search = rs_search rs ++ [c] }


incSearchPopChar :: RhombusState -> X RhombusState

-- only rubout if we have at least one char
incSearchPopChar rs@RhombusState{rs_search=xs@(_:_)} =
    return rs { rs_search = init xs }

incSearchPopChar rs = return rs


redraw :: RhombusConfig -> RhombusState -> X ()
redraw rc rs = do
    ss <- gets windowset

    let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss

    -- TODO this let is duplicated in newRhombus
    let scale x = x * cell_w `div` s_width -- TODO use bw
        cell_w  = rc_cellwidth rc
        cell_h  = scale s_height

        -- txy is the top-left corner of the first (center) cell
        -- XXX div and (-) are not distributive
        --     we could round $ (s_* - cell_*) / 2, though...
        tx = fi $ s_width  `div` 2 - cell_w `div` 2
        ty = fi $ s_height `div` 2 - cell_h `div` 2

        margin = rc_margin rc

        -- dxy are the outer cell dimensions (i.e. including the border)
        dx = fi $ cell_w + 2 + margin
        dy = fi $ cell_h + 2 + margin

        paint = rc_paint rc
        xmf   = rs_font rs
        tags  = rs_strings rs
        --currentTag = last tags

    withDisplay $ \ d -> do
        -- XXX we cannot use withPixmapAndGC because rc_paint is an X monad
        p <- io $ createPixmap d (rs_window rs) s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d)
        g <- io $ createGC d p

        -- TODO fixme
        color_black <- stringToPixel d "black"

        forZipWithM_ tags (reachableCoords rs) $ \tag oxy@(ox, oy) -> do

            let isFocused = oxy == rs_focus rs
                isMatched = isXOf (rc_matchmethod rc) (rs_search rs) tag
                isCurrent = tag == last tags
                (_b_color, _bg_color, _fg_color) = rc_colors rc isFocused isMatched isCurrent
                --cell_x = (ox * dx) + x - fi (cell_w `div` 2)
                --cell_y = (oy * dy) + y - fi (cell_h `div` 2)
                cell_x = (ox * dx) + tx + 1
                cell_y = (oy * dy) + ty + 1

            b_color <- stringToPixel d _b_color
            bg_color <- stringToPixel d _bg_color
            fg_color <- stringToPixel d _fg_color

            -- draw background
            io $ setForeground d g bg_color
            io $ fillRectangle d p g cell_x cell_y cell_w cell_h

            -- draw border
            io $ setForeground d g b_color
            io $ drawLines d p g
                    [ Point (cell_x - 1) (cell_y - 1)
                    , Point (fi cell_w + 1) 0
                    , Point 0 (fi cell_h + 1)
                    , Point (-(fi cell_w + 1)) 0
                    , Point 0 (-(fi cell_h + 1))
                    ]
                    coordModePrevious

            -- custom draw
            paint rc d p g tag (Rectangle cell_x cell_y cell_w cell_h) isFocused isMatched isCurrent

            -- paint text
            -- TODO custom paint text?
            -- TODO withCopyArea
            io $ withPixmapAndGC d p s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d) $ \ f_pm f_gc -> do
                withPixmapAndGC d f_pm s_width s_height 1 $ \ clip_mask clip_gc -> do
                    setForeground d clip_gc 0
                    setBackground d clip_gc 0
                    fillRectangle d clip_mask clip_gc 0 0 s_width s_height
                    setForeground d clip_gc 1

                    let r = Rectangle cell_x cell_y cell_w cell_h

                    printStringCentered d clip_mask xmf clip_gc r tag

                    setForeground d f_gc fg_color
                    setBackground d f_gc color_black -- TODO

                    printStringCentered d f_pm xmf f_gc r tag

                    setClipMask d f_gc clip_mask

                    copyArea d f_pm p f_gc 0 0 s_width s_height 0 0

        io $ copyArea d p (rs_window rs) g 0 0 s_width s_height 0 0
        io $ freePixmap d p
        io $ freeGC d g


newRhombus :: RhombusConfig -> [String] -> X RhombusState
newRhombus rc tags = do
    ss <- gets windowset

    let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss
        (_, def_win_bg, _) = rc_colors rc False True False

    -- TODO this let is duplicated in redraw
    let scale x = x * cell_w `div` s_width -- TODO use bw
        cell_w  = rc_cellwidth rc
        cell_h  = scale s_height

        -- TODO don't delete this let but use it instead of s_{width,height}
        -- (xcoords, ycoords) = unzip $ take (length tags) wave -- this is reachableCoords
        -- win_width  = (maximum xcoords - minimum xcoords) * dx
        -- win_height = (maximum ycoords - minimum ycoords) * dy

        -- txy is the top-left corner of the first (center) cell
        -- XXX div and (-) are not distributive
        --     we could round $ (s_* - cell_*) / 2, though...
        tx = fi $ s_width  `div` 2 - cell_w `div` 2
        ty = fi $ s_height `div` 2 - cell_h `div` 2

        margin = rc_margin rc

        -- dxy are the outer cell dimensions (i.e. including the border)
        dx = fi $ cell_w + 2 + margin
        dy = fi $ cell_h + 2 + margin

    fn <- initXMF (rc_font rc)
    win <- createNewWindow (Rectangle 0 0 s_width s_height) Nothing def_win_bg True

    withDisplay $ \ d ->
        io $ shapeWindow d win $ \ p g ->
            forZipWithM_ tags wave $ \ _ (ox, oy) ->
                fillRectangle d p g (tx + ox * dx) (ty + oy * dy) (fi cell_w + 2) (fi cell_h + 2)

    return $ RhombusState win "" fn (0,0) tags


removeRhombus :: RhombusState -> X ()
removeRhombus (RhombusState w _ fn _ _) = do
    deleteWindow w
    releaseXMF fn

wave :: [(Position, Position)]
wave = zip (0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])) (concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..])
    --where
    --    wave1 = 0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])
    --    wave2 = concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..]



isXOf :: MatchMethod -> String -> String -> Bool
isXOf MatchInfix  = isInfixOf
isXOf MatchPrefix = isPrefixOf


modIndex :: Integral i => [a] -> i -> a
modIndex xs i = xs `genericIndex` (i `mod` genericLength xs)


forZipWithM_ :: Monad m => [a] -> [b] -> (a -> b -> m c) -> m ()
forZipWithM_ a b f = zipWithM_ f a b


withGrabbedKeyboard :: X () -> X ()
withGrabbedKeyboard f = do
    XConf { theRoot = root, display = d } <- ask
    catchX (io (grabKeyboard d root False grabModeAsync grabModeAsync currentTime) >> f)
           (return ())
    io $ ungrabKeyboard d currentTime