aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--chelleport.cabal6
-rw-r--r--specs/Specs/KeySequenceSpec.hs13
-rw-r--r--src/Chelleport.hs44
-rw-r--r--src/Chelleport/AppShell.hs34
-rw-r--r--src/Chelleport/Context.hs46
-rw-r--r--src/Chelleport/Control.hs18
-rw-r--r--src/Chelleport/Draw.hs2
-rw-r--r--src/Chelleport/KeySequence.hs37
8 files changed, 129 insertions, 71 deletions
diff --git a/chelleport.cabal b/chelleport.cabal
index 2f6d458..b55212a 100644
--- a/chelleport.cabal
+++ b/chelleport.cabal
@@ -41,12 +41,16 @@ library lib-chelleport
hs-source-dirs: src
build-depends:
sdl2 == 2.5.5.0,
- sdl2-ttf == 2.1.3
+ sdl2-ttf == 2.1.3,
+ X11 == 1.10.3,
+ xtest == 0.2
exposed-modules:
Chelleport
Chelleport.AppShell
Chelleport.Draw
Chelleport.KeySequence
+ Chelleport.Context
+ Chelleport.Control
test-suite specs
import: common-config
diff --git a/specs/Specs/KeySequenceSpec.hs b/specs/Specs/KeySequenceSpec.hs
index d094741..707646d 100644
--- a/specs/Specs/KeySequenceSpec.hs
+++ b/specs/Specs/KeySequenceSpec.hs
@@ -5,13 +5,14 @@ import Test.Hspec
test = do
describe "#nextChars" $ do
- it "filters key sequence and returns next characters" $ do
- nextChars "AB" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]]
- `shouldBe` Just "CD"
- nextChars "A" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]]
- `shouldBe` Just "BM"
+ context "when there is a partial match" $ do
+ it "filters key sequence and returns next characters" $ do
+ nextChars "AB" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]]
+ `shouldBe` Just "CD"
+ nextChars "A" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]]
+ `shouldBe` Just "BM"
- context "when exact match is present" $ do
+ context "when there is an exact match" $ do
it "returns next characters" $ do
nextChars "ABD" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]]
`shouldBe` Just ""
diff --git a/src/Chelleport.hs b/src/Chelleport.hs
index d493db3..9cc6a57 100644
--- a/src/Chelleport.hs
+++ b/src/Chelleport.hs
@@ -1,22 +1,25 @@
module Chelleport where
-import Chelleport.AppShell (Action (AppAction, SysQuit), DrawContext (ctxWindow), setupAppShell)
+import Chelleport.AppShell (Action (AppAction, SysQuit), setupAppShell)
+import Chelleport.Context (DrawContext (ctxRenderer, ctxWindow))
+import Chelleport.Control (moveMouse, triggerMouseLeftClick)
import Chelleport.Draw (colorLightGray, colorWhite, renderText)
-import Chelleport.KeySequence (eventToKeycode, findMatchPosition, generateKeyCells, isValidKey, nextChars, toKeyChar)
+import Chelleport.KeySequence (Cell, KeyGrid, KeySequence, eventToKeycode, findMatchPosition, generateKeyCells, isValidKey, nextChars, toKeyChar)
import Control.Monad (forM_, unless, void)
import Data.IORef (modifyIORef', newIORef, readIORef)
import Data.List (isPrefixOf)
import qualified Data.Text as Text
import Foreign.C (CInt)
+import SDL (($=))
import qualified SDL
import Unsafe.Coerce (unsafeCoerce)
data State = State
- { stateCells :: [[[Char]]],
- stateKeySequence :: [Char]
+ { stateCells :: KeyGrid,
+ stateKeySequence :: KeySequence
}
-data AppAction = FilterSequence SDL.Keycode | SetupGrid
+data AppAction = FilterSequence SDL.Keycode | TriggerLeftClick | SetupGrid
open :: IO ()
open = setupAppShell initialState update eventToAction render
@@ -30,24 +33,22 @@ initialState _ctx = do
columns = 16
hintKeys = "ABCDEFGHIJKLMNOPRSTUVWXYZ1234567890"
-renderKeySequence :: DrawContext -> [Char] -> [Char] -> (CInt, CInt) -> (CInt, CInt) -> IO ()
-renderKeySequence ctx keySequence cell (px, py) (wcell, hcell) = do
- let w = px * wcell
- let h = py * hcell
+renderKeySequence :: DrawContext -> KeySequence -> Cell -> (CInt, CInt) -> IO ()
+renderKeySequence ctx keySequence cell (px, py) = do
let (matched, remaining) =
if keySequence `isPrefixOf` cell
then splitAt (length keySequence) cell
else ("", cell)
+
widthRef <- newIORef 0
unless (null matched) $ do
- let pos = w
- (textWidth, _h) <- renderText ctx (SDL.V2 pos h) colorLightGray $ Text.pack matched
+ (textWidth, _h) <- renderText ctx (SDL.V2 px py) colorLightGray $ Text.pack matched
modifyIORef' widthRef (const textWidth)
unless (null remaining) $ do
prevTextWidth <- readIORef widthRef
- let pos = w + prevTextWidth
- void $ renderText ctx (SDL.V2 pos h) colorWhite $ Text.pack remaining
+ let pos = px + prevTextWidth
+ void $ renderText ctx (SDL.V2 pos py) colorWhite $ Text.pack remaining
render :: State -> DrawContext -> IO ()
render state ctx = do
@@ -55,12 +56,24 @@ render state ctx = do
let rows = stateCells state
let wcell = width `div` unsafeCoerce (length $ head rows)
let hcell = height `div` unsafeCoerce (length rows)
+
+ SDL.rendererDrawColor (ctxRenderer ctx) $= SDL.V4 255 0 0 255
+ SDL.drawLine (ctxRenderer ctx) (SDL.P $ SDL.V2 (width `div` 2) 0) (SDL.P $ SDL.V2 (width `div` 2) height)
+ SDL.drawLine (ctxRenderer ctx) (SDL.P $ SDL.V2 0 (height `div` 2)) (SDL.P $ SDL.V2 width (height `div` 2))
+
+ SDL.rendererDrawColor (ctxRenderer ctx) $= SDL.V4 100 0 0 200
forM_ (zip [0 ..] rows) $ \(rowIndex, row) -> do
+ let py = rowIndex * hcell
+ SDL.drawLine (ctxRenderer ctx) (SDL.P $ SDL.V2 0 py) (SDL.P $ SDL.V2 width py)
+
forM_ (zip [0 ..] row) $ \(colIndex, cell) -> do
- renderKeySequence ctx (stateKeySequence state) cell (colIndex, rowIndex) (wcell, hcell)
+ let px = colIndex * wcell
+ SDL.drawLine (ctxRenderer ctx) (SDL.P $ SDL.V2 px 0) (SDL.P $ SDL.V2 px height)
+ renderKeySequence ctx (stateKeySequence state) cell (px, py)
update :: State -> DrawContext -> AppAction -> IO State
update state _ctx SetupGrid = pure state
+update state ctx TriggerLeftClick = state <$ triggerMouseLeftClick ctx
update state ctx (FilterSequence key) =
case validChars >>= (\chars -> (,chars) <$> toKeyChar key) of
Just (keyChar, validChars')
@@ -74,7 +87,7 @@ update state ctx (FilterSequence key) =
Just (row, col) -> do
let x = wcell * unsafeCoerce col
let y = hcell * unsafeCoerce row
- SDL.warpMouse SDL.WarpGlobal (SDL.P $ SDL.V2 x y)
+ moveMouse x y
Nothing -> pure ()
pure state {stateKeySequence = newKeySequence}
_ -> pure state
@@ -89,6 +102,7 @@ eventToAction _state event =
SDL.KeyboardEvent ev
| isKeyPressWith ev SDL.KeycodeQ -> Just SysQuit
| isKeyPressWith ev SDL.KeycodeEscape -> Just SysQuit
+ | isKeyPressWith ev SDL.KeycodeSpace -> Just $ AppAction TriggerLeftClick
| isKeyPress ev && isValidKey (eventToKeycode ev) ->
Just $ AppAction $ FilterSequence $ eventToKeycode ev
_ -> Nothing
diff --git a/src/Chelleport/AppShell.hs b/src/Chelleport/AppShell.hs
index 74ca784..545df13 100644
--- a/src/Chelleport/AppShell.hs
+++ b/src/Chelleport/AppShell.hs
@@ -1,5 +1,6 @@
module Chelleport.AppShell where
+import Chelleport.Context (DrawContext (ctxRenderer, ctxWindow), createContext)
import Control.Monad (foldM, unless)
import SDL (($=))
import qualified SDL
@@ -9,38 +10,6 @@ data Action act = SysQuit | AppAction act
newtype SysState = SysState {sysExit :: Bool}
-data DrawContext = DrawContext
- { ctxWindow :: SDL.Window,
- ctxRenderer :: SDL.Renderer,
- ctxFont :: TTF.Font
- }
-
-createContext :: IO DrawContext
-createContext = do
- -- bounds <- fmap SDL.displayBoundsSize <$> SDL.getDisplays
- -- let windowSize = case bounds of
- -- (x : _) -> x
- -- _ -> SDL.V2 800 600
- let windowSize = SDL.V2 0 0
-
- let windowCfg =
- SDL.defaultWindow
- { SDL.windowInputGrabbed = True,
- SDL.windowMode = SDL.FullscreenDesktop,
- SDL.windowPosition = SDL.Absolute $ SDL.P $ SDL.V2 0 0,
- SDL.windowInitialSize = windowSize,
- SDL.windowBorder = False
- }
- window <- SDL.createWindow "My SDL Application" windowCfg
- renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer
- font <- TTF.load "Inter-Regular.ttf" 16
-
- SDL.windowOpacity window $= 0.6
- SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend
- SDL.rendererDrawColor renderer $= SDL.V4 0 0 0 0
-
- pure $ DrawContext {ctxWindow = window, ctxRenderer = renderer, ctxFont = font}
-
setupAppShell ::
(DrawContext -> IO state) ->
(state -> DrawContext -> appAction -> IO state) ->
@@ -62,6 +31,7 @@ setupAppShell initState update eventHandler draw = do
appLoop drawCtx (state, sysState) = do
events <- SDL.pollEvents
+ SDL.rendererDrawColor (ctxRenderer drawCtx) $= SDL.V4 0 0 0 0
SDL.clear $ ctxRenderer drawCtx
draw state drawCtx
SDL.present $ ctxRenderer drawCtx
diff --git a/src/Chelleport/Context.hs b/src/Chelleport/Context.hs
new file mode 100644
index 0000000..8ef41fd
--- /dev/null
+++ b/src/Chelleport/Context.hs
@@ -0,0 +1,46 @@
+module Chelleport.Context where
+
+import qualified Graphics.X11 as X11
+import SDL (($=))
+import qualified SDL
+import qualified SDL.Font as TTF
+
+data DrawContext = DrawContext
+ { ctxWindow :: SDL.Window,
+ ctxRenderer :: SDL.Renderer,
+ ctxFont :: TTF.Font,
+ ctxX11Display :: X11.Display
+ }
+
+createContext :: IO DrawContext
+createContext = do
+ -- bounds <- fmap SDL.displayBoundsSize <$> SDL.getDisplays
+ -- let windowSize = case bounds of
+ -- (x : _) -> x
+ -- _ -> SDL.V2 800 600
+ let windowSize = SDL.V2 0 0
+
+ let windowCfg =
+ SDL.defaultWindow
+ { SDL.windowInputGrabbed = True,
+ SDL.windowMode = SDL.FullscreenDesktop,
+ SDL.windowPosition = SDL.Absolute $ SDL.P $ SDL.V2 0 0,
+ SDL.windowInitialSize = windowSize,
+ SDL.windowBorder = False
+ }
+ window <- SDL.createWindow "My SDL Application" windowCfg
+ renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer
+ font <- TTF.load "Inter-Regular.ttf" 16
+
+ SDL.windowOpacity window $= 0.6
+ SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend
+
+ display <- X11.openDisplay ""
+
+ pure $
+ DrawContext
+ { ctxWindow = window,
+ ctxRenderer = renderer,
+ ctxFont = font,
+ ctxX11Display = display
+ }
diff --git a/src/Chelleport/Control.hs b/src/Chelleport/Control.hs
new file mode 100644
index 0000000..04362bd
--- /dev/null
+++ b/src/Chelleport/Control.hs
@@ -0,0 +1,18 @@
+module Chelleport.Control where
+
+import Chelleport.Context (DrawContext (ctxX11Display))
+import Foreign.C (CInt)
+import qualified Graphics.X11 as X11
+import qualified Graphics.X11.XTest as X11
+import qualified Graphics.X11.Xlib.Extras as X11
+import qualified SDL
+
+triggerMouseLeftClick :: DrawContext -> IO ()
+triggerMouseLeftClick ctx = do
+ let display = ctxX11Display ctx
+ X11.fakeButtonPress display X11.button1
+ X11.sync display False
+
+moveMouse :: CInt -> CInt -> IO ()
+moveMouse x y = do
+ SDL.warpMouse SDL.WarpGlobal (SDL.P $ SDL.V2 x y)
diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs
index 8401966..3c2e2a8 100644
--- a/src/Chelleport/Draw.hs
+++ b/src/Chelleport/Draw.hs
@@ -1,6 +1,6 @@
module Chelleport.Draw where
-import Chelleport.AppShell (DrawContext (ctxFont, ctxRenderer))
+import Chelleport.Context (DrawContext (ctxFont, ctxRenderer))
import Data.Text (Text)
import Data.Word (Word8)
import Foreign.C (CInt)
diff --git a/src/Chelleport/KeySequence.hs b/src/Chelleport/KeySequence.hs
index 1046a98..1bc50a5 100644
--- a/src/Chelleport/KeySequence.hs
+++ b/src/Chelleport/KeySequence.hs
@@ -2,20 +2,25 @@ module Chelleport.KeySequence where
import Data.List (isPrefixOf, nub)
import qualified Data.Map as Map
-import Data.Maybe (isJust)
import qualified SDL
+type Cell = [Char]
+
+type KeySequence = [Char]
+
+type KeyGrid = [[Cell]]
+
-- padded :: Int -> a -> [a] -> [a]
-- padded 0 _ ls = ls
-- padded n x ls
-- | length ls > n = ls
-- | otherwise = padded (n - 1) x (ls ++ [x])
-safeHead :: a -> [a] -> a
-safeHead def [] = def
-safeHead _ (x : _) = x
+-- safeHead :: a -> [a] -> a
+-- safeHead def [] = def
+-- safeHead _ (x : _) = x
-nextChars :: [Char] -> [[[Char]]] -> Maybe [Char]
+nextChars :: KeySequence -> KeyGrid -> Maybe [Char]
nextChars keys cells =
case matches of
[] -> Nothing
@@ -24,23 +29,23 @@ nextChars keys cells =
matches = concatMap (filter (isPrefixOf keys)) cells
result = concatMap (take 1 . drop (length keys)) matches
-findMatchPosition :: [Char] -> [[[Char]]] -> Maybe (Int, Int)
+findWithIndex :: (x -> Maybe r) -> Int -> [x] -> Maybe (Int, r)
+findWithIndex _pred _index [] = Nothing
+findWithIndex predicate index (x : ls) =
+ case predicate x of
+ Just item -> Just (index, item)
+ Nothing -> findWithIndex predicate (index + 1) ls
+
+findMatchPosition :: KeySequence -> KeyGrid -> Maybe (Int, Int)
findMatchPosition keys = findWithIndex findMatch 0
where
- findMatch row =
- fst <$> findWithIndex (\c -> if c == keys then Just () else Nothing) 0 row
-
- findWithIndex :: (x -> Maybe r) -> Int -> [x] -> Maybe (Int, r)
- findWithIndex _pred _index [] = Nothing
- findWithIndex predicate index (x : ls) =
- case predicate x of
- Just item -> Just (index, item)
- Nothing -> findWithIndex predicate (index + 1) ls
+ findMatch =
+ fmap fst . findWithIndex (\c -> if c == keys then Just () else Nothing) 0
isValidKey :: SDL.Keycode -> Bool
isValidKey key = Map.member key keycodeMapping
-generateKeyCells :: (Int, Int) -> [Char] -> [[[Char]]]
+generateKeyCells :: (Int, Int) -> KeySequence -> KeyGrid
generateKeyCells (rows, columns) hintKeys =
(\row -> getCellSeq row <$> [1 .. columns]) <$> [1 .. rows]
where