{-
******************************************************************************
*                              I N V A D E R S                               *
*                                                                            *
*       Module:         Parser                                               *
*       Purpose:        Parsing (mainly lexical analysis) of window event    *
*                       stream.                                              *
*       Author:         Henrik Nilsson                                       *
*                                                                            *
*             Copyright (c) Yale University, 2003                            *
*                                                                            *
******************************************************************************
-}

-- Quick 'n dirty adaptation from old robot simulator. Could probably be
-- done better in the new AFRP framework.

module Parser (
    GameInput,          -- Abstract
    parseWinInput,      -- :: SF WinInput GameInput
    command,            -- :: SF GameInput (Event Command)
    cmdString,          -- :: SF GameInput (Event String)
    ptrPos,             -- :: SF GameInput Position2
    lbp,                -- :: SF GameInput (Event ())
    lbpPos,             -- :: SF GameInput (Event Position2)
    lbDown,             -- :: SF GameInput Bool
    rbp,                -- :: SF GameInput (Event ())
    rbpPos,             -- :: SF GameInput (Event Position2)
    rbDown,             -- :: SF GameInput Bool
    dragStart,          -- :: SF GameInput (Event ())
    dragStop,           -- :: SF GameInput (Event Distance2)
    dragStartPos,       -- :: SF GameInput Position2
    dragVec,            -- :: SF GameInput Distance2
    dragging            -- :: SF GameInput Bool
) where

import Data.AffineSpace (origin, (.-.))
import Data.Maybe (isNothing, isJust)
import qualified Graphics.HGL as HGL (Event(..))
import Data.Char (ord, isSpace, isDigit)

import FRP.Yampa

import PhysicalDimensions
import WorldGeometry (gPointToPosition2)
import Command
import Animate (WinInput)

------------------------------------------------------------------------------
-- Exported entities
------------------------------------------------------------------------------

data GameInput = GameInput {
    giCmdStr :: String,
    giCmd    :: Event Command,
    giPDS    :: PDState
}


parseWinInput :: SF WinInput GameInput
parseWinInput = wiToCmd &&& wiToPDS
                >>^ \((cmdStr, cmd), pds) ->
                        GameInput {giCmdStr = cmdStr, giCmd = cmd, giPDS = pds}


-- All event sources below are defined such that they will NOT occur at local
-- time 0 (immediately after a switch). Sometimes explicitly using a "notYet".
-- Sometimes using through careful use of "edge" and relatives. Is this the
-- right approach?

-- A valid command has been read.
command :: SF GameInput (Event Command)
command = giCmd ^>> notYet


-- Continuous parser feed back.
cmdString :: SF GameInput String
cmdString = arr giCmdStr


ptrPos :: SF GameInput Position2
ptrPos = arr (pdsPos . giPDS)


lbp :: SF GameInput (Event ())
lbp = lbpPos >>^ (`tag` ())


lbpPos :: SF GameInput (Event Position2)
lbpPos = (giPDS >>> pdsLeft) ^>> edgeJust


lbDown :: SF GameInput Bool
lbDown = arr (giPDS >>> pdsLeft >>> isJust)


rbp :: SF GameInput (Event ())
rbp = rbpPos >>^ (`tag` ())


rbpPos :: SF GameInput (Event Position2)
rbpPos = (giPDS >>> pdsRight) ^>> edgeJust


rbDown :: SF GameInput Bool
rbDown = arr (giPDS >>> pdsRight >>> isJust)


dragStart :: SF GameInput (Event ())
dragStart = (giPDS >>> pdsDrag) ^>> edgeBy detectStart (Just undefined)
    where
        detectStart Nothing  (Just _) = Just ()
        detectStart _        _        = Nothing


dragStop :: SF GameInput (Event Distance2)
dragStop = ((giPDS >>> pdsDrag) ^>> edgeBy detectStop Nothing) &&& dragVec
           >>^ \(e, dv) -> e `tag` dv
    where
        detectStop (Just _) Nothing = Just ()
        detectStop _        _       = Nothing


-- (Last) drag start position.
dragStartPos :: SF GameInput Position2
dragStartPos = arr (giPDS >>> pdsDragStartPos)


-- (Last) drag vector.
dragVec :: SF GameInput Distance2
dragVec = arr (giPDS >>> pdsDragVec)


dragging :: SF GameInput Bool
dragging = arr (giPDS >>> pdsDrag >>> isJust)


------------------------------------------------------------------------------
-- Lexical analysis of character input 
------------------------------------------------------------------------------

