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     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 metaBindings = lowerToo
 171     [ ('C', CmdSelCodename Nothing)
 172     , ('H', CmdHome)
 173     , ('B', CmdBackCodename)
 174     , ('S', CmdSolve Nothing)
 175     , ('D', CmdDeclare Nothing)
 176     , ('V', CmdViewSolution Nothing)
 177     , ('R', CmdRegister True)
 178     , ('R', CmdRegister False)
 179     , ('P', CmdPlaceLock Nothing)
 180     , ('E', CmdEdit)
 181     , ('L', CmdSelectLock)
 182     , ('O', CmdPrevLock)
 183     , ('N', CmdNextLock)
 184     , ('A', CmdAuth)
 185     , ('T', CmdTutorials)
 186     , ('+', CmdShowRetired)
 187     , ('#', CmdPlayLockSpec Nothing)
 188     , ('$', CmdSetServer)
 189     , ('^', CmdToggleCacheOnly)
 190     , ('>', CmdNextPage)
 191     , ('<', CmdPrevPage)
 192     ] ++ miscGlobal
 193
 194 impatienceBindings = lowerToo
 195     [ ('Q', CmdQuit)
 196     , (ctrl 'C', CmdQuit) ]
 197
 198 bindings :: InputMode -> KeyBindings
 199 bindings IMEdit       = editBindings
 200 bindings IMPlay       = playBindings
 201 bindings IMMeta       = metaBindings
 202 bindings IMReplay     = replayBindings
 203 bindings IMImpatience = impatienceBindings
 204 bindings _            = []
 205
 206 findBindings :: KeyBindings -> Command -> [Char]
 207 findBindings bdgs cmd = nub
 208     $ [ ch | (ch,cmd') <- bdgs, cmd'==cmd ]
 209     ++ [ ch | CmdInputChar ch <- [cmd] ]
 210
 211 findBinding :: KeyBindings -> Command -> Maybe Char
 212 findBinding = (listToMaybe.) . findBindings
 213
 214 showKey ch
 215     | isAscii (unmeta ch) = 'M':'-':showKey (unmeta ch)
 216     | isPrint ch = [ch]
 217     | isPrint (unctrl ch) = '^':[unctrl ch]
 218     | otherwise = "[?]"
 219
 220 showKeyFriendly ' '  = "space"
 221 showKeyFriendly '\r' = "return"
 222 showKeyFriendly '\n' = "newline"
 223 showKeyFriendly '\t' = "tab"
 224 showKeyFriendly '\b' = "bksp"
 225 showKeyFriendly ch   = showKey ch
 226
 227 showKeyFriendlyShort '\r' = "ret"
 228 showKeyFriendlyShort '\t' = "tab"
 229 showKeyFriendlyShort '\b' = "bksp"
 230 showKeyFriendlyShort ch   = showKey ch