astrds-0.1: src/UInputInterface.hs

module UInputInterface where

import Data.List
import Control.Monad

-- | Minimal waiting time.
minWait = 700 :: Int 

-- | Synonyms for joystick button numbers.
joystick_QUIT = 8 :: Int
joystick_PREV = 4 :: Int
joystick_NEXT = 5 :: Int

data UInputEngine =
  UInputEngine { input_handleRunning :: InputHandler
               , input_waitForAnyKey :: IO UInput 
               }

-- | The state of user input.
data UInput =
  UInput { dirkeys    :: DirKeys         -- ^ direction keys currently pressed down
         , quit       :: Bool            -- ^ quit?
         , axes       :: (Double,Double) -- ^ joystick axes
         }


-- | Abstract keys.
data Key =
    KUp | KDown | KRight | KLeft 
  | KQuit 
  | KUnknown  
  deriving (Show, Eq)

-- | Direction (given by the keys).
type DirKeys = (Double, Double)

type InputHandler = UInput -> IO UInput

hasQuit :: UInput -> Bool
hasQuit = quit

-- | Wait for any key;
-- returns 'True' if "any key" was "quit"
waitOrQuit :: IO UInput -> IO Bool
waitOrQuit waitFAK = liftM quit waitFAK

noInput = UInput { dirkeys  = (0,0)
                 , quit     = False
                 , axes     = (0,0)
                 } 

updateDirkeys :: (DirKeys -> DirKeys) -> UInput -> UInput
updateDirkeys f ui = ui { dirkeys = f (dirkeys ui) }

addKey :: Key -> UInput -> UInput
addKey KUp    = updateDirkeys (\ (x,y) -> (x,y-1))
addKey KDown  = updateDirkeys (\ (x,y) -> (x,y+1))
addKey KLeft  = updateDirkeys (\ (x,y) -> (x-1,y))
addKey KRight = updateDirkeys (\ (x,y) -> (x+1,y))
addKey KQuit  = \ ui -> ui { quit = True }
addKey _      = id

removeKey :: Key -> UInput -> UInput
removeKey KUp    = addKey KDown
removeKey KDown  = addKey KUp
removeKey KLeft  = addKey KRight
removeKey KRight = addKey KLeft
removeKey _      = id