spanout (empty) → 0.1

raw patch · 10 files changed

+757/−0 lines, 10 filesdep +MonadRandomdep +basedep +containerssetup-changed

Dependencies added: MonadRandom, base, containers, gloss, lens, linear, mtl, netwire

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• spanout.cabal +38/−0
• src/Main.hs +8/−0
• src/Spanout/Common.hs +157/−0
• src/Spanout/Gameplay.hs +188/−0
• src/Spanout/Graphics.hs +77/−0
• src/Spanout/Level.hs +93/−0
• src/Spanout/Main.hs +96/−0
• src/Spanout/Wire.hs +68/−0

@@ -0,0 +1,30 @@+Copyright 2015, Viktor Tanyi++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,38 @@+name: spanout+version: 0.1+category: Game+synopsis: A breakout clone written in netwire and gloss+homepage: https://github.com/vtan/spanout+author: Viktor Tanyi+maintainer: Viktor Tanyi <tanyi.viktor@gmail.com>+license: BSD3+license-file: LICENSE+description:+  A breakout clone written in netwire and gloss.+build-type: Simple+cabal-version: >=1.10++source-repository head+  type: git+  location: git://github.com/vtan/spanout.git++executable spanout+  hs-source-dirs: src+  main-is: Main.hs+  other-modules:+    Spanout.Common, Spanout.Gameplay, Spanout.Graphics, Spanout.Level,+    Spanout.Main, Spanout.Wire+  ghc-options:+    -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+  other-extensions:+    Arrows, MultiWayIf, RecordWildCards, TemplateHaskell, TypeOperators+  build-depends:+    base >=4.6 && <5,+    mtl >=2.2 && <2.3,+    containers >=0.5 && <0.6,+    lens >=4.9 && <4.10,+    linear >=1.18 && <1.19,+    MonadRandom >=0.4 && <0.5,+    netwire >=5.0 && <5.1,+    gloss >=1.8 && <1.9+  default-language: Haskell2010

@@ -0,0 +1,8 @@+module Main where++import qualified Spanout.Main++++main :: IO ()+main = Spanout.Main.main

@@ -0,0 +1,157 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module Spanout.Common+  ( M+  , type (->>)++  , GameState(..)+  , gsBall+  , gsBatX+  , gsBricks+  , Ball(..)+  , ballPos+  , ballVel+  , Brick(..)+  , brPos+  , brGeom+  , BrickGeom(..)++  , Env(..)+  , envMouse+  , envKeys++  , screenWidth+  , screenHeight+  , screenBoundX+  , screenBoundY+  , ballRadius+  , ballInit+  , batWidth+  , batHeight+  , batPositionY+  , batSpread+  , brickWidth+  , brickHeight+  , countdownTime+  , levelEndTime+  , bgColor+  , ballColor+  , batColor+  , brickColor+  , textScale+  , textColor+  ) where++import Spanout.Wire++import Control.Lens+import Control.Monad.Random+import Control.Monad.Reader++import Data.Set (Set)++import qualified Graphics.Gloss.Interface.IO.Game as Gloss++import Linear++++-- The monad stack under reactive values+type M = ReaderT Env (Rand StdGen)++-- A reactive value of type `b`, which depends on a value of type `a`+type a ->> b = Wire (Timed Float ()) () M a b++data GameState = GameState+  { _gsBall          :: Ball+  , _gsBatX          :: Float+  , _gsBricks        :: [Brick]+  }++data Ball = Ball+  { _ballPos :: V2 Float+  , _ballVel :: V2 Float+  }++data Brick = Brick+  { _brPos  :: V2 Float+  , _brGeom :: BrickGeom+  }++data BrickGeom+  = Circle Float+  | Rectangle Float Float++data Env = Env+  { _envMouse :: V2 Float+  , _envKeys  :: Set Gloss.Key+  }++makeLenses ''GameState+makeLenses ''Ball+makeLenses ''Brick+makeLenses ''Env++screenWidth :: Float+screenWidth = 2 * (16 / 9)++screenHeight :: Float+screenHeight = 2++screenBoundX :: Float+screenBoundX = screenWidth / 2++screenBoundY :: Float+screenBoundY = screenHeight / 2++ballRadius :: Float+ballRadius = 0.05++ballInit :: Ball+ballInit = Ball+  { _ballPos = V2 0 (-screenBoundY + 4 * batHeight)+  , _ballVel = V2 0 (-1.75)+  }++batWidth :: Float+batWidth = 0.5++batHeight :: Float+batHeight = 0.07++batPositionY :: Float+batPositionY = -screenBoundY + batHeight / 2++batSpread :: Float+batSpread = pi / 12++brickWidth :: Float+brickWidth = 0.4++brickHeight :: Float+brickHeight = 0.12++countdownTime :: Float+countdownTime = 3++levelEndTime :: Float+levelEndTime = 1.5++bgColor :: Gloss.Color+bgColor = Gloss.makeColor8 0x31 0x2b 0x25 0xff++ballColor :: Gloss.Color+ballColor = Gloss.makeColor8 0x9f 0x87 0x6b 0xff++batColor :: Gloss.Color+batColor = Gloss.makeColor8 0x6d 0xa3 0x3a 0xff++brickColor :: Gloss.Color+brickColor = Gloss.makeColor8 0xb1 0x5b 0x3e 0xff++textScale :: Float+textScale = 0.004++textColor :: Gloss.Color+textColor = Gloss.chartreuse

@@ -0,0 +1,188 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeOperators #-}++module Spanout.Gameplay (game) where++import Prelude hiding (id, (.))++import Spanout.Common+import Spanout.Graphics+import Spanout.Level+import qualified Spanout.Wire as Wire++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Lens+import Control.Monad++import Data.Either+import Data.Maybe+import Data.Monoid+import qualified Data.Set as Set++import qualified Graphics.Gloss.Interface.IO.Game as Gloss++import Linear++++-- The reactive view of the game+game :: a ->> Gloss.Picture+game = Wire.bindW gsInit gameBegin+  where+    gsInit = do+      bricks <- generateBricks+      return GameState+        { _gsBall = ballInit+        , _gsBatX = 0+        , _gsBricks = bricks+        }++++-- Displays the level and a countdown before the actual gameplay+gameBegin :: GameState -> a ->> Gloss.Picture+gameBegin gsInit = Wire.switch $ proc _ -> do+  batX <- view _x ^<< mousePos -< ()+  time <- Wire.time -< ()+  let+    gs = set gsBatX batX gsInit+    remainingTime = countdownTime - time+  returnA -< if+    | remainingTime > 0 -> Right $ gamePic gs <> countdownPic remainingTime+    | otherwise         -> Left  $ gameLevel gs++-- Gameplay from an initial game state+gameLevel :: GameState -> a ->> Gloss.Picture+gameLevel gsInit = Wire.switch $ proc _ -> do+  batX <- view _x ^<< mousePos -< ()+  rec+    -- Binding previous values+    ball' <- Wire.delay $ view gsBall gsInit -< ball+    bricks' <- Wire.delay $ view gsBricks gsInit -< bricks++    -- Current position+    pos <- Wire.accum (\dt p v -> p + dt *^ v) $ view (gsBall . ballPos) gsInit+        -< view ballVel ball'+    -- Collision and its normal+    let+      edgeNormal = ballEdgeNormal pos+      batNormal = ballBatNormal batX pos+      ballBrickColl = ballBrickCollision (ball' {_ballPos = pos}) bricks'+      brickNormals = fst <$> ballBrickColl+      normal = mfilter (faceAway $ view ballVel ball') . mergeNormalEvents $+           maybeToList edgeNormal+        ++ maybeToList batNormal+        ++ fromMaybe [] brickNormals+    -- Current velocity+    vel <- Wire.accumE reflect $ view (gsBall . ballVel) gsInit -< normal++    -- Binding current values+    let+      ball = Ball pos vel+      bricks = fromMaybe bricks' (snd <$> ballBrickColl)++  let gs = GameState {_gsBall = ball, _gsBatX = batX, _gsBricks = bricks}+  spacePressed <- keyPressed $ Gloss.SpecialKey Gloss.KeySpace -< ()+  returnA -< if+    | spacePressed ->+        Left game+    | null bricks ->+        Left $ levelEnd gs+    | view (ballPos . _y) ball <= -screenBoundY - ballRadius ->+        Left $ gameBegin gsInit+    | otherwise ->+        Right $ gamePic gs++-- Displays the final game state for some time after the end of the level+levelEnd :: GameState -> a ->> Gloss.Picture+levelEnd gs = Wire.switch $ Wire.forThen levelEndTime game . pure pic+  where+    pic = gamePic gs <> levelEndPic++-- The sum of zero or more normals+mergeNormalEvents :: (Floating a, Epsilon a) => [V2 a] -> Maybe (V2 a)+mergeNormalEvents [] = Nothing+mergeNormalEvents normals = Just . normalize $ sum normals++-- Collision between the ball and the screen edges+ballEdgeNormal :: V2 Float -> Maybe (V2 Float)+ballEdgeNormal (V2 px py)+  | px <= -screenBoundX + ballRadius = Just $  unit _x+  | px >=  screenBoundX - ballRadius = Just $ -unit _x+  | py >=  screenBoundY - ballRadius = Just $ -unit _y+  | otherwise                        = Nothing++-- Collision between the ball and the bat+ballBatNormal :: Float -> V2 Float -> Maybe (V2 Float)+ballBatNormal batX (V2 px py)+  | bxl && bxr && by = Just $ batNormalAt px batX+  | otherwise        = Nothing+  where+    bxl = px >= batX - batWidth / 2+    bxr = px <= batX + batWidth / 2+    by  = py <= batPositionY + batHeight / 2 + ballRadius++-- Collision between the ball and the bricks.+-- Calculates the resulting normals and the remaining bricks.+ballBrickCollision :: Ball -> [Brick] -> Maybe ([V2 Float], [Brick])+ballBrickCollision ball bricks =+  case collisionNormals of+    [] -> Nothing+    _  -> Just (collisionNormals, remBricks)+  where+    check brick =+      case ballBrickNormal brick ball of+        Just normal -> Right normal+        _           -> Left brick+    (remBricks, collisionNormals) = partitionEithers . map check $ bricks++-- Collision between the ball and a brick+ballBrickNormal :: Brick -> Ball -> Maybe (V2 Float)+ballBrickNormal (Brick pos (Circle radius)) (Ball bpos _)+  | hit = Just . normalize $ bpos - pos+  | otherwise = Nothing+  where+    hit = distance bpos pos <= radius + ballRadius+ballBrickNormal (Brick pos@(V2 x y) (Rectangle width height)) (Ball bpos bvel)+  | tooFar = Nothing+  | hitX = Just normalX+  | hitY = Just normalY+  | hitCorner = listToMaybe . filter (faceAway bvel) $ [normalX, normalY]+  | otherwise = Nothing+  where+    dist = bpos - pos+    V2 distAbsX distAbsY = abs <$> dist+    V2 ballX ballY = bpos+    tooFar = distAbsX > width  / 2 + ballRadius+          || distAbsY > height / 2 + ballRadius+    hitX = distAbsX <= width / 2+    hitY = distAbsY <= height / 2+    hitCorner = quadrance (V2 (distAbsX - width / 2) (distAbsY - height / 2))+             <= ballRadius ^ (2 :: Int)+    normalX = signum (ballY - y) *^ unit _y+    normalY = signum (ballX - x) *^ unit _x++-- The normal at a point of the bat+batNormalAt :: Float -> Float -> V2 Float+batNormalAt x batX = perp . angle $ batSpread * relX+  where+    relX = (batX - x) / (batWidth / 2)++-- Checks if two vectors face away from each other+faceAway :: (Num a, Ord a) => V2 a -> V2 a -> Bool+faceAway u v = u `dot` v < 0++-- The reflection of a vector based on a normal+reflect :: Num a => V2 a -> V2 a -> V2 a+reflect v normal = v - (2 * v `dot` normal) *^ normal++-- The reactive position of the mouse+mousePos :: a ->> V2 Float+mousePos = Wire.constM $ view envMouse++-- The reactive state of a keyboard button+keyPressed :: Gloss.Key -> a ->> Bool+keyPressed key = Wire.constM $ views envKeys (Set.member key)