-- Currently overkill, but being able to enter multi-character commands
-- could possibly be useful.

wiToCmd :: SF WinInput (String, Event Command)
wiToCmd = arr (mapFilterE selChar)
          >>> (accumBy scanChar (undefined,scanCmds) >>^ fmap fst >>^ splitE)
          >>> hold "" *** arr (mapFilterE id)
    where
        scanChar (_, S cont) c = cont c

        selChar (HGL.Char {HGL.char=c}) = Just c
        selChar _                       = Nothing


-- This ought to be redone. Kont should probably be called Tranition or
-- somethinig.

-- We define a continuation to be the command recognized thus far (a String
-- and maybe a complete Command), and a scanner to be applied to the rest
-- of the input. (I.e., there's output at every step.)

type Kont = ((String, Maybe Command), Scanner)
type Cont a = a -> Kont

-- Since a scanner is applied to one character at a time (typically, on
-- Char events), we recursively define a scanner to be a character
-- continuation.

newtype Scanner = S (Cont Char)

-- Scan commands

scanCmds :: Scanner
scanCmds = scanCmd cmds
    where
        cmds =
            [ ("q", emitCmd scanCmds CmdQuit), -- Discard inp.?
              ("p", emitCmd scanCmds CmdNewGame), 
              ("f", emitCmd scanCmds CmdFreeze),
              ("r", emitCmd scanCmds CmdResume)
            ]


-- Scan one command.
-- Looks for a valid command. Outputs prefix as long as the current
-- prefix is valid. Starts over on first invalid character. Invokes success
-- continuation on success.
-- cmds ....... List of pairs of valid command and corresponding success
--              continuation. 

scanCmd :: [(String, Cont String)] -> Scanner
scanCmd cmds = scanSubCmd "" cmds


-- Scan one subcommand/keyword argument.
-- Looks for a valid command. Outputs prefix as long as the current
-- prefix is valid. Starts over on first invalid character. Invokes success
-- continuation on success.
-- pfx0 ....... Initial prefix.
-- cmds ....... List of pairs of valid command and corresponding success
--              continuation. 

scanSubCmd :: String -> [(String, Cont String)] -> Scanner
scanSubCmd pfx0 cmds = S (scHlp pfx0 cmds)
    where
        -- pfx ........ Command prefix.
        -- sfxconts ... Command suffixes paired with success continuations.
        -- c .......... Input character.
        scHlp pfx sfxconts c =
            case c of
                '\r' ->
                    case [ cont | ("", cont) <- sfxconts ] of
                       []         -> emitPfx (S (scHlp pfx sfxconts)) pfx
                       (cont : _) -> cont pfx
                '.'  ->
                    case sfxconts of
                        []            -> emitPfx (S (scHlp pfx0 cmds)) pfx0
                        [(sfx, cont)] -> cont (pfx ++ sfx)
                        _             ->
                            let
                                (sfxs, conts) = unzip sfxconts
                                cpfx          = foldr1 lcp sfxs
                                sfxs'         = map (drop (length cpfx)) sfxs
                                pfx'          = pfx ++ cpfx
                                sfxconts'     = zip sfxs' conts
                            in
                                emitPfx (S (scHlp pfx' sfxconts')) pfx'
                _    ->
                    let
                        pfx' = pfx ++ [c]
                        sfxconts' = [ (tail sfx, cont)
                                    | (sfx, cont) <- sfxconts,
                                      not (null sfx) && head sfx == c
                                    ]
                    in
                        case sfxconts' of
                            []           -> emitPfx (S (scHlp pfx0 cmds))
                                                    pfx0
                                                    -- ("Invalid: " ++ [c])
                            [("", cont)] -> cont pfx'
                            _            -> emitPfx (S (scHlp pfx' sfxconts'))
                                                    pfx'


-- Scan fixed-length integer argument.
-- pfx0 ....... Initial prefix (command scanned thus far).
-- n0 ......... Maximal number of digits.
-- cont ....... Continuation: will be passed the new prefix and the
--              integer value of the scanned argument.

scanIntegerArg :: String -> Int -> Cont (String,Integer) -> Scanner
scanIntegerArg pfx0 n0 cont | n0 > 0 = S (siaHlp (pfx0 ++ " ") n0 0)
    where
        siaHlp pfx n a c =
            if c == '\r' then
                cont (pfx, a)
            else if isDigit c then
                let a'   = a * 10 + fromIntegral (ord c - ord '0')
                    pfx' = pfx ++ [c]
                in
                    if n > 1 then
                        emitPfx (S (siaHlp pfx' (n - 1) a')) pfx'
                    else
                        cont (pfx', a')
            else
                emitPfx (S (siaHlp (pfx0 ++ " ") n0 0)) pfx0


