yampa-glut 0.1.0 → 0.1.1
raw patch · 6 files changed
+144/−82 lines, 6 files
Files
- FRP/Yampa/GLUT/Adapter.hs +16/−12
- FRP/Yampa/GLUT/InternalUI.hs +1/−1
- FRP/Yampa/GLUT/UI.hs +17/−6
- example.hs +0/−60
- example.lhs +107/−0
- yampa-glut.cabal +3/−3
FRP/Yampa/GLUT/Adapter.hs view
@@ -36,7 +36,8 @@ let rInit = return NoEvent rActuate _ _ NoEvent = return False- rActuate _ _ (Event (Action b)) = b+ rActuate _ _ (Event (ActionExit io)) = io >> return True+ rActuate _ _ (Event (ActionIO io)) = io >> return False rh <- reactInit rInit rActuate sf @@ -77,29 +78,33 @@ scheduleTick scheduleTick- + -- | Action to perform in response to something-newtype Action = Action (IO Bool)+data Action = ActionExit (IO ())+ | ActionIO (IO ()) -- | Simple IO action that do not control mainLoop life-time actionIO :: IO () -> Action-actionIO = Action . fmap (const False)+actionIO = ActionIO -- | Terminate mainLoop action actionExit :: Action-actionExit = Action (return True)+actionExit = ActionExit (return ()) -- | Top level reaction signal function type Reaction = SF (Event UI) (Event Action) -- Monoid instances to combine actions, reactions etc-instance Newtype Action (IO Bool) where- pack = Action- unpack (Action x) = x+instance Newtype Action (IO ()) where+ pack = ActionIO+ unpack (ActionIO x) = x+ unpack (ActionExit x) = x instance Monoid Action where- mempty = Action (return False)- a `mappend` b = Action (unpack a >>= \x -> if x then return True else unpack b)+ mempty = ActionIO (return ())+ a@(ActionExit _) `mappend` _ = a+ (ActionIO a) `mappend` (ActionExit b) = ActionExit (a >> b)+ (ActionIO a) `mappend` (ActionIO b) = ActionIO (a >> b) instance Monoid a => Monoid (Event a) where mempty = Event mempty@@ -110,5 +115,4 @@ instance Monoid b => Monoid (SF a b) where mempty = arr mempty- sfX `mappend` sfY = (sfX &&& sfY) >>> arr (uncurry mappend)-+ sfX `mappend` sfY = (sfX &&& sfY) >>^ uncurry mappend
FRP/Yampa/GLUT/InternalUI.hs view
@@ -1,4 +1,4 @@-{-# BangPatterns #-}+{-# LANGUAGE BangPatterns #-} -- Copyright : (c) Nikolay Orlyuk 2012 -- License : GNU GPLv3 (see COPYING)
FRP/Yampa/GLUT/UI.hs view
@@ -7,8 +7,8 @@ , redisplay, reshaped, windowSize , mousePosition, simpleMousePosition , keyAction, mouseButtonAction, modifiers- , keyPressed- , crossed+ , keyPress, keyPressed, mouseButtonPressed+ , crossing ) where import Control.Arrow@@ -82,12 +82,23 @@ f _ = Nothing -- | Key press events-keyPressed :: SF (Event UI) (Event (Either Char SpecialKey))-keyPressed = keyAction >>> arr (fmap snd . filterE ((==Down) . fst))+keyPress :: SF (Event UI) (Event (Either Char SpecialKey))+keyPress = keyAction >>^ fmap snd . filterE ((==Down) . fst) +-- | Key pressed state for specific key+keyPressed :: Either Char SpecialKey -> SF (Event UI) Bool+keyPressed key = hold False <<< mapFilterE f ^<< keyAction where+ f (x, key') | key == key' = Just (x == Down)+ f _ = Nothing +-- | Mouse button pressed state for specific button+mouseButtonPressed :: MouseButton -> SF (Event UI) Bool+mouseButtonPressed button = hold False <<< mapFilterE f ^<< mouseButtonAction where+ f (x, button') | button == button' = Just (x == Down)+ f _ = Nothing+ -- | Crossing/leaving event-crossed :: SF (Event UI) (Event Crossing)-crossed = arr (mapFilterE f) where+crossing :: SF (Event UI) (Event Crossing)+crossing = arr (mapFilterE f) where f (GlutCrossing c) = Just c f _ = Nothing
− example.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE Arrows #-}-import Control.Arrow-import Data.Monoid--import Data.VectorSpace--import Graphics.UI.GLUT--import FRP.Yampa.GLUT.Adapter-import FRP.Yampa (SF, integral, delay, initially)-import FRP.Yampa.Event-import FRP.Yampa.Utilities---main = do- simpleInit "Simple"- adapt leaveMainLoop simple--simple :: Reaction-simple = proc ev -> do- pos <- ball -< ev- displayAction <- arr (tagWith (actionIO . display)) <<< redisplay -< ev- reshapedAction <- arr (fmap (actionIO . reshape)) <<< reshaped -< ev- returnA -< mconcat [fmap (\f -> f pos) displayAction, reshapedAction]---display (x, y) = do- clear [ ColorBuffer, DepthBuffer ]-- preservingMatrix $ do- translate (Vector3 (realToFrac x) (realToFrac y) (0 :: GLfloat))- renderObject Solid (Teapot 0.1)-- swapBuffers--reshape sz@(Size w h) = do- let b = fromIntegral (w `min` h) * 2- w' = fromIntegral w / b- h' = fromIntegral h / b-- viewport $= (Position 0 0, sz)-- matrixMode $= Projection- loadIdentity- frustum (-w') w' (-h') h' 2 100-- matrixMode $= Modelview 0- loadIdentity-- translate (Vector3 0 0 (-4 :: GLfloat))--ball :: SF (Event UI) (Float, Float)-ball = proc ev -> do- rec- (Vector2 tx ty) <- simpleMousePosition -< ev- let mpos = (tx, ty)- dpos = mpos ^-^ pos- speed = normalized dpos ^* 0.5- pos <- integral <<< delay 0.2 zeroV -< speed- returnA -< pos
+ example.lhs view
@@ -0,0 +1,107 @@+Useful syntax for working with @Arrow@ and associated combinators++> {-# LANGUAGE Arrows #-}+> import Control.Arrow++We know that our @Action@ objects have @Monoid@ property. Use that fact by+combining them through @mconcat@++> import Data.Monoid++Nice set of operators for Vectors manipulation++> import Data.VectorSpace+> import Data.VectorSpace.OpenGL++GLUT supplies us with a lot of already predefined objects (among them is teapot and sphere).++> import Graphics.UI.GLUT++Here we get our @Reaction@ processing and @simpleMousePosition@ signal+function.++> import FRP.Yampa.GLUT.Adapter++> import FRP.Yampa (SF, integral, delay, initially, edge, accumHoldBy)+> import FRP.Yampa.Event++Our small Simple game++> main = do+> simpleInit "Simple"+> cullFace $= Just Back+> frontFace $= CW+> shadeModel $= Smooth+>+> blend $= Enabled+> blendFunc $= (SrcAlpha, OneMinusSrcAlpha)+>+> lighting $= Enabled+> ambient (Light 0) $= Color4 0.1 0.1 0.1 (1::GLfloat)+> diffuse (Light 0) $= Color4 0.9 0.9 0.9 (1::GLfloat)+> position (Light 0) $= Vertex4 0.5 0.5 (-10) 0+> light (Light 0) $= Enabled+> colorMaterial $= Just (Front, AmbientAndDiffuse)+>+> adapt leaveMainLoop simple++Description of events flow through our game++> simple :: Reaction+> simple = proc ev -> do+> pos <- ball -< ev+> disp <- redisplay -< ev+> reshapedAction <- fmap (actionIO . reshape) ^<< reshaped -< ev+> returnA -< mconcat [+> reshapedAction,+> disp `tag` actionIO (display pos)+> ]++Display takes our in-game state and draws it++> display (x, y) = do+> clear [ ColorBuffer, DepthBuffer ]+>+> preservingMatrix $ do+> translate (Vector3 (realToFrac x) (realToFrac y) (0 :: GLfloat))+> color $ Color4 0.2 0.8 0 (0.5::GLfloat)+> renderObject Solid (Sphere' 0.1 50 50)+>+> swapBuffers++Our reshape callback is trying to keep aspect ratio.++> reshape sz@(Size w h) = do+> let b = fromIntegral (w `min` h) * 2+> w' = fromIntegral w / b+> h' = fromIntegral h / b+>+> viewport $= (Position 0 0, sz)+>+> matrixMode $= Projection+> loadIdentity+> frustum (-w') w' (-h') h' 2 100+>+> matrixMode $= Modelview 0+> loadIdentity+>+> translate (Vector3 0 0 (-4 :: GLfloat))++Internal state of in-game object represented by two @Float@'s. That's recursive+signal function that affected by user input.++> ball :: SF (Event UI) (Float, Float)+> ball = proc ev -> do+> d <- moveDirection -< ev+> (Vector2 tx ty) <- simpleMousePosition -< ev+> rec+> let mpos = (tx, ty)+> dpos = mpos ^-^ pos+> speed = normalized dpos ^* 0.5 ^* d+> pos <- integral <<< delay 0.2 zeroV -< speed+> returnA -< pos++Direction++> moveDirection :: SF (Event UI) Float+> moveDirection = mouseButtonPressed LeftButton >>> edge >>> accumHoldBy (const . negate) 1
yampa-glut.cabal view
@@ -1,5 +1,5 @@ Name: yampa-glut-Version: 0.1.0+Version: 0.1.1 Cabal-Version: >= 1.6 Synopsis: Connects Yampa and GLUT Category: FRP, graphics@@ -7,7 +7,7 @@ This package contains an adapter that connects OpenGL/GLUT to the FRP library \"Yampa\". .- © 2012 by Nikolay Orlyuk; BSD3 license.+ © 2012 by Nikolay Orlyuk; GPL-3 license. Author: Nikolay Orlyuk Maintainer: virkony@gmail.com@@ -17,7 +17,7 @@ License-File: COPYING Stability: experimental build-type: Simple-Extra-Source-Files: example.hs+Extra-Source-Files: example.lhs Source-Repository head type: git