Gloss GUI events not responding

[mohanr]

I was looking for guidance to use Gloss GUI events and react based on keystrokes. But here it is not clear how one would wait for a Gloss GUI event and react. Can I look at other examples ? Since this example is using loops I couldn't use it for my Gloss GUI.

{-----------------------------------------------------------------------------
    Event sources
------------------------------------------------------------------------------}
-- Event Sources - allows you to register event handlers
-- Your GUI framework should provide something like this for you
type EventSource a = (AddHandler a, a -> IO ())

Is this example the recommended way ? It is hidden in the documentation.

do
    (addHandler, fire) <- newAddHandler
    register addHandler putStrLn
    fire "Hello!"

The code that compiles is this. It works only the first time when eventLoop fires an event. But KeyBoard events etc. are required to react.

------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BlockArguments #-}

module Main where
import Data.IORef
import Data.Bool (bool)
import Data.IORef (newIORef, readIORef, writeIORef)
import Graphics.Gloss hiding (pictures)
import Reactive.Banana
import Reactive.Banana.Frameworks
import Graphics.Gloss.Interface.IO.Game( Event(..) )
import Graphics.Gloss.Interface.IO.Game( MouseButton(..) )
import Graphics.Gloss.Interface.IO.Game( KeyState( Down ) )
import Graphics.Gloss.Interface.IO.Game
import qualified Graphics.Gloss.Interface.IO.Game as Gloss (Event, playIO)

main = do

   picRef ← newIORef blank
   (eventHandler, event) ← newAddHandler
   -- register eventHandler eventLoop

   sources <- makeSources
   network <- compile $ networkDescriptor picRef sources
   actuate network
   eventLoop sources
   let handleEvent e@(EventKey k Down _ _) = case k of
            (SpecialKey KeySpace) -> (event e)  
            _                   -> (event e)
       handleEvent e = (event e)

   Gloss.playIO
    (InWindow "Functional Reactive" (320, 240) (800, 200))
    white
    30
    ()
    (\() -> readIORef picRef)
    (\ ev   _ → quit ev >> () <$ handleEvent ev)
    -- (\ ev () -> handleEvent ev)
    (\_ () -> pure ())
  where
    quit (EventKey (Char 's' )
                          _ _ _) = reactToKeyPress
    quit  _ = return ()

reactToKeyPress :: IO ()
reactToKeyPress = putStrLn "Key Pressed"

drawBoard :: Picture
drawBoard =
   Pictures $ [ color violet $ translate x y $ rectangleWire 90 90| x<-[0,90..180], y<-[0,90..180] ] 

makeSources =  newAddHandler

type EventSource a = (AddHandler a, a -> IO ())

addHandler :: EventSource a -> AddHandler a
addHandler = fst

eventLoop :: EventSource ()  -> IO ()
eventLoop ( displayvalueevent)  = do
  putStrLn "Fired Event"
  fire displayvalueevent ()

fire :: EventSource a -> a -> IO ()
fire = snd

networkDescriptor :: IORef Picture -> EventSource() -> MomentIO ()
networkDescriptor lastFrame  displayGlossEvent = do
  glossEvent <- fromAddHandler (addHandler displayGlossEvent )
  reactimate $ putStrLn . showValue <$> glossEvent

  picture <- liftMoment (handleKeys displayGlossEvent )
  changes picture >>= reactimate' . fmap (fmap (writeIORef lastFrame))
  valueBLater picture >>= liftIO . writeIORef lastFrame

showValue value = "Value is " ++ show value

handleKeys :: EventSource ()  -> Moment (Behavior Picture)
handleKeys glossEvent = do

  let picture = drawBoard
  return $ pure picture

Update :

Removed unused code.

Primarily I was trying to use this code to trap events and fire reactive-banana events. Maybe that isn't possible.

(eventHandler, event) ← newAddHandler
   -- register eventHandler eventLoop

   sources <- makeSources
   network <- compile $ networkDescriptor picRef sources
   actuate network
   eventLoop sources
   let handleEvent e@(EventKey k Down _ _) = case k of
            (SpecialKey KeySpace) -> (event e)  
            _                   -> (event e)
       handleEvent e = (event e)