@@ -0,0 +1,77 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}++module Spanout.Graphics+  ( gamePic+  , countdownPic+  , levelEndPic+  ) where++import Spanout.Common++import Data.Monoid++import qualified Graphics.Gloss as Gloss++import Linear++++-- The view of a game state+gamePic :: GameState -> Gloss.Picture+gamePic GameState{..} = Gloss.pictures $+     [ bg+     , ballPic _gsBall+     , batPic _gsBatX+     ]+  ++ map brickPic _gsBricks+  where+    bg = Gloss.color bgColor+       $ Gloss.rectangleSolid screenWidth screenHeight++-- The view of a countdown timer+countdownPic :: RealFrac a => a -> Gloss.Picture+countdownPic t =+    Gloss.scale textScale textScale+  . Gloss.color textColor+  . Gloss.text+  $ show (ceiling t :: Int)++-- A static picture after a level+levelEndPic :: Gloss.Picture+levelEndPic =+    Gloss.color textColor+  . Gloss.scale textScale textScale+  $ Gloss.text "Done"++++ballPic :: Ball -> Gloss.Picture+ballPic (Ball {_ballPos = V2 x y}) =+  Gloss.translate x y $ circleFilled ballColor ballRadius++batPic :: Float -> Gloss.Picture+batPic x =+  Gloss.translate x batPositionY $ rectangleFilled batColor batWidth batHeight++brickPic :: Brick -> Gloss.Picture+brickPic (Brick (V2 x y) (Circle r)) =+  Gloss.translate x y $ circleFilled brickColor r+brickPic (Brick (V2 x y) (Rectangle w h)) =+  Gloss.translate x y $ rectangleFilled brickColor w h++circleFilled :: Gloss.Color -> Float -> Gloss.Picture+circleFilled color radius =+     Gloss.color color (Gloss.circleSolid radius)+  <> Gloss.color (border color) (Gloss.circle radius)++rectangleFilled :: Gloss.Color -> Float -> Float -> Gloss.Picture+rectangleFilled color width height =+     Gloss.color color (Gloss.rectangleSolid width height)+  <> Gloss.color (border color) (Gloss.rectangleWire width height)++-- The color of the border of an object+border :: Gloss.Color -> Gloss.Color+border color = Gloss.rawColor r g b 0.5+  where+    (r, g, b, _) = Gloss.rgbaOfColor $ Gloss.mixColors 0.5 0.5 color bgColor

