path: root/XMonad/Stockholm/Rhombus.hs

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

import Control.Monad (forM_, zipWithM_)
import Data.Char
import Data.List
import Data.Ord
import Data.Map (fromList)
import Data.Maybe (isJust, fromJust)
import XMonad
import XMonad.StackSet hiding (filter)
import XMonad.Util.Font
import XMonad.Util.Image (drawIcon)
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 ()
    }


-- TODO currently xft is broken
defaultRhombusConfig = RhombusConfig "xft:Sans-8" 100 0 MatchInfix True stupidColors noPaint
    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 def keys
        Just i -> removeRhombus rs >> viewFunc i
    where
    def (ch:[]) | isPrint ch =
        incSearchPushChar ch rs >>= rhombusMode viewFunc rc

    def _ =
        failbeep >> 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


-- TODO make failbeep configurable
failbeep = spawn "beep -l 100 -f 500"


goto :: RhombusConfig -> (Position, Position) -> RhombusState -> X RhombusState
goto RhombusConfig{rc_wrap=True}  xy rs = maybe (failbeep >> return rs) return $ wrapFocus xy rs
goto RhombusConfig{rc_wrap=False} xy rs = maybe (failbeep >> return rs) return $ moveFocus xy rs


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


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

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

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

wrapFocus _ _ = Nothing


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


gotoNextMatch :: RhombusConfig -> RhombusState -> X RhombusState
gotoNextMatch rc rs@RhombusState{rs_focus=focus} = do
    case matchingReachableCoords rc rs of
        [] -> failbeep >> return rs
        xs -> return rs
            { rs_focus = maybe (head xs)
                               (modIndex xs . (+1))
                               (focus `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 focus   = oxy == rs_focus rs
                match   = isXOf (rc_matchmethod rc) (rs_search rs) tag
                current = tag == last tags
                (_b_color, _bg_color, _fg_color) = rc_colors rc focus match current
                --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) focus match current

            -- 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..]

commonPrefix (x:xs) (y:ys) | x == y = x:commonPrefix xs ys
commonPrefix _ _ = []


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


findXIndex :: (Eq a) => MatchMethod -> [a] -> [a] -> Maybe Int
findXIndex MatchInfix  = findInfixIndex
findXIndex MatchPrefix = findPrefixIndex


findInfixIndex :: (Eq a) => [a] -> [a] -> Maybe Int
findInfixIndex needle haystack
    = (\x -> if null x then Nothing else Just (fst $ head x))
      . dropWhile (\(_,x) -> not $ isPrefixOf needle x)
        $ zip [0..] (tails haystack)


findPrefixIndex :: (Eq a) => [a] -> [a] -> Maybe Int
findPrefixIndex needle haystack =
    if isPrefixOf needle haystack
        then Just 0
        else Nothing


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


forZipWithM_ a b f = zipWithM_ f a b


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