1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
module Chelleport where
import Chelleport.AppShell (Action (AppAction, SysQuit), hideWindow, setupAppShell, shutdownApp)
import Chelleport.Context (DrawContext (ctxRenderer, ctxWindow))
import Chelleport.Control (moveMouse, triggerMouseLeftClick)
import Chelleport.Draw (colorAxisLines, colorGridLines, colorLightGray, colorWhite, drawHorizontalLine, drawVerticalLine, renderText)
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 :: KeyGrid,
stateKeySequence :: KeySequence
}
data AppAction = FilterSequence SDL.Keycode | TriggerLeftClick | SetupGrid
open :: IO ()
open = setupAppShell initialState update eventToAction render
initialState :: DrawContext -> IO State
initialState _ctx = do
let cells = generateKeyCells (rows, columns) hintKeys
pure $ State {stateCells = cells, stateKeySequence = []}
where
rows = 16
columns = 16
hintKeys = "ABCDEFGHIJKLMNOPRSTUVWXYZ1234567890"
render :: State -> DrawContext -> IO ()
render state ctx = do
(SDL.V2 width height) <- SDL.get $ SDL.windowSize $ ctxWindow ctx
let grid = stateCells state
let wcell = width `div` unsafeCoerce (length $ head grid)
let hcell = height `div` unsafeCoerce (length grid)
renderGridLines state ctx
forM_ (zip [0 ..] grid) $ \(rowIndex, row) -> do
let py = rowIndex * hcell
forM_ (zip [0 ..] row) $ \(colIndex, cell) -> do
let px = colIndex * wcell
renderKeySequence ctx (stateKeySequence state) cell (px, py)
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
(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 = px + prevTextWidth
void $ renderText ctx (SDL.V2 pos py) colorWhite $ Text.pack remaining
renderGridLines :: State -> DrawContext -> IO ()
renderGridLines state ctx = do
(SDL.V2 width height) <- SDL.get $ SDL.windowSize $ ctxWindow ctx
let grid = stateCells state
let wcell = width `div` unsafeCoerce (length $ head grid)
let hcell = height `div` unsafeCoerce (length grid)
SDL.rendererDrawColor (ctxRenderer ctx) $= colorGridLines
let rows = unsafeCoerce $ length grid
let columns = unsafeCoerce $ length $ head grid
forM_ [0 .. rows] $ \rowIndex -> do
drawHorizontalLine ctx $ rowIndex * hcell
forM_ [0 .. columns] $ \colIndex -> do
drawVerticalLine ctx $ colIndex * wcell
SDL.rendererDrawColor (ctxRenderer ctx) $= colorAxisLines
drawHorizontalLine ctx (rows * hcell `div` 2)
drawVerticalLine ctx (columns * wcell `div` 2)
update :: State -> DrawContext -> AppAction -> IO State
update state _ctx SetupGrid = pure state
update state ctx TriggerLeftClick = do
hideWindow ctx
triggerMouseLeftClick ctx
shutdownApp ctx
pure state
update state ctx (FilterSequence key) =
case validChars >>= (\chars -> (,chars) <$> toKeyChar key) of
Just (keyChar, validChars')
| keyChar `elem` validChars' -> do
(SDL.V2 width height) <- SDL.get $ SDL.windowSize $ ctxWindow ctx
let newKeySequence = stateKeySequence state ++ [keyChar]
let rows = stateCells state
let wcell = width `div` unsafeCoerce (length $ head rows)
let hcell = height `div` unsafeCoerce (length rows)
case findMatchPosition newKeySequence rows of
Just (row, col) -> do
moveMouse ctx (wcell * unsafeCoerce col) (hcell * unsafeCoerce row)
Nothing -> pure ()
pure state {stateKeySequence = newKeySequence}
_ -> pure state
where
validChars = nextChars (stateKeySequence state) (stateCells state)
eventToAction :: State -> SDL.Event -> Maybe (Action AppAction)
eventToAction _state event =
case SDL.eventPayload event of
-- SDL.WindowShownEvent _ -> Just $ AppAction SetupGrid
SDL.QuitEvent -> Just SysQuit
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
isKeyPress :: SDL.KeyboardEventData -> Bool
isKeyPress keyboardEvent =
SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed
isKeyPressWith :: SDL.KeyboardEventData -> SDL.Keycode -> Bool
isKeyPressWith keyboardEvent keyCode =
isKeyPress keyboardEvent && SDL.keysymKeycode (SDL.keyboardEventKeysym keyboardEvent) == keyCode
|
