UserEvent.hs

module UserEvent
        (userEvent)
where
import Config
import Model                                    as M
import Data.Array.Repa                          as R
import Graphics.Gloss.Interface.Pure.Game       as G


-- | Handle user events for the Gloss `playIO` wrapper.
userEvent :: Config -> Event -> Model -> Model
userEvent config
        (EventKey key keyState mods (x, y)) 
        model

        -- Add velocity ---------------------------------------------
        | MouseButton G.RightButton     <- key
        , Down                          <- keyState
        , (x',y')                       <- windowToModel config (x,y)
        = model { clickLoc       = Just (x',y')
                , currButton     = M.RightButton }

        -- Accept shift-leftbutton for people with trackpads
        | MouseButton G.LeftButton      <- key
        , Down                          <- keyState
        , Down                          <- shift mods
        , (x',y')                       <- windowToModel config (x,y)
        = model { clickLoc       = Just (x',y')
                , currButton     = M.RightButton }

        | MouseButton G.RightButton     <- key
        , Up                            <- keyState
        , Just (locX, locY)             <- clickLoc model
        , (x',y')                       <- windowToModel config (x,y)
        = model { velocitySource = Just (SourceDensity (Z:.locY:.locX)
                                         (fromIntegral (locX-x'),fromIntegral (locY-y')))
                 , clickLoc       = Nothing
                 , currButton     = M.None }

        -- Add density ----------------------------------------------
        | MouseButton G.LeftButton <- key
        , Down                          <- keyState
        , (x',y')                       <- windowToModel config (x, y) 
        = model { densitySource  = Just (SourceDensity (Z:.y':.x') 1)
                , currButton     = M.LeftButton }

        | MouseButton G.LeftButton <- key
        , Up                       <- keyState
        = model { currButton = M.None }

        -- Reset model 
        | Char 'r' <- key
        , Down     <- keyState
        = initModel (configInitialDensity config)
                    (configInitialVelocity config)

        -- Toggle velocity display
        | Char 'v' <- key
        , Down     <- keyState
        = model { drawVelocity = not $ drawVelocity model }

        -- Quit program 
        | Char 'q' <- key
        , Down     <- keyState
        = error "Quitting"


userEvent config (EventMotion (x, y)) model
        | M.LeftButton  <- currButton model
        , (x',y')       <- windowToModel config (x, y) 
        = model { densitySource  = Just (SourceDensity (Z:.y':.x') 1)
                , currButton     = M.LeftButton
                }

userEvent config (EventMotion (x, y)) model
        | (x', y')              <- windowToModel config (x,y)
        , Just (clx, cly)       <- clickLoc model
        , M.RightButton         <- currButton model
        = model { velocitySource = Just (SourceDensity (Z:.y':.x')
                                        (fromIntegral (clx-x'), fromIntegral (cly-y')))
                , clickLoc       = Just (x',y')
                , currButton     = M.RightButton
                }

userEvent _ _ m = m

-- Converts a window location to the corresponding location in the
-- simulation.
windowToModel :: Config -> (Float, Float) -> (Int, Int)
windowToModel config (x, y) = (x', y')
 where  (scaleX, scaleY)                = configScale config
        (windowWidth, windowHeight)     = configWindowSize config

        x' = round ((x + (fromIntegral windowWidth  / 2)) / fromIntegral scaleX)
        y' = round ((y + (fromIntegral windowHeight / 2)) / fromIntegral scaleY)