Slight extension of http://blog.sigfpe.com/2011/10/quick-and-dirty-reinversion-of-control.html, which adds input capabilities
{-- | |
This file is a slight extension of Sigfpe's "Quick and dirty reinversion of control": | |
http://blog.sigfpe.com/2011/10/quick-and-dirty-reinversion-of-control.html | |
I only added input capabilities: yieldInput + modification to yield | |
and of course the lines in imperative (i.e. our re-captured "main loop") which have to do with getting input. | |
--} | |
import Graphics.UI.GLUT | |
import Control.Monad.Cont | |
display :: GLdouble -> IO () | |
display y = do | |
clear [ColorBuffer] | |
renderPrimitive LineStrip $ do | |
vertex (Vertex2 (-1) (-y)) | |
vertex (Vertex2 1 y) | |
swapBuffers | |
postRedisplay Nothing | |
main = do | |
(progname, _) <- getArgsAndInitialize | |
initialWindowSize $= Size 500 500 | |
initialDisplayMode $= [DoubleBuffered, RGBMode] | |
createWindow "Bounce!" | |
matrixMode $= Modelview 0 | |
loadIdentity | |
matrixMode $= Projection | |
loadIdentity | |
ortho (-1) 1 (-1) 1 (-1) 1 | |
imperative | |
mainLoop | |
imperative = flip runContT return $ do | |
liftIO $ print "Start!" | |
forever $ do | |
forM_ [-1, -0.992 .. 1.0] $ \y -> do | |
render $ display y | |
yield | |
liftIO $ print "Bounce!" | |
liftIO $ print "yielding for input now" | |
(key, _, _, _) <- yieldInput | |
liftIO $ putStrLn $ "user pressed: " ++ show key | |
forM_ [-1, -0.992 .. 1.0] $ \y -> do | |
render $ display (-y) | |
yield | |
liftIO $ print "Bounce!" | |
yield | |
render f = liftIO $ displayCallback $= f | |
-- modified yield! | |
yield :: ContT () IO () | |
yield = ContT $ \k -> do | |
idleCallback $= Just (do | |
idleCallback $= Nothing -- unhook | |
k () | |
) | |
-- wait for input | |
yieldInput :: ContT () IO (Key, KeyState, Modifiers, Position) | |
yieldInput = do | |
ContT $ \k -> do | |
keyboardMouseCallback $= Just ( | |
\key state mod pos -> do | |
keyboardMouseCallback $= Nothing -- unhook | |
k (key, state, mod, pos) | |
) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment