Commits

paradoxiology committed b30cbf0

Introduced G Monad transformer to encapsulate both Random and Reader Monad

The Reader Monad captures the size of the window, which is used to determine the
collision boundary.

Comments (0)

Files changed (3)

   -- other-modules:       
   other-extensions:    Arrows
   build-depends:       base >=4.6 && <4.7,
+                        mtl >=2.1 && <2.2,
                     netwire >=5.0 && <5.1,
                        vect >=0.4 && <0.5,
                       gloss >=1.8 && <1.9,
 
 import Control.Wire hiding (Event)
 
+import Control.Monad.Random
+import Control.Monad.Reader (ReaderT, runReaderT, asks)
+
 import Data.Maybe (catMaybes)
 
 import Data.Vect
 import Prelude hiding ((.), id)
 
 import System.Random
-import Control.Monad.Random
 
 -- import Debug.Trace
 
-import WireUtils (integralVecWith, integralVecWith', mergeWires, oneShot)
+import WireUtils
 
 
 main :: IO ()
                    | VerticalCollision
                    | NoCollision
 
-type GlossWire a b = Wire (Timed Float ()) () (Rand StdGen) a b
+data WorldEnv = WorldEnv
+  { worldWidth  :: !Float
+  , worldHeight :: !Float
+  } deriving (Show)
+
+-- | G Monad captures the game environment and the Random monad 
+-- used in the wires
+type G = RandT StdGen (ReaderT WorldEnv Identity)
+
+runG :: G a -> StdGen -> WorldEnv -> (a, StdGen)
+runG m g env = runIdentity (runReaderT (runRandT m g) env)
+
+type GlossWire a b = Wire (Timed Float ()) () G a b
 
 data WireWorld = WireWorld
   { wire :: GlossWire [Event] [Ball]
   , balls  :: [Ball]
   , pendingEvents :: [Event]
   , randGen :: !StdGen -- Without the bang, the program will space leak
+  , worldEnv :: WorldEnv
   }
 
 data Ball = Ball !Vec2 !Color deriving (Show)
 
 initWorld :: WireWorld
-initWorld = WireWorld animateBalls [] [] (mkStdGen 8552)
+initWorld = WireWorld animateBalls [] [] (mkStdGen 8552) (WorldEnv 600 480)
 
 handleEvents :: Event -> WireWorld -> WireWorld
+handleEvents (EventResize (newWidth, newHeight)) oldWorld = 
+  oldWorld{worldEnv = WorldEnv (fromIntegral newWidth) (fromIntegral newHeight)}
+
 handleEvents event oldWorld@(WireWorld{pendingEvents = events}) =
   oldWorld{pendingEvents = event:events}
 
 render world = pictures $ map mkCircle (balls world)
 
 update :: Float -> WireWorld -> WireWorld
-update dt oldWorld = WireWorld w' bs' [] g'
+update dt oldWorld = WireWorld w' bs' [] g' env
   where
     events = pendingEvents oldWorld
-    ((ebs, w'), g') = runRand
+    env = worldEnv oldWorld
+    ((ebs, w'), g') = runG
                         (stepWire (wire oldWorld) (Timed dt ()) (Right events))
                         (randGen oldWorld)
+                        env
     bs' = either (const []) id ebs
 
 mkCircle :: Ball -> Picture
                             | abs y < 50   = Vec2 x 0
                             | otherwise    = vec
 
-boundaryWidth :: Float
-boundaryWidth = 290
+position :: Vec2 -> GlossWire Vec2 (Vec2, CollisionType)
+position = integralVecWithM' bounce
+  where 
+    bounce v = do
+      width  <- asks worldWidth
+      height <- asks worldHeight
+      return $ bounce' (width / 2 - 10) (height / 2 - 10) v
 
-boundaryHeight :: Float
-boundaryHeight = 230
-
-position :: Vec2 -> GlossWire Vec2 (Vec2, CollisionType)
-position = integralVecWith' bounce
-  where 
-    bounce (Vec2 x y) = (Vec2 x' y', col)
+    bounce' bWidth bHeight (Vec2 x y) = (Vec2 x' y', col)
       where
-        x'  | x < (-boundaryWidth) = (-x) - 2 * boundaryWidth
-            | x > boundaryWidth = 2 * boundaryWidth - x
+        x'  | x < (-bWidth) = (-x) - 2 * bWidth
+            | x > bWidth = 2 * bWidth - x
             | otherwise = x
 
-        y'  | y < (-boundaryHeight) = (-y) - 2 * boundaryHeight
-            | y > boundaryHeight = 2 * boundaryHeight - y
+        y'  | y < (-bHeight) = (-y) - 2 * bHeight
+            | y > bHeight = 2 * bHeight - y
             | otherwise = y
 
-        col | x < (-boundaryWidth) || (x > boundaryWidth) = HorizontalCollision
-            | y < (-boundaryHeight) || (y > boundaryHeight) = VerticalCollision
+        col | x < (-bWidth) || (x > bWidth) = HorizontalCollision
+            | y < (-bHeight) || (y > bHeight) = VerticalCollision
             | otherwise = NoCollision
             
-module WireUtils where
+module WireUtils 
+(
+  integralVec,
+  integralVecWith,
+  integralVecWith',
+  integralVecWithM',
+  mergeWires,
+  oneShot,
+  periodicShots
+)
+where
 
 import Control.Wire
 
             (x1, o) = correct (x0 &+ dt *& dx)
         in x0 `seq` (Right (x0, o), go x1) 
 
+integralVecWithM' :: (HasTime t s, Monad m, Vector v)
+                  => (v -> m (v, o))
+                  -> v
+                  -> Wire s e m v (v, o)
+integralVecWithM' correct = go
+  where 
+    go x0 =
+      mkGen $ \ds dx -> do
+        let dt  =  realToFrac (dtime ds)
+        -- Use res as opposed to explicitly destruct(pattern match)
+        -- the tuple (x1, 0) to avoid evaluation of the tuple in the do notation
+        -- (Because of the implicitly threaded ordering)
+        res <- correct (x0 &+ dt *& dx)
+        return $ x0 `seq` (Right (x0, snd res), go (fst res)) 
+
 mergeWires :: (Monad m, Monoid s) => [Wire s e m a b] -> Wire s e m (a, [Wire s e m a b]) [b]
 mergeWires wires = mkGen $ \ds (a, newWires) -> do
   stepped <- mapM (\w -> stepWire w ds (Right a)) (newWires ++ wires)