@@ -0,0 +1,93 @@+module Spanout.Level (generateBricks) where++import Spanout.Common++import Control.Lens+import Control.Monad+import Control.Monad.Random++import Data.Fixed++import Linear++++-- Generates bricks in randomly sized rows+generateBricks :: MonadRandom m => m [Brick]+generateBricks = do+  relLevelHeight <- getRandomR (0.3, 0.6)+  relRowHeights <- splitRow relLevelHeight+  let rowHeights = map (screenHeight *) relRowHeights+  rows <- forM rowHeights $ \h -> do+    relW <- getRandomR (0.2, 0.8)+    shape <- getRandom+    let+      w = screenWidth * relW+      gen+        | shape < (0.3 :: Float) = fillCircles+        | otherwise              = fillRectangles+    return $ gen w h+  let levelHeight = screenHeight * relLevelHeight+  offset <- getRandomR (0, screenBoundY - levelHeight / 2 - 2 * ballRadius)+  let+    rowYs = alignRows offset rowHeights+    placedRows = zipWith placeRow rowYs rows+  case concat placedRows of+    []     -> generateBricks+    bricks -> return bricks+  where+    placeRow y = over (mapped . brPos . _y) (+y)++++-- Splits a row of a given height randomly+splitRow :: MonadRandom m => Float -> m [Float]+splitRow h+  | h <= 0.15 = return [h]+  | otherwise = do+      splitFurther <- getRandom+      if splitFurther < (0.8 :: Float)+      then do+        ratio <- getRandomR (0.3, 0.7)+        liftM2 (++) (splitRow (ratio * h)) (splitRow ((1 - ratio) * h))+      else return [h]++-- Fills the rectangle centered at the origin with bricks+fillCircles :: Float -> Float -> [Brick]+fillCircles w h+  | h >= brickHeight = map circBrick [0 .. countX - 1]+  | otherwise        = []+  where+    r = h / 2+    (countX, marginX) = w `divMod'` h+    startX = negate $ (w - marginX - h) / 2+    y = 0++    circBrick :: Int -> Brick+    circBrick x = Brick (V2 (startX + fromIntegral x * h) y) $ Circle r++-- Fills the rectangle centered at the origin with bricks+fillRectangles :: Float -> Float -> [Brick]+fillRectangles w h =+  map rectBrick [V2 x y | x <- [0 .. countX - 1], y <- [0 .. countY - 1]]+  where+    (countX, marginX) = w `divMod'` brickWidth+    (countY, marginY) = h `divMod'` brickHeight+    startX = negate $ (w - marginX - brickWidth) / 2+    startY = negate $ (h - marginY - brickHeight) / 2++    rectBrick :: V2 Int -> Brick+    rectBrick (V2 x y) = Brick (V2 px py) $ Rectangle brickWidth brickHeight+      where+        px = startX + fromIntegral x * brickWidth+        py = startY + fromIntegral y * brickHeight++-- Calculates the vertical row centers based on the row heights, so the+-- resulting list of rows is centered at the origin+alignRows :: Float -> [Float] -> [Float]+alignRows offset heights =+  map (offset+) $ zipWith avg (init alignedBottoms) (tail alignedBottoms)+  where+    bottoms = scanl (+) 0 heights+    alignedBottoms = map (subtract $ sum heights / 2) bottoms+    avg x y = (x + y) / 2

