frpdontworksadsmiley.hs

-- some stuff taken from ocharle's SDL and netwire tutorial, https://github.com/ocharles/ocharles.org.uk--Getting-Started-with-Netwire-and-SDL/blob/master/Challenge3.hs
{-# LANGUAGE StandaloneDeriving #-}
import Data.Word (Word16)
import Data.Set (Set)
import qualified Data.Set as Set 
import qualified Graphics.UI.SDL as SDL 
import Reactive.Banana
import Reactive.Banana.Frameworks

main = do
  SDL.init [SDL.InitEverything]
  SDL.setVideoMode 640 480 32 []
  keys <- newAddHandler
  mouse <- newAddHandler
  let source = (keys, mouse)
  network <- setupNetwork source
  actuate network
  eventLoop source

eventLoop :: (EventSource (Set SDL.Keysym), EventSource (Word16, Word16)) -> IO ()
eventLoop (keys, mouse) = loop Set.empty (0, 0)
  where
  loop ks mpos = do
    event <- SDL.pollEvent
    case event of
      SDL.NoEvent -> loop ks mpos
      SDL.KeyDown k -> let ks' = Set.insert k ks
        in (return ks' >>= snd keys) >> loop ks' mpos
      SDL.KeyUp k -> let ks' = Set.delete k ks
        in (return ks' >>= snd keys) >> loop ks' mpos
      SDL.MouseMotion x y _ _ -> let mpos' = (x, y)
        in (return mpos' >>= snd mouse) >> loop ks mpos'
      SDL.Quit -> return ()
      _ -> loop ks mpos

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

setupNetwork :: (EventSource (Set SDL.Keysym), EventSource (Word16, Word16)) -> IO EventNetwork
setupNetwork (keys, mouse) = compile $ do
  bKeys <- fromChanges Set.empty $ fst keys
  bMouse <- fromChanges (0, 0) $ fst mouse
  let bSpace = fmap (keyDown SDL.SDLK_SPACE) bKeys
      eSpace = whenE bSpace $ accumE () never
  reactimate $ fmap react eSpace
  where react _ = putStrLn "space"

keyDown :: SDL.SDLKey -> Set SDL.Keysym -> Bool
keyDown k = not . Set.null . Set.filter ((== k) . SDL.symKey)

deriving instance Ord SDL.Keysym