If I remove the additional eventHandler then using only sources I can trigger reactive-banana events ? Somehow I couldn't make it compile.

[HeinrichApfelmus]

I'm not really familiar with Gloss, so I can't give a good answer. Your code is a bit confusing, e.g. makeNewEvent is defined, but not used. Could you try to distill a minimal example that does not work but should?

It looks like the AddHandler in sources is used by networkDescriptor to create the network, but the arguments Gloss.playIO use the other AddHandler named eventHandler that was created before — the two are talking past each other.

[mohanr]

This pattern wasn't clear. Hope it is right. This works. This is just trapping the keys and restricting. Not sure if there can be multiple networkDescriptor functions for each key. The other way is to restrict the keys inside the networkDescriptor.

   picRef ← newIORef blank

   network <- compile $ networkDescriptor picRef eventHandler
   actuate network
   let handleEvent e@(EventKey k Down _ _) = case k of
            (SpecialKey KeySpace) -> event e
            _                   -> return ()
       handleEvent e = return ()

   Gloss.playIO
    (InWindow "Functional Reactive" (320, 240) (800, 200))
    white
    30
    ()
    (\() -> readIORef picRef)
    (\ ev () -> handleEvent ev)
    (\_ () -> pure ())

[ocharles]

@mohanr I'm afraid I'm struggling to understand exactly what your question is, but I'm going to interpret it as "how do I integrate gloss events with reactive-banana". If that's not question, let me know and I'll try again! Here is one suggestion:

main :: IO ()
main = do
  -- Create an AddHandler that notifies us when gloss Events occur
  (eventAddHandler, notifyEvent) <- newAddHandler

  -- Create another AddHandler for when we want rendering to happen
  (renderAddHandler, render) <- newAddHandler

  picRef <- newIORef blank

  actuate =<< compile (game picRef eventAddHandler renderAddHandler)

  Gloss.playIO
    (InWindow "Functional Reactive" (320, 240) (800, 200))
    white
    30
    ()
    (\() -> render >> readIORef picRef)
    (\ev _ -> notifyEvent ev)
    (\_ () -> pure ())

game :: IORef Picture -> AddHandler Gloss.Event -> AddHandler () -> MomentIO ()
game picRef eventAddHandler renderAddHandler = do
  onEvent <- fromAddHandler eventAddHandler
  onSample <- fromAddHandler sampleAddHandler

  -- Here we accumulate gloss events into a new world satte
  worldState <- accumB .. ..

  -- Whenever 'onRender' fires
  reactimate $ writeIORef picRef . drawWorld <$> worldState <@ onRender

[ocharles]

@mohanr Was my response above helpful? Can we close this issue, or are you still stuck?

[mohanr]

game picRef eventAddHandler renderAddHandler = do
  onEvent <- fromAddHandler eventAddHandler
  onSample <- fromAddHandler sampleAddHandler

  -- Here we accumulate gloss events into a new world state. 'accumB' means that I just draw a new state ?
  worldState <- accumB .. ..

  -- Whenever 'onRender' fires. Could you explain what 'onRender' here means ?
  reactimate $ writeIORef picRef . drawWorld <$> worldState <@ onRender

I have these 'inlined' questions as now I do this. Am I complicating this ? It works though but the new Picture is just very simple.

networkDescriptor :: IORef Picture -> EventSource() -> MomentIO ()
networkDescriptor lastFrame  displayGlossEvent = do
  glossEvent <- fromAddHandler (addHandler displayGlossEvent )
  reactimate $ putStrLn . showValue <$> glossEvent

  picture <- liftMoment (handleKeys displayGlossEvent )
  changes picture >>= reactimate' . fmap (fmap (writeIORef lastFrame))
  valueBLater picture >>= liftIO . writeIORef lastFrame

showValue value = "Value is " ++ show value

handleKeys :: EventSource ()  -> Moment (Behavior Picture)
handleKeys glossEvent = do

  let picture = drawBoard
  return $ pure picture