-- Scan variable-length string argument.
-- pfx0 ....... Initial prefix (command scanned thus far).
-- cont ....... Continuation: will be passed the new prefix and the
--              string value of the scanned argument.

scanStringArg :: String -> Cont (String,String) -> Scanner
scanStringArg pfx0 cont = S (ssaHlp (pfx0 ++ " ") "")
    where
        ssaHlp pfx a c =
            if c == '\r' then
                cont (pfx, a)
            else
                let a'   = dropWhile isSpace $ a ++ [c]
                    pfx' = pfx ++ [c]
                in
                    emitPfx (S (ssaHlp pfx' a')) pfx'


-- Emit command (and command string), then continue scanning.
emitCmd :: Scanner -> Command -> String -> Kont
emitCmd scanner cmd cmdStr = ((cmdStr, Just cmd), scanner)


-- Emit current prefix, then scan next character.
emitPfx :: Scanner -> String -> Kont
emitPfx scanner pfx = ((pfx, Nothing), scanner)


------------------------------------------------------------------------------
-- Pointing device processing
------------------------------------------------------------------------------

-- State of the pointing device.
-- The points for pdsLeft, pdsRight, and pdsDrag reflect where the button
-- was initially pressed.


data PDState = PDState {
    pdsPos          :: Position2,               -- Current position.
    pdsDragStartPos :: Position2,               -- (Last) drag start position.
    pdsDragVec      :: Distance2,               -- (Latest) drag vector.
    pdsLeft         :: Maybe Position2,         -- Left button currently down.
    pdsRight        :: Maybe Position2,         -- Right button currently down.
    pdsDrag         :: Maybe Position2          -- Currently dragging.
}


-- Initial state.
initPDS = PDState {
              pdsPos          = origin,
              pdsDragStartPos = origin,
              pdsDragVec      = zeroVector,
              pdsLeft         = Nothing,
              pdsRight        = Nothing,
              pdsDrag         = Nothing
          }


wiToPDS :: SF WinInput PDState
wiToPDS = accumHoldBy nextPDS initPDS


-- Compute next pointing device state.
nextPDS :: PDState -> HGL.Event -> PDState
nextPDS pds (HGL.Key {}) = pds                  -- Currently we ignore keys.
nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = True, HGL.isDown = True}) =
    -- Left button pressed.
    pds {pdsPos = p', pdsDragVec = dv, pdsLeft = Just p'}
    where
        p' = gPointToPosition2 p
        dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) (pdsDrag pds)
nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = True, HGL.isDown = False}) =
    -- Left button released.
    pds {pdsPos = p', pdsDragVec = dv, pdsLeft = Nothing, pdsDrag = md}
    where
        p' = gPointToPosition2 p
        md = maybe Nothing (const (pdsDrag pds)) (pdsRight pds)
        dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md
nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = False, HGL.isDown = True}) =
    -- Right button pressed.
    pds {pdsPos = p', pdsDragVec = dv, pdsRight = Just p'}
    where
        p' = gPointToPosition2 p
        dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) (pdsDrag pds)
nextPDS pds (HGL.Button {HGL.pt = p, HGL.isLeft = False, HGL.isDown = False}) =
    -- Right button released.
    pds {pdsPos = p', pdsDragVec = dv, pdsRight = Nothing, pdsDrag = md}
    where
        p' = gPointToPosition2 p
        md = maybe Nothing (const (pdsDrag pds)) (pdsLeft pds)
        dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md
nextPDS pds (HGL.MouseMove {HGL.pt = p}) =
    -- Mouse move.
    pds {pdsPos = p', pdsDragStartPos = dsp, pdsDragVec = dv, pdsDrag = md}
    where
        p' = gPointToPosition2 p
        md = case pdsLeft pds of
                 mlp@(Just _) -> mlp
                 Nothing      -> pdsRight pds
        dsp = maybe (pdsDragStartPos pds) id md
        dv = maybe (pdsDragVec pds) (\dspos -> p' .-. dspos) md
nextPDS pds _ = pds                             -- Ignore unknown events.


------------------------------------------------------------------------------
-- General utilities
------------------------------------------------------------------------------

-- Longest common prefix.
lcp :: Eq a => [a] -> [a] -> [a]
lcp []     _                  = []
lcp _      []                 = []
lcp (x:xs) (y:ys) | x == y    = x : lcp xs ys
                  | otherwise = []