content: {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE CPP                       #-}
  -- |
  -- Copyright  : (c) Ivan Perez & Henrik Nilsson, 2014.
  -- License    : See LICENSE file.
  -- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>
  --
  -- Defines an abstraction for the game controller and the functions to read it.
  --
  -- Lower-level devices replicate the higher-level API, and should accommodate to
  -- it. Each device should:
  --
  --    - Upon initialisation, return any necessary information to poll it again.
  --
  --    - Update the controller with its own values upon sensing.
  --
  -- In this case, we only have two: a wiimote and a mouse/keyboard combination.
  -- If the wiimote is available, then the mouse isn't used.
  --
  -- It's very easy to add new devices. In particular, adding a Kinect using the
  -- freenect library is easy (see github.com/keera-studios/freenect) for an
  -- updated version.
  --
  -- Limitations:
  --
  --    - Device failures are not handled.
  --
  --    - Falling back to the next available device when there's a problem.
  --
  --    - Keymap configuration (having an intermediate Action-based layer).
  --
  --    - Using more than one device at a time. Changing that would be a one-line
  --    patch.
  --
  module Input where
  
  -- External imports
  import Control.Monad
  import Data.IORef
  import Graphics.UI.SDL as SDL
  
  -- External imports (Wiimote)
  #ifdef wiimote
  import Control.Monad        (void)
  import Control.Monad.IfElse (awhen)
  import Data.Maybe           (fromMaybe)
  import System.CWiid
  #endif
  
  -- External imports (Kinect)
  #ifdef kinect
  import           Control.Concurrent
  import           Data.Vector.Storable (Vector, (!))
  import qualified Data.Vector.Storable as V
  import           Data.Word
  import           Freenect
  #endif
  
  -- Internal imports
  import Constants
  import Control.Extra.Monad
  import Graphics.UI.Extra.SDL
  
  -- * Game controller
  
  -- | Controller info at any given point.
  data Controller = Controller
    { controllerPos   :: (Double, Double)
    , controllerClick :: Bool
    , controllerPause :: Bool
    , controllerQuit  :: Bool
    }
  
  -- | Controller info at any given point, plus a pointer to poll the main device
  -- again. This is safe, since there is only one writer at a time (the device
  -- itself).
  newtype ControllerRef =
    ControllerRef (IORef Controller, Controller -> IO Controller)
  
  -- * General API
  
  -- | Initialize the available input devices. This operation returns a reference
  -- to a controller, which enables getting its state as many times as necessary.
  -- It does not provide any information about its nature, abilities, etc.
  initializeInputDevices :: IO ControllerRef
  initializeInputDevices = do
      let baseDev = sdlGetController
  
  -- Fall back to mouse/kb is no kinect is present
  #ifdef kinect
      print "Kinecting"
      dev <- do kn <- kinectController
                case kn of
                  Nothing  -> return baseDev
                  Just kn' -> return kn'
  #else
      let dev = baseDev
  #endif
  
  -- Fall back to kinect or mouse/kb is no wiimote is present
  #ifdef wiimote
      dev' <- do wm <- wiimoteDev
                 return $ fromMaybe dev wm
  #else
      let dev' = dev
  #endif
  
      nr <- newIORef defaultInfo
      return $ ControllerRef (nr, dev')
    where
      defaultInfo = Controller (0, 0) False False False
  
  -- | Sense from the controller, providing its current state. This should return
  -- a new Controller state if available, or the last one there was.
  --
  -- It is assumed that the sensing function is always callable, and that it
  -- knows how to update the Controller info if necessary.
  senseInput :: ControllerRef -> IO Controller
  senseInput (ControllerRef (cref, sensor)) = do
    cinfo <- readIORef cref
    cinfo' <- sensor cinfo
    writeIORef cref cinfo'
    return cinfo'
  
  type ControllerDev = IO (Maybe (Controller -> IO Controller))
  
  -- * WiiMote API (mid-level)
  #ifdef wiimote
  
  -- | The wiimote controller as defined using this abstract interface. See
  -- 'initializeWiimote'.
  wiimoteDev :: ControllerDev
  wiimoteDev = initializeWiimote
  
  -- ** Initialisation
  
  -- | Initializes the wiimote, optionally returning the sensing function. It
  -- returns Nothing if the Wiimote cannot be detected. Users should have a BT
  -- device and press 1+2 to connect to it. A message is shown on stdout.
  initializeWiimote :: ControllerDev
  initializeWiimote = do
    putStrLn "Initializing WiiMote. Please press 1+2 to connect."
    wm <- cwiidOpen
    awhen wm (void . (`cwiidSetRptMode` 15)) -- Enable button reception, acc, IR
    case wm of
      Nothing -> return Nothing
      Just wm' -> return $ Just $ senseWiimote wm'
  
  -- ** Sensing
  
  -- | Sense the Wiimote and update the controller.
  --
  -- This operation uses the IR for the controller's position, and the main (A)
  -- button for the click.
  --
  -- TODO: Allow configuring the button and using other motion mechanisms
  -- (accelerometers).
  --
  -- TODO: This should be split in two operations. One that presents a nice
  -- Wii-like interface and one that actually updates the controller
  senseWiimote :: CWiidWiimote -> Controller -> IO Controller
  senseWiimote wmdev controller = do
    flags <- cwiidGetBtnState wmdev
    irs   <- cwiidGetIR wmdev
  
    -- Obtain positions of leds 1 and 2 (with a normal wii bar, those
    -- will be the ones we use).
    let led1 = irs !! 0
        led2 = irs !! 1
  
    -- Calculate mid point between sensor bar leds
    let posX = ((cwiidIRSrcPosX led1) + (cwiidIRSrcPosX led2)) `div` 2
        posY = ((cwiidIRSrcPosY led1) + (cwiidIRSrcPosY led2)) `div` 2
  
    -- Calculate proportional coordinates
    let propX = fromIntegral (1024 - posX) / 1024.0
        propY = fromIntegral (max 0 (posY - 384)) / 384.0
  
    -- Calculate game area coordinates
    let finX = width  * propX
        finY = height * propY
  
    -- Direction (old system based on buttons)
    -- let isLeft  = cwiidIsBtnPushed flags cwiidBtnLeft
    --     isRight = cwiidIsBtnPushed flags cwiidBtnRight
    --     (x, y)  = controllerPos controller
    --     x'      | isLeft    = x - wiiXDiff
    --             | isRight   = x + wiiXDiff
    --             | otherwise = x
    --     x''     = inRange (0, gameWidth) x'
    --     pos'    = (x'', y)
    -- wiiXDiff :: Float
    -- wiiXDiff = 6
  
    -- Clicks
    let isClick = cwiidIsBtnPushed flags cwiidBtnA
  
    -- Update state
    return (controller { controllerPos   = (finX, finY) -- pos'
                       , controllerClick = isClick
                       })
  #endif
  
  -- * SDL API (mid-level)
  
  -- ** Initialization
  
  -- | Dummy initialization. No device is actually initialized.
  sdlMouseKB :: ControllerDev
  sdlMouseKB = return (Just sdlGetController)
  
  -- ** Sensing
  
  -- | Sense the SDL keyboard and mouse and update the controller. It only senses
  -- the mouse position, the primary mouse button, and the p key to pause the
  -- game.
  --
  -- We need a non-blocking controller-polling function.
  -- TODO: Check http://gameprogrammer.com/fastevents/fastevents1.html
  sdlGetController :: Controller -> IO Controller
  sdlGetController info =
    foldLoopM info pollEvent (not.isEmptyEvent) ((return .) . handleEvent)
  
  -- | Handles one event only and returns the updated controller.
  handleEvent :: Controller -> SDL.Event -> Controller
  handleEvent c e =
    case e of
      MouseMotion x y _ _ ->
        c { controllerPos = (fromIntegral x, fromIntegral y)}
      MouseButtonDown _ _ ButtonLeft ->
        c { controllerClick = True }
      MouseButtonUp _ _ ButtonLeft ->
        c { controllerClick = False}
      KeyUp Keysym { symKey = SDLK_p } ->
        c { controllerPause = not (controllerPause c) }
      KeyDown Keysym { symKey = SDLK_SPACE } ->
        c { controllerClick = True  }
      KeyUp Keysym { symKey = SDLK_SPACE } ->
        c { controllerClick = False }
      KeyDown Keysym { symKey = SDLK_q } ->
        c { controllerQuit  = True  }
      _ -> c
  
  -- Kinect
  
  #ifdef kinect
  kinectController :: ControllerDev
  kinectController = do
    kref <- initializeKinect (gameWidth, gameHeight)
    return $ Just $ kinectGetController kref
  
  kinectGetController :: KinectPosRef -> Controller -> IO Controller
  kinectGetController kinectPosRef c = do
    kinectPos  <- readIORef kinectPosRef
    c' <- sdlGetController c
    let c'' = maybe c' (\p -> c' { controllerPos = p }) kinectPos
    return c''
  
  -- TODO Use these instead of hard-coded values
  kinectWidth, kinectHeight :: Int
  kinectWidth  = 640
  kinectHeight = 480
  
  type KinectPosRef = IORef KinectPos
  
  type KinectPos = Maybe (Double, Double)
  
  initializeKinect :: (Double, Double) -> IO KinectPosRef
  initializeKinect screenSize = do
    lastPos <- newIORef Nothing
    _ <- getDepthThread screenSize lastPos
    return lastPos
  
  getDepthThread :: (Double, Double) -> KinectPosRef -> IO ThreadId
  getDepthThread screenSize lastPos = forkIO $ do
      withContext $ \context -> do
        setLogLevel LogFatal context
        selectSubdevices context devices
        withDevice context index $ \device -> do
          setDepthMode device Medium ElevenBit
          setDepthCallback device $ \payload _timestamp -> do
            maybe (print ".") -- Too far or too close
                  (updatePos lastPos)
                  (calculateMousePos screenSize payload)
            return ()
          startDepth device
          forever $ processEvents context
  
    where
      devices = [Camera]
      index = 0 :: Integer
  
  updatePos :: IORef (Maybe (Double, Double)) -> (Double, Double) -> IO ()
  updatePos lastPosRef newPos@(nx, ny) = do
    lastPosM <- readIORef lastPosRef
    let (mx, my) = case lastPosM of
                     Nothing         -> newPos
                     (Just (lx, ly)) -> (adjust 50 lx nx, adjust 50 ly ny)
    writeIORef lastPosRef (Just (mx, my))
    mx `seq` my `seq` return ()
  
  calculateMousePos :: (Double, Double)
                    -> Vector Word16
                    -> Maybe (Double, Double)
  calculateMousePos (width, height) payload =
      fmap g (findFirst payload)
    where
      g (px, py) = (mousex, mousey)
        where
          pointerx = fromIntegral (640 - px)
          pointery = fromIntegral py
          mousex   = pointerx -- pointerx * adjx
          mousey   = pointery -- pointery * adjy
          adjx     = width  / 630.0
          adjy     = height / 470.0
  
  mat :: Vector Float
  mat = V.generate 2048 $ \i ->
    let v :: Float
        v = ((fromIntegral i / 2048.0)^3) * 6.0
    in v * 6.0 * 256.0
  
  findFirst :: Vector Word16 -> Maybe (Int, Int)
  findFirst vs = fmap (\v -> (v `mod` 640, v `div` 640)) i
    where
      i = V.findIndex (\x -> mat ! (fromIntegral x) < 512) vs
  
  processPayload :: Vector Word16 -> [(Float, Int, Int)]
  processPayload ps = [(pval, tx, ty) | i <- [0 .. 640 * 480 - 1]
                                      , let pval = mat ! (fromIntegral (ps ! i))
                                      , pval < 300
                                      , let ty = i `div` 640
                                            tx = i `mod` 640
                                      ]
  
  -- Drop the fst elem, calculate the avg of snd and trd over the whole list
  avg :: [(Float, Int, Int)] -> (Int, Int)
  avg ls = (sumx `div` l, sumy `div` l)
    where
      l = length ls
      (sumx, sumy) = foldr (\(_, x, y) (rx, ry) -> (x + rx, y + ry)) (0, 0) ls
  
  -- Update a value, with a max cap
  adjust :: (Num a, Ord a) => a -> a -> a -> a
  adjust maxD old new
    | abs (old - new) < maxD = new
    | old < new              = old + maxD
    | otherwise              = old - maxD
  #endif
  