KeyBindings.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 module KeyBindings (KeyBindings, bindings, findBindings, findBinding, showKey,
  12     showKeyChar, showKeyFriendly, showKeyFriendlyShort) where
  13
  14 import           Data.Bits      (xor)
  15 import           Data.Char
  16 import           Data.List
  17 import           Data.Maybe
  18
  19 import           Command
  20 import           GameStateTypes
  21 import           Hex
  22 import           InputMode
  23
  24 type KeyBindings = [ (Char,Command) ]
  25
  26 ctrl, unctrl, meta, unmeta :: Char -> Char
  27 ctrl = toEnum . xor 64 . fromEnum
  28 meta = toEnum . xor 128 . fromEnum
  29 unctrl = ctrl
  30 unmeta = meta
  31
  32 lowerToo :: KeyBindings -> KeyBindings
  33 lowerToo = concatMap addLower
  34     where addLower b@(c, cmd) = [ b, (toLower c, cmd) ]
  35
  36 qwertyViHex =
  37     [ ('l', CmdDir WHSHook hu)
  38     , ('h', CmdDir WHSHook $ neg hu)
  39     , ('b', CmdDir WHSHook hw)
  40     , ('u', CmdDir WHSHook $ neg hw)
  41     , ('y', CmdDir WHSHook hv)
  42     , ('n', CmdDir WHSHook $ neg hv)
  43     , ('L', CmdDir WHSWrench hu)
  44     , ('H', CmdDir WHSWrench $ neg hu)
  45     , ('B', CmdDir WHSWrench hw)
  46     , ('U', CmdDir WHSWrench $ neg hw)
  47     , ('Y', CmdDir WHSWrench hv)
  48     , ('N', CmdDir WHSWrench $ neg hv)
  49     , ('k', CmdRotate WHSHook 1)
  50     , ('j', CmdRotate WHSHook $ -1)
  51     ]
  52 qwertyLeftHex =
  53     [ ('d', CmdDir WHSHook hu)
  54     , ('a', CmdDir WHSHook $ neg hu)
  55     , ('z', CmdDir WHSHook hw)
  56     , ('e', CmdDir WHSHook $ neg hw)
  57     , ('w', CmdDir WHSHook hv)
  58     , ('x', CmdDir WHSHook $ neg hv)
  59     , ('D', CmdDir WHSWrench hu)
  60     , ('A', CmdDir WHSWrench $ neg hu)
  61     , ('Z', CmdDir WHSWrench hw)
  62     , ('E', CmdDir WHSWrench $ neg hw)
  63     , ('W', CmdDir WHSWrench hv)
  64     , ('X', CmdDir WHSWrench $ neg hv)
  65     , ('q', CmdRotate WHSHook 1)
  66     , ('c', CmdRotate WHSHook $ -1)
  67     , ('S', CmdWait)
  68     , ('s', CmdWait)
  69     ]
  70 dvorakMidHex =
  71     [ ('i', CmdDir WHSWrench hu)
  72     , ('e', CmdDir WHSWrench $ neg hu)
  73     , ('j', CmdDir WHSWrench hw)
  74     , ('y', CmdDir WHSWrench $ neg hw)
  75     , ('p', CmdDir WHSWrench hv)
  76     , ('k', CmdDir WHSWrench $ neg hv)
  77     ]
  78
  79 keypadHex =
  80     [ ('5', CmdWait)
  81     , ('6', CmdDir WHSSelected hu)
  82     , ('4', CmdDir WHSSelected $ neg hu)
  83     , ('1', CmdDir WHSSelected hw)
  84     , ('9', CmdDir WHSSelected $ neg hw)
  85     , ('7', CmdDir WHSSelected hv)
  86     , ('3', CmdDir WHSSelected $ neg hv)
  87     , ('8', CmdRotate WHSSelected 1)
  88     , ('2', CmdRotate WHSSelected $ -1)
  89     ]
  90
  91 miscLockGlobal = lowerToo
  92     [ ('X', CmdUndo)
  93     , ('\b', CmdUndo)
  94     , ('R', CmdRedo)
  95     , (ctrl 'R', CmdRedo)
  96     , (ctrl 'U', CmdUndo)
  97     , ('^', CmdReset)
  98     , ('.', CmdWait)
  99     , ('Z', CmdWait)
 100     , ('M', CmdMark)
 101     , ('\'', CmdJumpMark)
 102     ]
 103
 104 miscGlobal = lowerToo
 105     [ ('Q', CmdQuit)
 106     , (ctrl 'C', CmdQuit)
 107     , ('?', CmdHelp)
 108     , (ctrl 'B', CmdBind Nothing)
 109     , (ctrl 'L', CmdRedraw)
 110     , (ctrl 'Z', CmdSuspend)
 111     , ('%', CmdToggleColourMode)
 112     ]
 113
 114 lockGlobal = keypadHex ++ qwertyViHex ++ miscGlobal ++ miscLockGlobal
 115
 116 playOnly = lowerToo
 117     [ ('O', CmdOpen)
 118     , (' ', CmdWait)
 119     , ('\r', CmdWait)
 120     , ('\n', CmdWait)
 121     , ('\t', CmdToggle)
 122     , ('*', CmdTile $ WrenchTile zero)
 123     , ('/', CmdTile HookTile)
 124     , ('@', CmdTile HookTile)
 125     ]
 126 replayOnly =
 127     [ (' ', CmdReplayForward 1)
 128     ]
 129 editMisc = lowerToo
 130     [ ('P', CmdPlay)
 131     , (' ', CmdSelect)
 132     , ('\r', CmdSelect)
 133     , ('\n', CmdSelect)
 134     , ('T', CmdTest)
 135     , ('W', CmdWriteState)
 136     , (ctrl 'S', CmdWriteState)
 137     , ('=', CmdMerge)
 138     , ('+', CmdMerge)
 139     , ('&', CmdMerge)
 140     , ('0', CmdDelete)
 141     , ('E', CmdDelete)
 142     ]
 143 tilesPaintRow = lowerToo
 144     [ ('G', CmdTile BallTile)
 145     , ('F', CmdTile $ ArmTile zero False)
 146     , ('D', CmdTile $ PivotTile zero)
 147     , ('S', CmdTile $ SpringTile Relaxed zero)
 148     , ('A', CmdTile $ BlockTile [])
 149     , ('Z', CmdDelete)
 150     ]
 151 tilesAscii =
 152     [ ('o', CmdTile $ PivotTile zero)
 153     , ('O', CmdTile BallTile)
 154     , ('S', CmdTile $ SpringTile Relaxed zero)
 155     --, ('s', CmdTile $ SpringTile Stretched zero)
 156     --, ('$', CmdTile $ SpringTile Compressed zero)
 157     , ('-', CmdTile $ ArmTile zero False)
 158     --, ('-', CmdTile $ ArmTile hu False)
 159     , ('\\', CmdTile $ ArmTile hv False)
 160     , ('/', CmdTile $ ArmTile hw False)
 161     , ('@', CmdTile HookTile)
 162     , ('*', CmdTile $ WrenchTile zero)
 163     , ('#', CmdTile $ BlockTile [])
 164     ]
 165 editOnly = tilesPaintRow ++ editMisc ++ tilesAscii
 166
 167 playBindings = playOnly ++ lockGlobal
 168 replayBindings = replayOnly ++ lockGlobal
 169 editBindings = editOnly ++ lockGlobal
 170 initBindings = lowerToo
 171     [ ('S', CmdSolveInit Nothing) ] ++ miscGlobal
 172 metaBindings = lowerToo
 173     [ ('C', CmdSelCodename Nothing)
 174     , ('H', CmdHome)
 175     , ('B', CmdBackCodename)
 176     , ('S', CmdSolve Nothing)
 177     , ('D', CmdDeclare Nothing)
 178     , ('V', CmdViewSolution Nothing)
 179     , ('R', CmdRegister True)
 180     , ('R', CmdRegister False)
 181     , ('P', CmdPlaceLock Nothing)
 182     , ('E', CmdEdit)
 183     , ('L', CmdSelectLock)
 184     , ('O', CmdPrevLock)
 185     , ('N', CmdNextLock)
 186     , ('A', CmdAuth)
 187     , ('I', CmdInitiation)
 188     , ('+', CmdShowRetired)
 189     , ('#', CmdPlayLockSpec Nothing)
 190     , ('$', CmdSetServer)
 191     , ('^', CmdToggleCacheOnly)
 192     , ('>', CmdNextPage)
 193     , ('<', CmdPrevPage)
 194     ] ++ miscGlobal
 195
 196 impatienceBindings = lowerToo
 197     [ ('Q', CmdQuit)
 198     , (ctrl 'C', CmdQuit) ]
 199
 200 bindings :: InputMode -> KeyBindings
 201 bindings IMEdit       = editBindings
 202 bindings IMPlay       = playBindings
 203 bindings IMInit       = initBindings
 204 bindings IMMeta       = metaBindings
 205 bindings IMReplay     = replayBindings
 206 bindings IMImpatience = impatienceBindings
 207 bindings _            = []
 208
 209 findBindings :: KeyBindings -> Command -> [Char]
 210 findBindings bdgs cmd = nub
 211     $ [ ch | (ch,cmd') <- bdgs, cmd'==cmd ]
 212     ++ [ ch | CmdInputChar ch <- [cmd] ]
 213
 214 findBinding :: KeyBindings -> Command -> Maybe Char
 215 findBinding = (listToMaybe.) . findBindings
 216
 217 showKey :: Char -> String
 218 showKey ch
 219     | isAscii (unmeta ch) = 'M':'-':showKey (unmeta ch)
 220     | isPrint ch = [ch]
 221     | isPrint (unctrl ch) = '^':[unctrl ch]
 222     | otherwise = "[?]"
 223
 224 showKeyFriendly ' '  = "space"
 225 showKeyFriendly '\r' = "return"
 226 showKeyFriendly '\n' = "newline"
 227 showKeyFriendly '\t' = "tab"
 228 showKeyFriendly '\b' = "bksp"
 229 showKeyFriendly ch   = showKey ch
 230
 231 showKeyFriendlyShort '\r' = "ret"
 232 showKeyFriendlyShort '\t' = "tab"
 233 showKeyFriendlyShort '\b' = "bksp"
 234 showKeyFriendlyShort ch   = showKey ch
 235
 236 showKeyChar :: Char -> Char
 237 showKeyChar ch
 238     | isAscii (unmeta ch) = '['
 239     | isPrint ch = ch
 240     | isPrint (unctrl ch) = '^'
 241     | otherwise = '?'