@@ -0,0 +1,96 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module Spanout.Main (main) where++import Spanout.Common+import Spanout.Gameplay+import Spanout.Wire++import Control.Lens+import Control.Monad.Random+import Control.Monad.Reader++import qualified Data.Set as Set++import qualified Graphics.Gloss as Gloss+import qualified Graphics.Gloss.Data.ViewPort as Gloss+import qualified Graphics.Gloss.Interface.IO.Game as Gloss++import Linear++import qualified System.Exit as System++++type MainWire = () ->> Gloss.Picture++data World = World+  { _worldWire     :: MainWire+  , _worldEnv      :: Env+  , _worldLastPic  :: Gloss.Picture+  , _worldViewPort :: Gloss.ViewPort+  }++makeLenses ''World++main :: IO ()+main = Gloss.playIO disp Gloss.black fps world+    obtainPicture registerEvent performIteration+  where+    disp = Gloss.InWindow "spanout" winSize (0, 0)+    fps = 60+    winSize = (960, 540)+    world = World+      { _worldWire     = game+      , _worldEnv      = env+      , _worldLastPic  = Gloss.blank+      , _worldViewPort = viewPort winSize+      }+    env = Env+      { _envMouse = zero+      , _envKeys  = Set.empty+      }++++-- Updated the world with a gloss event+registerEvent :: Gloss.Event -> World -> IO World+registerEvent (Gloss.EventResize wh) world =+  return $ set worldViewPort (viewPort wh) world+registerEvent (Gloss.EventMotion p) world =+  return $ set (worldEnv . envMouse) (V2 x y) world+  where+    (x, y) = Gloss.invertViewPort vp p+    vp = view worldViewPort world+registerEvent (Gloss.EventKey key Gloss.Down _ _) world =+  return $ over (worldEnv . envKeys) (Set.insert key) world+registerEvent (Gloss.EventKey key Gloss.Up _ _) world =+  return $ over (worldEnv . envKeys) (Set.delete key) world++-- Steps the wire stored in the world and stores the resulting picture and wire+performIteration :: Float -> World -> IO World+performIteration dTime world = do+  let+    timed = Timed dTime ()+    input = Right ()+    mb = stepWire (view worldWire world) timed input+  (epic, wire') <- evalRandIO . runReaderT mb $ view worldEnv world+  case epic of+    Right pic -> return . set worldWire wire' . set worldLastPic pic $ world+    Left ()   -> System.exitSuccess++-- The rendered picture from the world+obtainPicture :: World -> IO Gloss.Picture+obtainPicture world = return $ Gloss.applyViewPortToPicture vp pic+  where+    vp = view worldViewPort world+    pic = view worldLastPic world++-- The viewport based on the new dimensions of the window+viewPort :: (Int, Int) -> Gloss.ViewPort+viewPort (w, h) = Gloss.viewPortInit { Gloss.viewPortScale = scale }+  where+    scale = min scaleX scaleY+    scaleX = fromIntegral w / 2 / screenBoundX+    scaleY = fromIntegral h / 2 / screenBoundY

@@ -0,0 +1,68 @@+{-# LANGUAGE Arrows #-}++module Spanout.Wire+  ( constM+  , bindW+  , accum+  , accumE+  , switch+  , forThen++  , Wire+  , Wire.Timed(..)+  , Wire.stepWire+  , Wire.delay+  , Wire.time+  ) where++import Control.Arrow+import Control.Monad+import Control.Wire (Wire)+import qualified Control.Wire as Wire++import Data.Monoid++++-- A reactive value from a monadic value+constM :: Monad m => m b -> Wire s e m a b+constM m = Wire.mkGen_ . const $ liftM Right m++-- Peforms a monadic action and parametrizes a wire with the resulting value+bindW :: (Monad m, Monoid s) => m k -> (k -> Wire s e m a b) -> Wire s e m a b+bindW mk f = Wire.mkGen $ \s a -> do+  k <- mk+  Wire.stepWire (f k) s (Right a)++-- A wire that yields an accumulated value based on its input and a time delta+accum :: Wire.HasTime t s => (t -> b -> a -> b) -> b -> Wire s e m a b+accum f b = Wire.mkSF $ \s a ->+  let b' = f (Wire.dtime s) b a+  in  (b', accum f b')++-- A wire that yields an accumulated value based on events+accumE :: (b -> a -> b) -> b -> Wire s e m (Maybe a) b+accumE f b = Wire.mkSFN $ \ma ->+  case ma of+    Just a  ->+      let b' = f b a+      in  (b', accumE f b')+    Nothing -> (b, accumE f b)++-- Switches from a wire that produces either an output or a new wire+switch :: (Monoid s, Monad m)+  => Wire s e m a (Either (Wire s e m a b) b) -> Wire s e m a b+switch w = Wire.mkGen $ \s a -> do+  (Right eb, w') <- Wire.stepWire w s (Right a)+  case eb of+    Left w'' -> Wire.stepWire w'' mempty (Right a)+    Right b -> return (Right b, switch w')++-- Acts as the identity wire for given time, then yield a constant value+forThen :: (Wire.HasTime t s, Monad m) => t -> k -> Wire s e m a (Either k a)+forThen t e = proc a -> do+  t' <- Wire.time -< ()+  returnA -<+    if t' < t+    then Right a+    else Left e