Add 'users/glittershark/xanthous/' from commit '53b56744f4'

git-subtree-dir: users/glittershark/xanthous
git-subtree-mainline: 91f53f02d8
git-subtree-split: 53b56744f4

users/glittershark/xanthous/src/Xanthous/Command.hs

@@ -0,0 +1,73 @@
+--------------------------------------------------------------------------------
+module Xanthous.Command where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude hiding (Left, Right, Down)
+--------------------------------------------------------------------------------
+import Graphics.Vty.Input (Key(..), Modifier(..))
+import qualified Data.Char as Char
+--------------------------------------------------------------------------------
+import Xanthous.Data (Direction(..))
+--------------------------------------------------------------------------------
+
+data Command
+  = Quit
+  | Move Direction
+  | StartAutoMove Direction
+  | PreviousMessage
+  | PickUp
+  | Drop
+  | Open
+  | Close
+  | Wait
+  | Eat
+  | Look
+  | Save
+  | Read
+  | ShowInventory
+  | Wield
+  | GoUp
+  | GoDown
+
+    -- | TODO replace with `:` commands
+  | ToggleRevealAll
+
+commandFromKey :: Key -> [Modifier] -> Maybe Command
+commandFromKey (KChar 'q') [] = Just Quit
+commandFromKey (KChar '.') [] = Just Wait
+commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir
+commandFromKey (KChar c) []
+  | Char.isUpper c
+  , Just dir <- directionFromChar $ Char.toLower c
+  = Just $ StartAutoMove dir
+commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
+commandFromKey (KChar ',') [] = Just PickUp
+commandFromKey (KChar 'd') [] = Just Drop
+commandFromKey (KChar 'o') [] = Just Open
+commandFromKey (KChar 'c') [] = Just Close
+commandFromKey (KChar ';') [] = Just Look
+commandFromKey (KChar 'e') [] = Just Eat
+commandFromKey (KChar 'S') [] = Just Save
+commandFromKey (KChar 'r') [] = Just Read
+commandFromKey (KChar 'i') [] = Just ShowInventory
+commandFromKey (KChar 'w') [] = Just Wield
+commandFromKey (KChar '<') [] = Just GoUp
+commandFromKey (KChar '>') [] = Just GoDown
+
+-- DEBUG COMMANDS --
+commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
+
+commandFromKey _ _ = Nothing
+
+--------------------------------------------------------------------------------
+
+directionFromChar :: Char -> Maybe Direction
+directionFromChar 'h' = Just Left
+directionFromChar 'j' = Just Down
+directionFromChar 'k' = Just Up
+directionFromChar 'l' = Just Right
+directionFromChar 'y' = Just UpLeft
+directionFromChar 'u' = Just UpRight
+directionFromChar 'b' = Just DownLeft
+directionFromChar 'n' = Just DownRight
+directionFromChar '.' = Just Here
+directionFromChar _   = Nothing