module Game.LambdaHack.Client.Key
( Key(..), showKey, handleDir, dirAllKey
, moveBinding, mkKM, keyTranslate
, Modifier(..), KM(..), showKM
, escKM, spaceKM, returnKM, pgupKM, pgdnKM
) where
import Control.Exception.Assert.Sugar
import Data.Binary
import qualified Data.Char as Char
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Prelude hiding (Left, Right)
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Vector
data Key =
Esc
| Return
| Space
| Tab
| BackTab
| BackSpace
| PgUp
| PgDn
| Left
| Right
| Up
| Down
| End
| Begin
| Insert
| Delete
| Home
| KP !Char
| Char !Char
| Unknown !Text
deriving (Read, Ord, Eq, Generic)
instance Binary Key
data Modifier =
NoModifier
| Control
deriving (Read, Ord, Eq, Generic)
instance Binary Modifier
data KM = KM {modifier :: !Modifier, key :: !Key}
deriving (Read, Ord, Eq, Generic)
instance Show KM where
show = T.unpack . showKM
instance Binary KM
showKey :: Key -> Text
showKey (Char c) = T.singleton c
showKey Esc = "ESC"
showKey Return = "RET"
showKey Space = "SPACE"
showKey Tab = "TAB"
showKey BackTab = "SHIFT-TAB"
showKey BackSpace = "BACKSPACE"
showKey Up = "UP"
showKey Down = "DOWN"
showKey Left = "LEFT"
showKey Right = "RIGHT"
showKey Home = "HOME"
showKey End = "END"
showKey PgUp = "PGUP"
showKey PgDn = "PGDOWN"
showKey Begin = "BEGIN"
showKey Insert = "INSERT"
showKey Delete = "DELETE"
showKey (KP c) = "KEYPAD_" <> T.singleton c
showKey (Unknown s) = s
showKM :: KM -> Text
showKM KM{modifier=Control, key} = "CTRL-" <> showKey key
showKM KM{modifier=NoModifier, key} = showKey key
escKM :: KM
escKM = KM {modifier = NoModifier, key = Esc}
spaceKM :: KM
spaceKM = KM {modifier = NoModifier, key = Space}
returnKM :: KM
returnKM = KM {modifier = NoModifier, key = Return}
pgupKM :: KM
pgupKM = KM {modifier = NoModifier, key = PgUp}
pgdnKM :: KM
pgdnKM = KM {modifier = NoModifier, key = PgDn}
dirKeypadKey :: [Key]
dirKeypadKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left]
dirKeypadShiftChar :: [Char]
dirKeypadShiftChar = ['7', '8', '9', '6', '3', '2', '1', '4']
dirKeypadShiftKey :: [Key]
dirKeypadShiftKey = map KP dirKeypadShiftChar
dirLaptopKey :: [Key]
dirLaptopKey = map Char ['7', '8', '9', 'o', 'l', 'k', 'j', 'u']
dirLaptopShiftKey :: [Key]
dirLaptopShiftKey = map Char ['&', '*', '(', 'O', 'L', 'K', 'J', 'U']
dirViChar :: [Char]
dirViChar = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h']
dirViKey :: [Key]
dirViKey = map Char dirViChar
dirViShiftKey :: [Key]
dirViShiftKey = map (Char . Char.toUpper) dirViChar
dirMoveNoModifier :: Bool -> Bool -> [Key]
dirMoveNoModifier configVi configLaptop =
dirKeypadKey ++ if configVi then dirViKey
else if configLaptop then dirLaptopKey
else []
dirRunNoModifier :: Bool -> Bool -> [Key]
dirRunNoModifier configVi configLaptop =
dirKeypadShiftKey ++ if configVi then dirViShiftKey
else if configLaptop then dirLaptopShiftKey
else []
dirRunControl :: [Key]
dirRunControl = dirKeypadKey
++ dirKeypadShiftKey
++ (map Char dirKeypadShiftChar)
dirAllKey :: Bool -> Bool -> [Key]
dirAllKey configVi configLaptop =
dirMoveNoModifier configVi configLaptop
++ dirRunNoModifier configVi configLaptop
++ dirRunControl
handleDir :: Bool -> Bool -> KM -> (Vector -> a) -> a -> a
handleDir configVi configLaptop KM{modifier=NoModifier, key} h k =
let assocs = zip (dirAllKey configVi configLaptop) $ cycle moves
in maybe k h (lookup key assocs)
handleDir _ _ _ _ k = k
moveBinding :: Bool -> Bool -> (Vector -> a) -> (Vector -> a)
-> [(KM, a)]
moveBinding configVi configLaptop move run =
let assign f (km, dir) = (km, f dir)
mapMove modifier keys =
map (assign move) (zip (zipWith KM (repeat modifier) keys) moves)
mapRun modifier keys =
map (assign run) (zip (zipWith KM (repeat modifier) keys) moves)
in mapMove NoModifier (dirMoveNoModifier configVi configLaptop)
++ mapRun NoModifier (dirRunNoModifier configVi configLaptop)
++ mapRun Control dirRunControl
mkKM :: String -> KM
mkKM s = let mkKey sk =
case keyTranslate sk of
Unknown _ ->
assert `failure` "unknown key" `twith` s
key -> key
in case s of
('C':'T':'R':'L':'-':rest) -> KM {key=mkKey rest, modifier=Control}
_ -> KM {key=mkKey s, modifier=NoModifier}
keyTranslate :: String -> Key
keyTranslate "less" = Char '<'
keyTranslate "greater" = Char '>'
keyTranslate "period" = Char '.'
keyTranslate "colon" = Char ':'
keyTranslate "semicolon" = Char ';'
keyTranslate "comma" = Char ','
keyTranslate "question" = Char '?'
keyTranslate "dollar" = Char '$'
keyTranslate "parenleft" = Char '('
keyTranslate "parenright" = Char ')'
keyTranslate "asterisk" = Char '*'
keyTranslate "KP_Multiply" = KP '*'
keyTranslate "slash" = Char '/'
keyTranslate "KP_Divide" = Char '/'
keyTranslate "backslash" = Char '\\'
keyTranslate "underscore" = Char '_'
keyTranslate "minus" = Char '-'
keyTranslate "KP_Subtract" = Char '-'
keyTranslate "plus" = Char '+'
keyTranslate "KP_Add" = Char '+'
keyTranslate "equal" = Char '='
keyTranslate "bracketleft" = Char '['
keyTranslate "bracketright" = Char ']'
keyTranslate "braceleft" = Char '{'
keyTranslate "braceright" = Char '}'
keyTranslate "ampersand" = Char '&'
keyTranslate "apostrophe" = Char '\''
keyTranslate "Escape" = Esc
keyTranslate "Return" = Return
keyTranslate "space" = Space
keyTranslate "Tab" = Tab
keyTranslate "ISO_Left_Tab" = BackTab
keyTranslate "BackSpace" = BackSpace
keyTranslate "Up" = Up
keyTranslate "KP_Up" = Up
keyTranslate "Down" = Down
keyTranslate "KP_Down" = Down
keyTranslate "Left" = Left
keyTranslate "KP_Left" = Left
keyTranslate "Right" = Right
keyTranslate "KP_Right" = Right
keyTranslate "Home" = Home
keyTranslate "KP_Home" = Home
keyTranslate "End" = End
keyTranslate "KP_End" = End
keyTranslate "Page_Up" = PgUp
keyTranslate "KP_Page_Up" = PgUp
keyTranslate "Prior" = PgUp
keyTranslate "KP_Prior" = PgUp
keyTranslate "Page_Down" = PgDn
keyTranslate "KP_Page_Down" = PgDn
keyTranslate "Next" = PgDn
keyTranslate "KP_Next" = PgDn
keyTranslate "Begin" = Begin
keyTranslate "KP_Begin" = Begin
keyTranslate "Clear" = Begin
keyTranslate "KP_Clear" = Begin
keyTranslate "Center" = Begin
keyTranslate "KP_Center" = Begin
keyTranslate "Insert" = Insert
keyTranslate "KP_Insert" = Insert
keyTranslate "Delete" = Delete
keyTranslate "KP_Delete" = Delete
keyTranslate "KP_Enter" = Return
keyTranslate ['K','P','_',c] = KP c
keyTranslate [c] = Char c
keyTranslate s = Unknown $ T.pack s