sodium 0.4.0.0 → 0.5.0.0

raw patch · 84 files changed

+1238/−589 lines, 84 filesbinary-addedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• examples/games/Engine.hs +183/−0
• examples/games/Image.hs +134/−0
• examples/games/cards/b1fh.png binary
• examples/games/cards/b1fv.png binary
• examples/games/cards/b1pb.png binary
• examples/games/cards/b1pl.png binary
• examples/games/cards/b1pr.png binary
• examples/games/cards/b1pt.png binary
• examples/games/cards/b2fh.png binary
• examples/games/cards/b2fv.png binary
• examples/games/cards/b2pb.png binary
• examples/games/cards/b2pl.png binary
• examples/games/cards/b2pr.png binary
• examples/games/cards/b2pt.png binary
• examples/games/cards/c1.png binary
• examples/games/cards/c10.png binary
• examples/games/cards/c2.png binary
• examples/games/cards/c3.png binary
• examples/games/cards/c4.png binary
• examples/games/cards/c5.png binary
• examples/games/cards/c6.png binary
• examples/games/cards/c7.png binary
• examples/games/cards/c8.png binary
• examples/games/cards/c9.png binary
• examples/games/cards/cj.png binary
• examples/games/cards/ck.png binary
• examples/games/cards/cq.png binary
• examples/games/cards/d1.png binary
• examples/games/cards/d10.png binary
• examples/games/cards/d2.png binary
• examples/games/cards/d3.png binary
• examples/games/cards/d4.png binary
• examples/games/cards/d5.png binary
• examples/games/cards/d6.png binary
• examples/games/cards/d7.png binary
• examples/games/cards/d8.png binary
• examples/games/cards/d9.png binary
• examples/games/cards/dj.png binary
• examples/games/cards/dk.png binary
• examples/games/cards/dq.png binary
• examples/games/cards/ec.png binary
• examples/games/cards/empty-space.png binary
• examples/games/cards/h1.png binary
• examples/games/cards/h10.png binary
• examples/games/cards/h2.png binary
• examples/games/cards/h3.png binary
• examples/games/cards/h4.png binary
• examples/games/cards/h5.png binary
• examples/games/cards/h6.png binary
• examples/games/cards/h7.png binary
• examples/games/cards/h8.png binary
• examples/games/cards/h9.png binary
• examples/games/cards/hj.png binary
• examples/games/cards/hk.png binary
• examples/games/cards/hq.png binary
• examples/games/cards/index.html +108/−0
• examples/games/cards/jb.png binary
• examples/games/cards/jr.png binary
• examples/games/cards/licence.txt +16/−0
• examples/games/cards/s1.png binary
• examples/games/cards/s10.png binary
• examples/games/cards/s2.png binary
• examples/games/cards/s3.png binary
• examples/games/cards/s4.png binary
• examples/games/cards/s5.png binary
• examples/games/cards/s6.png binary
• examples/games/cards/s7.png binary
• examples/games/cards/s8.png binary
• examples/games/cards/s9.png binary
• examples/games/cards/sj.png binary
• examples/games/cards/sk.png binary
• examples/games/cards/sq.png binary
• examples/games/freecell.hs +338/−0
• examples/games/poodle.hs +109/−0
• examples/games/poodle.png binary
• examples/poodle/Engine.hs +0/−177
• examples/poodle/Image.hs +0/−134
• examples/poodle/poodle.hs +0/−109
• examples/poodle/poodle.png binary
• examples/tests.hs +174/−81
• sodium.cabal +78/−6
• src/FRP/Sodium.hs +1/−2
• src/FRP/Sodium/Context.hs +32/−35
• src/FRP/Sodium/Plain.hs +65/−45

@@ -0,0 +1,183 @@+{-# LANGUAGE ScopedTypeVariables, EmptyDataDecls #-}+module Engine where++import FRP.Sodium++import Control.Applicative+import Control.Monad+import Data.List+import Graphics.Rendering.OpenGL as GL hiding (Triangle, Rect, translate)+import qualified Graphics.Rendering.OpenGL as GL+import qualified Graphics.UI.GLUT as GLUT hiding (Rect, translate)+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import System.Time+import Debug.Trace++import Image++frameRate :: Num a => a+frameRate = 40++type Coord = Double+type Point = (Coord, Coord)+type Vector = (Coord, Coord)+type Rect = (Point, Vector)   -- Central point and size from centre to edge+type Sprite = (Rect, String)++data MouseEvent = MouseDown Point | MouseMove Point | MouseUp Point+    deriving Show++plus :: Point -> Vector -> Point+plus (x0, y0) (x1, y1) = (x0 + x1, y0 + y1)++minus :: Point -> Point -> Vector+minus (x0, y0) (x1, y1) = (x0 - x1, y0 - y1)++-- | True if the point is inside the rectangle+inside :: Point -> Rect -> Bool+inside (x, y) ((ox, oy), (wx, wy)) =+    x >= ox - wx && x <= ox + wx &&+    y >= oy - wy && y <= oy + wy++-- | True if the two rectangles overlap+overlaps :: Rect -> Rect -> Bool+overlaps ((x0, y0), (w0, h0)) ((x1, y1), (w1, h1)) =+    let ax0 = x0 - w0+        ay0 = y0 - h0+        ax1 = x0 + w0+        ay1 = y0 + h0+        bx0 = x1 - w1+        by0 = y1 - h1+        bx1 = x1 + w1+        by1 = y1 + h1+    in ax1 > bx0 &&+       ay1 > by0 &&+       ax0 < bx1 &&+       ay0 < by1++-- | Get system time in seconds since the start of the Unix epoch+-- (1 Jan 1970).+getTime :: IO Double+getTime = do+    (TOD sec pico) <- getClockTime+    return $!+        (fromIntegral sec) ++        (fromIntegral pico) / 1000000000000++-- | Game, which takes mouse event and time as input, and a list of sprites to draw+-- as output. Time is updated once per animation frame.+type Game = Event MouseEvent -> Behaviour Double -> Reactive (Behaviour [Sprite])++runGame :: String -> Game -> IO ()+runGame title game = do++    (eMouse, pushMouse) <- sync newEvent+    (eTime, pushTime) <- sync newEvent+    spritesRef <- newIORef []+    _ <- sync $ do+        time <- hold 0 eTime+        sprites <- game eMouse time+        listen (values sprites) (writeIORef spritesRef)++    _ <- GLUT.getArgsAndInitialize+    GLUT.initialDisplayMode $= [GLUT.DoubleBuffered]+    GLUT.createWindow title+    GLUT.windowSize $= GLUT.Size 700 500+    blend $= Enabled+    blendFunc $= (SrcAlpha, OneMinusSrcAlpha)+    multisample $= Enabled+    shadeModel $= Smooth+    polygonSmooth $= Enabled+    hint PolygonSmooth $= Nicest+    hint LineSmooth $= Nicest+    normalize $= Enabled++    texturesRef <- newIORef M.empty+    t0 <- getTime+    GLUT.displayCallback $= display texturesRef t0 pushTime spritesRef+    let motion (GLUT.Position x y) = do+            pt <- toScreen x y+            sync $ pushMouse (MouseMove pt)+    GLUT.motionCallback $= Just motion+    GLUT.passiveMotionCallback $= Just motion+    GLUT.keyboardMouseCallback $= Just (\key keyState mods pos -> do+            case (key, keyState, pos) of+                (GLUT.MouseButton GLUT.LeftButton, GLUT.Down, GLUT.Position x y) ->+                    sync . pushMouse . MouseDown =<< toScreen x y+                (GLUT.MouseButton GLUT.LeftButton, GLUT.Up,   GLUT.Position x y) ->+                    sync . pushMouse . MouseUp   =<< toScreen x y+                _ -> return ()+        )+    GLUT.addTimerCallback (1000 `div` frameRate) $ repaint+    GLUT.mainLoop+  where+    toScreen :: GLint -> GLint -> IO (Coord, Coord)+    toScreen x y = do+        (_, Size w h) <- get viewport+        let aspect = fromIntegral w / fromIntegral h+            sx = 0.001/aspect+            sy = 0.001+            xx = 2 * ((fromIntegral x / fromIntegral w) - 0.5) / sx+            yy = 2 * (0.5 - (fromIntegral y / fromIntegral h)) / sy+        return (xx, yy)+    repaint = do+        GLUT.postRedisplay Nothing+        GLUT.addTimerCallback (1000 `div` frameRate) $ repaint++    period = 1 / frameRate++    display :: IORef (Map String (TextureImage, TextureObject))+            -> Double+            -> (Double -> Reactive ())+            -> IORef [Sprite]+            -> IO ()+    display texturesRef t0 pushTime spritesRef = do++        t <- subtract t0 <$> getTime+        sync $ pushTime t++        sprites <- readIORef spritesRef++        clearColor $= Color4 0 0 0 (1 :: GLclampf)+        --clearColor $= Color4 0.1 0.1 0.15 (1 :: GLclampf)+        clear [ColorBuffer{-, DepthBuffer-}]+        loadIdentity++        (_, Size w h) <- get viewport+        let aspect = fromIntegral w / fromIntegral h+        scale (0.001/aspect) 0.001 (0.001 :: GLfloat)++        forM_ sprites $ \(((posX, posY),(sizeX, sizeY)),imgFile) -> do+            textures <- readIORef texturesRef+            (TextureImage iWidth iHeight pWidth pHeight _ _, to) <- case imgFile `M.lookup` textures of+                Just (ti, to) -> return (ti, to)+                Nothing       -> do+                    ti <- loadTexture imgFile False+                    to <- createTexture ti+                    modifyIORef texturesRef (M.insert imgFile (ti, to))+                    return $ (ti, to)++            preservingMatrix $ do+                texture Texture2D $= Enabled+                textureBinding Texture2D $= Just to+                GL.translate $ Vector3 (realToFrac posX) (realToFrac posY) (0 :: GLdouble)+                let w2 = realToFrac sizeX :: GLdouble+                    h2 = realToFrac sizeY :: GLdouble+                    cx = realToFrac pWidth / realToFrac iWidth :: GLfloat+                    cy = realToFrac pHeight / realToFrac iHeight :: GLfloat+                renderPrimitive Polygon $ do+                    texCoord $ TexCoord2 0 cy+                    vertex $ Vertex2 (-w2) (-h2)+                    texCoord $ TexCoord2 cx cy+                    vertex $ Vertex2 w2 (-h2)+                    texCoord $ TexCoord2 cx 0+                    vertex $ Vertex2 w2 h2+                    texCoord $ TexCoord2 0 (0 :: GLfloat)+                    vertex $ Vertex2 (-w2) h2+                texture Texture2D $= Disabled+            --translate $ Vector3 0 0 (0.001 :: GLdouble)++        GLUT.swapBuffers

@@ -0,0 +1,134 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Image where++import Data.ByteString (ByteString)     +import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Unsafe as B+import Graphics.Rendering.OpenGL as GL hiding (RGB, RGBA)+import qualified Graphics.Rendering.OpenGL as GL+import Codec.Image.STB+import Data.Bitmap+import Data.Char+import Control.Exception+import Control.Monad+import Data.Typeable+import Data.Word+import Foreign+import Foreign.C+++data Format = RGB | RGBA deriving (Eq, Show)++data TextureImage_ d = TextureImage !Int !Int !Int !Int Format d deriving Show+type TextureImage = TextureImage_ ByteString+data ImageException = ImageException String+    deriving Typeable+instance Exception ImageException+instance Show ImageException where+    showsPrec _ (ImageException err) = ("ImageException: "++) . (err++)++loadTexture :: FilePath+            -> Bool               -- ^ True to invert it+            -> IO TextureImage+loadTexture path invert = do+        eImg <- loadImage path+        img <- case eImg of+            Left err -> throwIO $ ImageException $+                "Failed to load image file "++path++": "++err+            Right img -> return img+        withBitmap img $ \(width, height) components padding imgData0 -> do+            fmt <- case components of+                3 -> return RGB+                4 -> return RGBA+                _ -> throwIO $ ImageException $+                    "Failed to load image file "++path++": we only support RGB images"+            let len = width * height * components+            imgData <- mallocBytes len+            B.memcpy imgData imgData0 (fromIntegral len)+            when invert $ do+                let row = width * bytesPerPixel fmt+                    row_sz = fromIntegral row+                allocaBytes row $ \tempRow -> do+                    forM_ [0..height `div` 2] $ \y -> do+                        let r0 = row * y+                            s0 = row * (height - 1 - y)+                        B.memcpy tempRow (imgData `plusPtr` r0) row_sz+                        B.memcpy (imgData `plusPtr` r0) (imgData `plusPtr` s0) row_sz+                        B.memcpy (imgData `plusPtr` s0) tempRow row_sz+            let tex = TextureImage width height width height fmt imgData+            transparent <- hasTransparency tex+            tex' <- if transparent then return tex else removeAlphaChannel tex+            unsafeTextureToBS tex'++-- | Converts a buffer-based Texture to to a ByteString-based one.  Frees+-- the input byte buffer.+unsafeTextureToBS :: TextureImage_ (Ptr Word8) -> IO TextureImage+unsafeTextureToBS (TextureImage iWidth iHeight pWidth pHeight fmt buf) = do+    let bpp = bytesPerPixel fmt+        sz = bpp * iWidth * iHeight+    bytes <- peekArray sz buf+    free buf+    return $ TextureImage iWidth iHeight pWidth pHeight fmt (B.pack bytes)++bytesPerPixel :: Format -> Int+bytesPerPixel RGB = 3+bytesPerPixel RGBA = 4++hasTransparency :: TextureImage_ (Ptr Word8) -> IO Bool+hasTransparency (TextureImage _ _ _ _ RGB _) = return False+hasTransparency (TextureImage width height _ _ fmt@RGBA imgData) = h 0+  where+    limit = width * height+    bpp = bytesPerPixel fmt+    h ix | ix >= limit = return False+    h ix = do+        alpha <- peekByteOff imgData (ix * bpp + 3) :: IO Word8+        if alpha < 255+            then return True+            else h (ix + 1)++removeAlphaChannel :: TextureImage_ (Ptr Word8) -> IO (TextureImage_ (Ptr Word8))+removeAlphaChannel tex@(TextureImage _ _ _ _ RGB _) = return tex+removeAlphaChannel (TextureImage iWidth iHeight pWidth pHeight fmt@RGBA imgData) = do+    forM_ [1..limit-1] $ \ix -> do+        r <- peekByteOff imgData (ix * bpp) :: IO Word8+        pokeByteOff imgData (ix * 3) r+        g <- peekByteOff imgData (ix * bpp + 1) :: IO Word8+        pokeByteOff imgData (ix * 3 + 1) g+        b <- peekByteOff imgData (ix * bpp + 2) :: IO Word8+        pokeByteOff imgData (ix * 3 + 2) b+    return (TextureImage iWidth iHeight pWidth pHeight RGB imgData)+  where+    limit = iWidth * iHeight+    bpp = bytesPerPixel fmt++-- | Convert texture data into an OpenGL handle+createTexture :: TextureImage+              -> IO TextureObject+createTexture (TextureImage iWid iHt _ _ fmt imgBS) = do+    [texName] <- genObjectNames 1  -- generate our texture.+    --rowAlignment  Unpack $= 1+    textureBinding Texture2D $= Just texName  -- make our new texture the current texture.+    generateMipmap Texture2D $= Enabled+    B.unsafeUseAsCStringLen imgBS $ \(buf, len) -> do+        let glFmt = case fmt of+                RGB  -> GL.RGB+                RGBA -> GL.RGBA+            pixels = PixelData glFmt UnsignedByte buf+        build2DMipmaps Texture2D RGBA' (fromIntegral iWid) (fromIntegral iHt) pixels+    GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')+    return texName++-- | Ensure this label can be a valid filename+cleanLabel :: String -> String+cleanLabel =+    scrunch .+    map (\c -> if (c >= 'a' && c <= 'z') ||+                  (c >= 'A' && c <= 'Z') ||+                  (c >= '0' && c <= '9') then c else '_')+  where+    scrunch ('_':'_':cs) = scrunch ('_':cs)+    scrunch (c:cs) = c:scrunch cs+    scrunch [] = []+

binary file changed (absent → 691 bytes)

binary file changed (absent → 1362 bytes)

binary file changed (absent → 1214 bytes)

binary file changed (absent → 1305 bytes)

binary file changed (absent → 681 bytes)

binary file changed (absent → 959 bytes)

binary file changed (absent → 641 bytes)

binary file changed (absent → 1071 bytes)

binary file changed (absent → 1147 bytes)

binary file changed (absent → 1084 bytes)

binary file changed (absent → 1278 bytes)

binary file changed (absent → 931 bytes)

binary file changed (absent → 1636 bytes)

binary file changed (absent → 2015 bytes)

binary file changed (absent → 1463 bytes)

binary file changed (absent → 1501 bytes)

binary file changed (absent → 1885 bytes)

binary file changed (absent → 805 bytes)

binary file changed (absent → 1865 bytes)

binary file changed (absent → 844 bytes)

binary file changed (absent → 1685 bytes)

binary file changed (absent → 2037 bytes)

binary file changed (absent → 2502 bytes)

binary file changed (absent → 2314 bytes)

binary file changed (absent → 2730 bytes)

binary file changed (absent → 1453 bytes)

binary file changed (absent → 1446 bytes)

binary file changed (absent → 1146 bytes)

binary file changed (absent → 1189 bytes)

binary file changed (absent → 1268 bytes)

binary file changed (absent → 1429 bytes)

binary file changed (absent → 1246 bytes)

binary file changed (absent → 1585 bytes)

binary file changed (absent → 1442 bytes)

binary file changed (absent → 1447 bytes)

binary file changed (absent → 2393 bytes)

binary file changed (absent → 2632 bytes)

binary file changed (absent → 2579 bytes)

binary file changed (absent → 773 bytes)

binary file changed (absent → 746 bytes)

binary file changed (absent → 1546 bytes)

binary file changed (absent → 1860 bytes)

binary file changed (absent → 1434 bytes)

binary file changed (absent → 1488 bytes)

binary file changed (absent → 1589 bytes)

binary file changed (absent → 1805 bytes)

binary file changed (absent → 1597 bytes)

binary file changed (absent → 1939 bytes)

binary file changed (absent → 1595 bytes)

binary file changed (absent → 1923 bytes)

binary file changed (absent → 2618 bytes)

binary file changed (absent → 2854 bytes)

binary file changed (absent → 2902 bytes)

@@ -0,0 +1,108 @@+<HTML>+<HEAD>+<META NAME="description" CONTENT="A full deck of Playing Card Icons">+<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=ISO-8859-1">+<META NAME="keywords" CONTENT="Playing Cards, deck of cards, deck, cards, icons, images">+<TITLE>Playing Cards</TITLE>+</HEAD>+<BODY BGCOLOR=#006633  TEXT=#e1ffd7 LINK=#FFFFFF VLINK=#FFFFFF>+<CENTER>+<TABLE BORDER=0 CELLSPACING=10 CELLPADDING=10>+<TR>+<TD>+<IMG SRC="b1pt.png"><BR>+<IMG SRC="b1fh.png"><BR>+<IMG SRC="b1pb.png"><BR>+</TD>+<TD>+<IMG SRC="b1pl.png">+<IMG SRC="b1fv.png">+<IMG SRC="b1pr.png">+</TD>+<TD><IMG SRC="jb.png"></TD>+<TD VALIGN=CENTER><STRONG>Playing Cards</STRONG></TD>+<TD><IMG SRC="jr.png"></TD>+<TD>+<IMG SRC="b2pl.png">+<IMG SRC="b2fv.png">+<IMG SRC="b2pr.png">+</TD>+<TD>+<IMG SRC="b2pt.png"><BR>+<IMG SRC="b2fh.png"><BR>+<IMG SRC="b2pb.png"><BR>+</TD>+</TR>+<TR></TR>+</TABLE>+<TABLE BORDER=1 CELLSPACING=0 CELLPADDING=0>+<TR>+<TD ALIGN=CENTER><IMG SRC="c1.png"></TD>+<TD ALIGN=CENTER><IMG SRC="c2.png"></TD>+<TD ALIGN=CENTER><IMG SRC="c3.png"></TD>+<TD ALIGN=CENTER><IMG SRC="c4.png"></TD>+<TD ALIGN=CENTER><IMG SRC="c5.png"></TD>+<TD ALIGN=CENTER><IMG SRC="c6.png"></TD>+<TD ALIGN=CENTER><IMG SRC="c7.png"></TD>+<TD ALIGN=CENTER><IMG SRC="c8.png"></TD>+<TD ALIGN=CENTER><IMG SRC="c9.png"></TD>+<TD ALIGN=CENTER><IMG SRC="c10.png"></TD>+<TD ALIGN=CENTER><IMG SRC="cj.png"></TD>+<TD ALIGN=CENTER><IMG SRC="cq.png"></TD>+<TD ALIGN=CENTER><IMG SRC="ck.png"></TD>+</TR>+<TR>+<TD ALIGN=CENTER><IMG SRC="h1.png"></TD>+<TD ALIGN=CENTER><IMG SRC="h2.png"></TD>+<TD ALIGN=CENTER><IMG SRC="h3.png"></TD>+<TD ALIGN=CENTER><IMG SRC="h4.png"></TD>+<TD ALIGN=CENTER><IMG SRC="h5.png"></TD>+<TD ALIGN=CENTER><IMG SRC="h6.png"></TD>+<TD ALIGN=CENTER><IMG SRC="h7.png"></TD>+<TD ALIGN=CENTER><IMG SRC="h8.png"></TD>+<TD ALIGN=CENTER><IMG SRC="h9.png"></TD>+<TD ALIGN=CENTER><IMG SRC="h10.png"></TD>+<TD ALIGN=CENTER><IMG SRC="hj.png"></TD>+<TD ALIGN=CENTER><IMG SRC="hq.png"></TD>+<TD ALIGN=CENTER><IMG SRC="hk.png"></TD>+</TR>+<TR>+<TD ALIGN=CENTER><IMG SRC="s1.png"></TD>+<TD ALIGN=CENTER><IMG SRC="s2.png"></TD>+<TD ALIGN=CENTER><IMG SRC="s3.png"></TD>+<TD ALIGN=CENTER><IMG SRC="s4.png"></TD>+<TD ALIGN=CENTER><IMG SRC="s5.png"></TD>+<TD ALIGN=CENTER><IMG SRC="s6.png"></TD>+<TD ALIGN=CENTER><IMG SRC="s7.png"></TD>+<TD ALIGN=CENTER><IMG SRC="s8.png"></TD>+<TD ALIGN=CENTER><IMG SRC="s9.png"></TD>+<TD ALIGN=CENTER><IMG SRC="s10.png"></TD>+<TD ALIGN=CENTER><IMG SRC="sj.png"></TD>+<TD ALIGN=CENTER><IMG SRC="sq.png"></TD>+<TD ALIGN=CENTER><IMG SRC="sk.png"></TD>+</TR>+<TR>+<TD ALIGN=CENTER><IMG SRC="d1.png"></TD>+<TD ALIGN=CENTER><IMG SRC="d2.png"></TD>+<TD ALIGN=CENTER><IMG SRC="d3.png"></TD>+<TD ALIGN=CENTER><IMG SRC="d4.png"></TD>+<TD ALIGN=CENTER><IMG SRC="d5.png"></TD>+<TD ALIGN=CENTER><IMG SRC="d6.png"></TD>+<TD ALIGN=CENTER><IMG SRC="d7.png"></TD>+<TD ALIGN=CENTER><IMG SRC="d8.png"></TD>+<TD ALIGN=CENTER><IMG SRC="d9.png"></TD>+<TD ALIGN=CENTER><IMG SRC="d10.png"></TD>+<TD ALIGN=CENTER><IMG SRC="dj.png"></TD>+<TD ALIGN=CENTER><IMG SRC="dq.png"></TD>+<TD ALIGN=CENTER><IMG SRC="dk.png"></TD>+</TR>+</TABLE>+<TABLE BORDER=0 CELLSPACING=10>+<TR>+<TD ALIGN=CENTER><FONT SIZE=2><BR>+These images were created using <A HREF="http://www.mindworkshop.com/alchemy/alchemy.html">GIFCon</A>.+</FONT></TD>+</TR>+</TABLE>+</BODY>+</HTML>

binary file changed (absent → 1171 bytes)

binary file changed (absent → 1175 bytes)

@@ -0,0 +1,16 @@+http://www.jfitz.com/cards/+++These images were created using GIFCon, XnView and Paint Shop Pro.+Feel free to use for personal or professional purposes, subject to the following:+Additional Copyright information:+Larry Ewing <lewing@isc.tamu.edu> created Tux using GIMP.+Marshall Kirk McKusick <mckusick@mckusick.com> is the copyright holder and creator of the BSD Daemon image.+The "Windows" cards were originally designed by Susan Kare for Microsoft.+To the best of my knowledge, the images used in any "standard" French/British 52 card deck are public domain.+The top Jokers are derived from an image I found of a John Waddington design.+The bottom Jokers were created by me as quick placeholders for a design I never got around to implementing.+I guess it's possible that Microsoft could claim copyright on the Windows Ace of Spades.+If they did, I'd suggest filling in or changing the white pattern on the Spade.++Please click here if you have problems viewing the graphics on this page. 

binary file changed (absent → 950 bytes)

binary file changed (absent → 1951 bytes)

binary file changed (absent → 1401 bytes)

binary file changed (absent → 1453 bytes)

binary file changed (absent → 1660 bytes)

binary file changed (absent → 1918 bytes)

binary file changed (absent → 1635 bytes)

binary file changed (absent → 2063 bytes)

binary file changed (absent → 1645 bytes)

binary file changed (absent → 1990 bytes)

binary file changed (absent → 2368 bytes)

binary file changed (absent → 2318 bytes)

binary file changed (absent → 2627 bytes)

@@ -0,0 +1,338 @@+{-# LANGUAGE DoRec #-}+-- Package dependencies:+--     random+--     stb-image+--     OpenGL+--     GLUT+import FRP.Sodium+import Control.Applicative+import Control.Monad+import Data.Traversable (sequenceA)+import Data.List+import Data.Maybe+import Engine+import System.Random+import System.FilePath+import Data.Array.IArray as A+import Data.Array.ST++data Suit  = Spades | Clubs | Diamonds | Hearts+             deriving (Eq, Ord, Show, Enum, Bounded)+data Value = Ace | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | Jack | Queen | King+             deriving (Eq, Ord, Show, Enum, Bounded)+data Card  = Card Value Suit+             deriving (Eq, Ord, Show)++instance Enum Card where+    fromEnum (Card v s) = fromEnum v + fromEnum s * 13+    toEnum i = Card (toEnum v) (toEnum s)+      where+        (s, v) = divMod i 13++instance Bounded Card where+    minBound = Card minBound minBound+    maxBound = Card maxBound maxBound ++noOfStacks :: Int+noOfStacks = 8++noOfCells :: Int+noOfCells = 4++cardSize :: Vector+cardSize = (100,150)++overlapY :: Double+overlapY = 90++data Location = Stack Int | Cell Int | Grave deriving (Eq, Show)++data Bunch = Bunch {+        buInitOrig     :: Point,+        buInitMousePos :: Point,+        buCards        :: [Card],+        buOrigin       :: Location+    }+    deriving Show++data Destination = Destination {+        deLocation :: Location,+        deDropZone :: Rect,+        deMayDrop  :: [Card] -> Bool+    }++validSequence :: [Card] -> Bool+validSequence xs = and $ zipWith follows xs (drop 1 xs)++follows :: Card -> Card -> Bool+follows one@(Card v1 _) two@(Card v2 _) = isRed one /= isRed two && (v1 /= Ace && pred v1 == v2)+  where+    isRed :: Card -> Bool+    isRed (Card _ suit) = suit == Hearts || suit == Diamonds++cardSpacing :: Double+cardSpacing = (2000-cardWidth) / fromIntegral (noOfStacks-1)+  where+    (cardWidth, _) = cardSize++cardSpacingNarrow :: Double+cardSpacingNarrow = cardSpacing * 0.9++topRow :: Double+topRow = 1000 - 50 - cardHeight+  where+    (cardWidth, cardHeight) = cardSize++draw :: Point -> Card -> Sprite+draw pt (Card v s) = ((pt, cardSize), "cards" ++ [pathSeparator] ++ suitName s ++ valueName v ++ ".png")+  where+    suitName Spades = "s"+    suitName Clubs = "c"+    suitName Diamonds = "d"+    suitName Hearts = "h"+    valueName Ace = "1"+    valueName Two = "2"+    valueName Three = "3"+    valueName Four = "4"+    valueName Five = "5"+    valueName Six = "6"+    valueName Seven = "7"+    valueName Eight = "8"+    valueName Nine = "9"+    valueName Ten = "10"+    valueName Jack = "j"+    valueName Queen = "q"+    valueName King = "k"++emptySpace :: Point -> Sprite+emptySpace pt = ((pt, cardSize), "cards" ++ [pathSeparator] ++ "empty-space.png") ++-- | The vertical stacks of cards, where cards can only be added if they're+-- descending numbers and alternating red-black.+stack :: Event MouseEvent -> [Card] -> Location -> Behavior Int -> Event [Card]+      -> Reactive (Behavior [Sprite], Behavior Destination, Event Bunch)+stack eMouse initCards loc@(Stack ix) freeSpaces eDrop = do+    let (cardWidth, cardHeight) = cardSize+        orig@(origX, origY) = (+                (-1000) + cardWidth*0.5 + fromIntegral ix * cardSpacing,+                300+            )+        positions = iterate (\(x, y) -> (x, y-overlapY)) orig+    rec+        cards <- hold initCards (eRemoveCards `merge` eAddCards)+        let eAddCards = snapshotWith (\newCards cards -> cards ++ newCards) eDrop cards+            eMouseSelection = filterJust $ snapshotWith (\mev cards ->+                    case mev of+                        MouseDown pt@(x, y) | x >= origX - cardWidth && x <= origX + cardWidth ->+                            let n = length cards+                                bottomY = (origY - cardHeight) - overlapY * fromIntegral (n-1) +                                ix = (length cards - 1) `min` floor (((origY + cardHeight) - y) / overlapY)+                                (left, taken) = splitAt ix cards+                            in  if ix >= 0 && y >= bottomY+                                    then Just (left, Bunch (positions !! ix) pt taken loc)+                                    else Nothing+                        _ -> Nothing+                ) eMouse cards+            eRemoveCards = fst <$> eMouseSelection   -- Cards left over when we drag+            eDrag        = snd <$> eMouseSelection   -- Cards removed when we drag+    let sprites = map (uncurry draw) . zip positions <$> cards+        dest = (\cards freeSpaces -> Destination {+                    deLocation = loc,+                    deDropZone = (orig `minus` (0, fromIntegral (length cards) * overlapY), cardSize),+                    deMayDrop = \newCards ->+                        validSequence newCards &&+                        -- You get one card for free, but there must be free cells for any+                        -- more than that.+                        (length newCards - 1) <= freeSpaces &&+                        case cards of+                            [] -> True+                            _  -> last cards `follows` head newCards+                }+            ) <$> cards <*> freeSpaces+    return (sprites, dest, eDrag)++-- | The "free cells" where cards can be temporarily put.+cell :: Event MouseEvent -> Location -> Event [Card]+     -> Reactive (Behavior [Sprite], Behavior Destination, Event Bunch, Behavior Int)+cell eMouse loc@(Cell ix) eDrop = do+    let (cardWidth, cardHeight) = cardSize+        orig = ((-1000) + cardWidth*0.5 + fromIntegral ix * cardSpacingNarrow, topRow)+        rect = (orig, cardSize)+    rec+        mCard <- hold Nothing $ eRemove `merge` (Just . head <$> eDrop)+        let eMouseSelection = filterJust $ snapshotWith (\mev mCard ->+                    case (mev, mCard) of+                        (MouseDown pt, Just card) | pt `inside` rect ->+                            Just (Nothing, Bunch (fst rect) pt [card] loc)+                        _ -> Nothing+                ) eMouse mCard+            eRemove = fst <$> eMouseSelection+            eDrag = snd <$> eMouseSelection+    let sprites = ((:[]) . maybe (emptySpace orig) (draw orig)) <$> mCard+        dest = (\mCard -> Destination {+                deLocation = loc,+                deDropZone = rect,+                deMayDrop = \newCards -> length newCards == 1 && isNothing mCard+            }) <$> mCard+        emptySpaces = (\c -> if isNothing c then 1 else 0) <$> mCard+    return (sprites, dest, eDrag, emptySpaces)++-- | The place where the cards end up at the top right, aces first.+grave :: Event MouseEvent -> Event [Card]+      -> Reactive (Behavior [Sprite], Behavior Destination, Event Bunch)+grave eMouse eDrop = do+    let xOf ix = 1000 - cardWidth*0.5 - cardSpacingNarrow * fromIntegral (3-ix)+        positions = map (\ix -> (xOf ix, topRow)) [0..3]+        areas = zip positions (repeat cardSize)+        (cardWidth, cardHeight) = cardSize+        wholeRect = (((xOf 0 + xOf 3) * 0.5, topRow), ((cardSpacingNarrow * 3 + cardWidth*2) * 0.5, cardHeight))    +    rec+        let eDropModify = snapshotWith (\newCards slots ->+                    let newCard@(Card _ suit) = head newCards+                        ix = fromEnum suit+                    in  take ix slots ++ [Just newCard] ++ drop (ix+1) slots +                ) eDrop slots+        slots <- hold [Nothing, Nothing, Nothing, Nothing] (eDropModify `merge` eRemove)+        let eMouseSelection = filterJust $ snapshotWith (\mev slots ->+                    case mev of+                        MouseDown pt ->+                            let isIn = map (pt `inside`) areas+                            in  case trueIxOf isIn of+                                    Just ix ->+                                        case slots !! ix of+                                            Just card@(Card value suit) ->+                                                let prevCard = if value == Ace then Nothing+                                                                               else Just (Card (pred value) suit)+                                                    slots' = take ix slots ++ [prevCard] ++ drop (ix+1) slots+                                                in  Just (slots', Bunch (positions !! ix) pt [card] Grave)+                                            Nothing -> Nothing+                                    Nothing -> Nothing+                        _ -> Nothing+                ) eMouse slots+            eRemove = fst <$> eMouseSelection+            eDrag = snd <$> eMouseSelection+    let sprites = zipWith (\pos mSlot ->+                maybe (emptySpace pos) (draw pos) mSlot+            ) positions <$> slots+        dest = (\slots -> Destination {+                deLocation = Grave,+                deDropZone = wholeRect,+                deMayDrop = \newCards -> case newCards of+                    [card@(Card value suit)] ->+                        let ix = fromEnum suit+                        in  case slots !! ix of+                                Just (Card topValue _) -> value == succ topValue+                                Nothing                -> value == Ace +                    _                    -> False+            }) <$> slots+    return (sprites, dest, eDrag)+  where+    -- Index of first true item in the list+    trueIxOf items = doit items 0+      where+        doit [] _ = Nothing+        doit (x:xs) ix = if x then Just ix+                              else doit xs (ix+1)++-- | Draw the cards while they're being dragged.+dragger :: Event MouseEvent -> Event Bunch -> Reactive (Behavior [Sprite], Event (Point, Bunch))+dragger eMouse eStartDrag = do+    dragPos <- hold (0,0) $ flip fmap eMouse $ \mev ->+        case mev of+            MouseUp   pt -> pt+            MouseMove pt -> pt+            MouseDown pt -> pt+    rec+        dragging <- hold Nothing $ (const Nothing <$> eDrop) `merge` (Just <$> eStartDrag)+        let eDrop = filterJust $ snapshotWith (\mev mDragging ->+                    case (mev, mDragging) of+                        -- If the mouse is released, and we are dragging...+                        (MouseUp pt, Just dragging) -> Just (cardPos pt dragging, dragging)+                        _                           -> Nothing+                ) eMouse dragging+    let sprites = drawDraggedCards <$> dragPos <*> dragging+          where+            drawDraggedCards pt (Just bunch) =+                let cpos = cardPos pt bunch+                    positions = iterate (\(x, y) -> (x, y-overlapY)) cpos+                in  zipWith draw positions (buCards bunch) +            drawDraggedCards _ Nothing = []+    return (sprites, eDrop)+  where+    cardPos pt bunch = (pt `minus` buInitMousePos bunch) `plus` buInitOrig bunch++-- | Determine where dropped cards are routed to.+dropper :: Event (Point, Bunch) -> Behavior [Destination] -> Event (Location, [Card])+dropper eDrop dests =+    snapshotWith (\(pt, bunch) dests ->+                -- If none of the destinations will accept the dropped cards, then send them+                -- back where they originated from.+                let findDest [] = (buOrigin bunch, buCards bunch)+                    findDest (dest:rem) =+                        if pt `inside` deDropZone dest && deMayDrop dest (buCards bunch)+                            then (deLocation dest, buCards bunch)+                            else findDest rem+                in  findDest dests+            ) eDrop dests++distributeTo :: Event (Location, [Card]) -> [Location] -> [Event [Card]]+distributeTo eWhere locations = flip map locations $ \thisLoc ->+    filterJust $ (\(loc, cards) ->+            if loc == thisLoc+                then Just cards+                else Nothing+        ) <$> eWhere++freecell :: [[Card]] -> Game+freecell stackCards eMouse time = do+    let stLocs = map Stack [0..noOfStacks-1]+        ceLocs = map Cell [0..noOfCells-1]+    rec+        let eWhere = dropper eDrop (sequenceA (stDests ++ ceDests ++ [grDest]))+            stDrops = eWhere `distributeTo` stLocs+            ceDrops = eWhere `distributeTo` ceLocs+            grDrops = eWhere `distributeTo` [Grave]+        (stSprites, stDests, stDrags) <- unzip3 <$> forM (zip3 stLocs stackCards stDrops) (\(loc, cards, drop) ->+            stack eMouse cards loc emptySpaces drop)+        (ceSprites, ceDests, ceDrags, ceEmptySpaces) <- unzip4 <$> forM (zip ceLocs ceDrops) (\(loc, drop) ->+            cell eMouse loc drop)+        (grSprites, grDest, grDrag) <- grave eMouse (head grDrops)+        -- The total number of empty spaces available in cells - 0 to 4. We need to+        -- know this when we drop a stack of cards, because (the rules of the game say)+        -- this is equivalent to temporarily putting all but one of them in cells.+        let emptySpaces = foldr1 (\x y -> (+) <$> x <*> y) ceEmptySpaces+        (drSprites, eDrop) <- dragger eMouse (foldr1 merge (stDrags ++ ceDrags ++ [grDrag]))+    return $ concat <$> sequenceA (stSprites ++ ceSprites ++ [grSprites] ++ [drSprites])++shuffle :: StdGen -> [Card] -> ([Card], StdGen)+shuffle rng cards =+    let n = length cards+        (rng', ixes) = mapAccumL (\rng () ->+                let (ix, rng') = randomR (0, n-1) rng+                in  (rng', ix)) rng (replicate n ())+        ary = runSTArray $ do+            ary <- newListArray (0, n-1) cards+            forM_ (zip [0..n-1] ixes) $ \(ix1, ix2) -> do+                when (ix1 /= ix2) $ do+                    one <- readArray ary ix1+                    two <- readArray ary ix2+                    writeArray ary ix1 two+                    writeArray ary ix2 one+            return ary+    in  (A.elems ary, rng')++toStacks :: Int -> [Card] -> [[Card]]+toStacks noOfStacks cards = foldl (\stacks layer ->+        zipWith (++) (map (:[]) layer ++ repeat []) stacks+    ) (replicate noOfStacks []) (layerize cards)+  where+    layerize :: [Card] -> [[Card]]+    layerize cards = case splitAt noOfStacks cards of+        ([], _) -> []+        (layer, rem) -> layer : layerize rem++main = do+    rng <- newStdGen+    let (cards, rng') = shuffle rng [minBound..maxBound]+    runGame "Freecell" (freecell (toStacks noOfStacks cards))+

@@ -0,0 +1,109 @@+{-# LANGUAGE DoRec, GeneralizedNewtypeDeriving #-}+-- Package dependencies:+--     random+--     stb-image+--     OpenGL+--     GLUT+import FRP.Sodium+import Control.Applicative+import Control.Monad.Trans+import Data.Maybe+import Engine+import System.Random++poodleSprite :: Point -> Sprite+poodleSprite pt = ((pt,(120,120)), "poodle.png")++-- | Active poodle logic (which could be made much more interesting).+poodle :: PoodleID+       -> Point+       -> Event MouseEvent+       -> Behaviour Double+       -> Reactive (Behaviour (PoodleID, Sprite))+poodle iD pos@(x0,y0) eMouse time = do+    t0 <- sample time+    let dt = subtract t0 <$> time+        bounce dt =+            let t = snd $ properFraction dt+            in  800 * t + (-800) * t^2+        sprite = (\dt -> (iD, poodleSprite (x0, y0 + bounce dt))) <$> dt+    return sprite++-- | Peel a new item off the list each time the event fires.+peelList :: Event x -> [a] -> Reactive (Behaviour a)+peelList ev xs0 =+    hold (head xs0)+            =<< collectE (\_ (x:xs) -> (x, xs)) (tail xs0) ev++-- | Generate events at random intervals.+randomTimes :: StdGen -> Behaviour Double -> Reactive (Event Double)+randomTimes rng time = do+    -- Infinite list of random intervals from 0.25 to 1.2 seconds.+    let intervals = randomRs (0.25, 1.2) rng+    rec+        tLast <- hold 0 eAppear+        interval <- peelList eAppear intervals+        let eTime = values time+            eAppear = filterJust $ snapshotWith (\t (tLast, interval) ->+                    if t >= tLast + interval then Just t else Nothing+                ) eTime ((,) <$> tLast <*> interval)+    return eAppear++newtype PoodleID = PoodleID Int deriving (Eq, Enum, Show)+data Action = Create PoodleID (Behaviour (PoodleID, Sprite)) | Destroy PoodleID++poodleGame :: StdGen -> Game+poodleGame rng eMouse time = do++    -- Random times for appearance of new poodles+    let (rng1, rng2_) = split rng+        (rng2, rng3) = split rng2_+    eAppear <- do+        randomTimes rng1 time++    -- Pick a position for each new poodle+    eNewPosition <- do+        -- Infinite list of random poodle positions+        let xs = randomRs (-900, 900) rng2+            ys = randomRs (-900, 500) rng3+        let idsAndPoses = zip [PoodleID 1..] (zip xs ys)+        -- Peel an item off the list for each new poodle+        collectE (\_ ((iD, pos):xs) -> ((iD, pos), xs)) idsAndPoses eAppear++    -- Construct a new active poodle for each new position+    let eCreations = execute $ (\(iD, pos) -> do+                beh <- poodle iD pos eMouse time+                return $ Create iD beh+            ) <$> eNewPosition++    rec+        -- Destroy poodles that are clicked on+        let eDestructions = filterJust $ snapshotWith (\mev poodles ->+                    case mev of+                        MouseDown clickPos -> listToMaybe+                            [ Destroy iD | (iD, (rect, _)) <- poodles,+                                   clickPos `inside` rect]+                        _ -> Nothing+                ) eMouse poodles++        -- Handle creations and destructions giving a behaviour containing a+        -- list of poodle behaviours.+        poodleBehs <- hold [] =<< collectE (\change poodles ->+                let poodles' = case change of+                        Create iD beh -> (iD, beh) : poodles+                        Destroy iD    -> filter (\(thisID, _) -> iD /= thisID) poodles+                in  (map snd poodles', poodles')+            ) [] (eCreations `merge` eDestructions)++        -- Convert list of behaviours into a behaviour containing a list,+        -- then flatten behaviour within behaviour down to a single behaviour of+        -- poodle sprites.+        poodles <- switch $ foldr (\ba bt -> (:) <$> ba <*> bt) (pure []) <$> poodleBehs++    -- Return poodle sprites without their ids+    return (map snd <$> poodles)++main = do+    rng <- newStdGen+    runGame "Poodle invasion - click the poodles to keep them under control" (poodleGame rng)+

binary file changed (absent → 148345 bytes)

@@ -1,177 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, EmptyDataDecls #-}-module Engine where--import FRP.Sodium--import Control.Applicative-import Control.Monad-import Data.List-import Graphics.Rendering.OpenGL as GL hiding (Triangle, Rect, translate)-import qualified Graphics.Rendering.OpenGL as GL-import qualified Graphics.UI.GLUT as GLUT hiding (Rect, translate)-import Data.IORef-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe-import System.Time-import Debug.Trace--import Image--frameRate :: Num a => a-frameRate = 40--type Coord = Double-type Point = (Coord, Coord)-type Vector = (Coord, Coord)-type Rect = (Point, Vector)   -- Central point and size from centre to edge-type Sprite = (Rect, String)--data MouseEvent = MouseDown Point | MouseMove Point | MouseUp Point-    deriving Show---- | True if the point is inside the rectangle-inside :: Point -> Rect -> Bool-inside (x, y) ((ox, oy), (wx, wy)) =-    x >= ox - wx && x <= ox + wx &&-    y >= oy - wy && y <= oy + wy---- | True if the two rectangles overlap-overlaps :: Rect -> Rect -> Bool-overlaps ((x0, y0), (w0, h0)) ((x1, y1), (w1, h1)) =-    let ax0 = x0 - w0-        ay0 = y0 - h0-        ax1 = x0 + w0-        ay1 = y0 + h0-        bx0 = x1 - w1-        by0 = y1 - h1-        bx1 = x1 + w1-        by1 = y1 + h1-    in ax1 > bx0 &&-       ay1 > by0 &&-       ax0 < bx1 &&-       ay0 < by1---- | Get system time in seconds since the start of the Unix epoch--- (1 Jan 1970).-getTime :: IO Double-getTime = do-    (TOD sec pico) <- getClockTime-    return $!-        (fromIntegral sec) +-        (fromIntegral pico) / 1000000000000---- | Game, which takes mouse event and time as input, and a list of sprites to draw--- as output. Time is updated once per animation frame.-type Game = Event MouseEvent -> Behaviour Double -> Reactive (Behaviour [Sprite])--runGame :: String -> Game -> IO ()-runGame title game = do--    (eMouse, pushMouse) <- sync newEvent-    (eTime, pushTime) <- sync newEvent-    spritesRef <- newIORef []-    _ <- sync $ do-        time <- hold 0 eTime-        sprites <- game eMouse time-        listenValue sprites (writeIORef spritesRef)--    _ <- GLUT.getArgsAndInitialize-    GLUT.initialDisplayMode $= [GLUT.DoubleBuffered]-    GLUT.createWindow title-    GLUT.windowSize $= GLUT.Size 700 500-    blend $= Enabled-    blendFunc $= (SrcAlpha, OneMinusSrcAlpha)-    multisample $= Enabled-    shadeModel $= Smooth-    polygonSmooth $= Enabled-    hint PolygonSmooth $= Nicest-    hint LineSmooth $= Nicest-    normalize $= Enabled--    texturesRef <- newIORef M.empty-    t0 <- getTime-    GLUT.displayCallback $= display texturesRef t0 pushTime spritesRef-    let motion (GLUT.Position x y) = do-            pt <- toScreen x y-            sync $ pushMouse (MouseMove pt)-    GLUT.motionCallback $= Just motion-    GLUT.passiveMotionCallback $= Just motion-    GLUT.keyboardMouseCallback $= Just (\key keyState mods pos -> do-            case (key, keyState, pos) of-                (GLUT.MouseButton GLUT.LeftButton, GLUT.Down, GLUT.Position x y) ->-                    sync . pushMouse . MouseDown =<< toScreen x y-                (GLUT.MouseButton GLUT.LeftButton, GLUT.Up,   GLUT.Position x y) ->-                    sync . pushMouse . MouseUp   =<< toScreen x y-                _ -> return ()-        )-    GLUT.addTimerCallback (1000 `div` frameRate) $ repaint-    GLUT.mainLoop-  where-    toScreen :: GLint -> GLint -> IO (Coord, Coord)-    toScreen x y = do-        (_, Size w h) <- get viewport-        let aspect = fromIntegral w / fromIntegral h-            sx = 0.001/aspect-            sy = 0.001-            xx = 2 * ((fromIntegral x / fromIntegral w) - 0.5) / sx-            yy = 2 * (0.5 - (fromIntegral y / fromIntegral h)) / sy-        return (xx, yy)-    repaint = do-        GLUT.postRedisplay Nothing-        GLUT.addTimerCallback (1000 `div` frameRate) $ repaint--    period = 1 / frameRate--    display :: IORef (Map String (TextureImage, TextureObject))-            -> Double-            -> (Double -> Reactive ())-            -> IORef [Sprite]-            -> IO ()-    display texturesRef t0 pushTime spritesRef = do--        t <- subtract t0 <$> getTime-        sync $ pushTime t--        sprites <- readIORef spritesRef--        clearColor $= Color4 0 0 0 (1 :: GLclampf)-        --clearColor $= Color4 0.1 0.1 0.15 (1 :: GLclampf)-        clear [ColorBuffer{-, DepthBuffer-}]-        loadIdentity--        (_, Size w h) <- get viewport-        let aspect = fromIntegral w / fromIntegral h-        scale (0.001/aspect) 0.001 (0.001 :: GLfloat)--        forM_ sprites $ \(((posX, posY),(sizeX, sizeY)),imgFile) -> do-            textures <- readIORef texturesRef-            (TextureImage iWidth iHeight pWidth pHeight _ _, to) <- case imgFile `M.lookup` textures of-                Just (ti, to) -> return (ti, to)-                Nothing       -> do-                    ti <- loadTexture imgFile False-                    to <- createTexture ti-                    modifyIORef texturesRef (M.insert imgFile (ti, to))-                    return $ (ti, to)--            preservingMatrix $ do-                texture Texture2D $= Enabled-                textureBinding Texture2D $= Just to-                GL.translate $ Vector3 (realToFrac posX) (realToFrac posY) (0 :: GLdouble)-                let w2 = realToFrac sizeX :: GLdouble-                    h2 = realToFrac sizeY :: GLdouble-                    cx = realToFrac pWidth / realToFrac iWidth :: GLfloat-                    cy = realToFrac pHeight / realToFrac iHeight :: GLfloat-                renderPrimitive Polygon $ do-                    texCoord $ TexCoord2 0 cy-                    vertex $ Vertex2 (-w2) (-h2)-                    texCoord $ TexCoord2 cx cy-                    vertex $ Vertex2 w2 (-h2)-                    texCoord $ TexCoord2 cx 0-                    vertex $ Vertex2 w2 h2-                    texCoord $ TexCoord2 0 (0 :: GLfloat)-                    vertex $ Vertex2 (-w2) h2-                texture Texture2D $= Disabled-            --translate $ Vector3 0 0 (0.001 :: GLdouble)--        GLUT.swapBuffers

@@ -1,134 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-module Image where--import Data.ByteString (ByteString)     -import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Unsafe as B-import Graphics.Rendering.OpenGL as GL hiding (RGB, RGBA)-import qualified Graphics.Rendering.OpenGL as GL-import Codec.Image.STB-import Data.Bitmap.IO-import Data.Char-import Control.Exception-import Control.Monad-import Data.Typeable-import Data.Word-import Foreign-import Foreign.C---data Format = RGB | RGBA deriving (Eq, Show)--data TextureImage_ d = TextureImage !Int !Int !Int !Int Format d deriving Show-type TextureImage = TextureImage_ ByteString-data ImageException = ImageException String-    deriving Typeable-instance Exception ImageException-instance Show ImageException where-    showsPrec _ (ImageException err) = ("ImageException: "++) . (err++)--loadTexture :: FilePath-            -> Bool               -- ^ True to invert it-            -> IO TextureImage-loadTexture path invert = do-        eImg <- loadImage path-        img <- case eImg of-            Left err -> throwIO $ ImageException $-                "Failed to load image file "++path++": "++err-            Right img -> return img-        withBitmap img $ \(width, height) components padding imgData0 -> do-            fmt <- case components of-                3 -> return RGB-                4 -> return RGBA-                _ -> throwIO $ ImageException $-                    "Failed to load image file "++path++": we only support RGB images"-            let len = width * height * components-            imgData <- mallocBytes len-            B.memcpy imgData imgData0 (fromIntegral len)-            when invert $ do-                let row = width * bytesPerPixel fmt-                    row_sz = fromIntegral row-                allocaBytes row $ \tempRow -> do-                    forM_ [0..height `div` 2] $ \y -> do-                        let r0 = row * y-                            s0 = row * (height - 1 - y)-                        B.memcpy tempRow (imgData `plusPtr` r0) row_sz-                        B.memcpy (imgData `plusPtr` r0) (imgData `plusPtr` s0) row_sz-                        B.memcpy (imgData `plusPtr` s0) tempRow row_sz-            let tex = TextureImage width height width height fmt imgData-            transparent <- hasTransparency tex-            tex' <- if transparent then return tex else removeAlphaChannel tex-            unsafeTextureToBS tex'---- | Converts a buffer-based Texture to to a ByteString-based one.  Frees--- the input byte buffer.-unsafeTextureToBS :: TextureImage_ (Ptr Word8) -> IO TextureImage-unsafeTextureToBS (TextureImage iWidth iHeight pWidth pHeight fmt buf) = do-    let bpp = bytesPerPixel fmt-        sz = bpp * iWidth * iHeight-    bytes <- peekArray sz buf-    free buf-    return $ TextureImage iWidth iHeight pWidth pHeight fmt (B.pack bytes)--bytesPerPixel :: Format -> Int-bytesPerPixel RGB = 3-bytesPerPixel RGBA = 4--hasTransparency :: TextureImage_ (Ptr Word8) -> IO Bool-hasTransparency (TextureImage _ _ _ _ RGB _) = return False-hasTransparency (TextureImage width height _ _ fmt@RGBA imgData) = h 0-  where-    limit = width * height-    bpp = bytesPerPixel fmt-    h ix | ix >= limit = return False-    h ix = do-        alpha <- peekByteOff imgData (ix * bpp + 3) :: IO Word8-        if alpha < 255-            then return True-            else h (ix + 1)--removeAlphaChannel :: TextureImage_ (Ptr Word8) -> IO (TextureImage_ (Ptr Word8))-removeAlphaChannel tex@(TextureImage _ _ _ _ RGB _) = return tex-removeAlphaChannel (TextureImage iWidth iHeight pWidth pHeight fmt@RGBA imgData) = do-    forM_ [1..limit-1] $ \ix -> do-        r <- peekByteOff imgData (ix * bpp) :: IO Word8-        pokeByteOff imgData (ix * 3) r-        g <- peekByteOff imgData (ix * bpp + 1) :: IO Word8-        pokeByteOff imgData (ix * 3 + 1) g-        b <- peekByteOff imgData (ix * bpp + 2) :: IO Word8-        pokeByteOff imgData (ix * 3 + 2) b-    return (TextureImage iWidth iHeight pWidth pHeight RGB imgData)-  where-    limit = iWidth * iHeight-    bpp = bytesPerPixel fmt---- | Convert texture data into an OpenGL handle-createTexture :: TextureImage-              -> IO TextureObject-createTexture (TextureImage iWid iHt _ _ fmt imgBS) = do-    [texName] <- genObjectNames 1  -- generate our texture.-    --rowAlignment  Unpack $= 1-    textureBinding Texture2D $= Just texName  -- make our new texture the current texture.-    generateMipmap Texture2D $= Enabled-    B.unsafeUseAsCStringLen imgBS $ \(buf, len) -> do-        let glFmt = case fmt of-                RGB  -> GL.RGB-                RGBA -> GL.RGBA-            pixels = PixelData glFmt UnsignedByte buf-        build2DMipmaps Texture2D RGBA' (fromIntegral iWid) (fromIntegral iHt) pixels-    GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')-    return texName---- | Ensure this label can be a valid filename-cleanLabel :: String -> String-cleanLabel =-    scrunch .-    map (\c -> if (c >= 'a' && c <= 'z') ||-                  (c >= 'A' && c <= 'Z') ||-                  (c >= '0' && c <= '9') then c else '_')-  where-    scrunch ('_':'_':cs) = scrunch ('_':cs)-    scrunch (c:cs) = c:scrunch cs-    scrunch [] = []-

@@ -1,109 +0,0 @@-{-# LANGUAGE DoRec, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}--- Package dependencies:---     random---     stb-image---     OpenGL---     GLUT-import FRP.Sodium-import Control.Applicative-import Control.Monad.Trans-import Data.Maybe-import Engine-import System.Random--poodleSprite :: Point -> Sprite-poodleSprite pt = ((pt,(120,120)), "poodle.png")---- | Active poodle logic (which could be made much more interesting).-poodle :: PoodleID-       -> Point-       -> Event MouseEvent-       -> Behaviour Double-       -> Reactive (Behaviour (PoodleID, Sprite))-poodle iD pos@(x0,y0) eMouse time = do-    t0 <- sample time-    let dt = subtract t0 <$> time-        bounce dt =-            let t = snd $ properFraction dt-            in  800 * t + (-800) * t^2-        sprite = (\dt -> (iD, poodleSprite (x0, y0 + bounce dt))) <$> dt-    return sprite---- | Peel a new item off the list each time the event fires.-peelList :: Event x -> [a] -> Reactive (Behaviour a)-peelList ev xs0 =-    hold (head xs0)-            =<< collectE (\_ (x:xs) -> (x, xs)) (tail xs0) ev---- | Generate events at random intervals.-randomTimes :: StdGen -> Behaviour Double -> Reactive (Event Double)-randomTimes rng time = do-    -- Infinite list of random intervals from 0.25 to 1.2 seconds.-    let intervals = randomRs (0.25, 1.2) rng-    rec-        tLast <- hold 0 eAppear-        interval <- peelList eAppear intervals-        let eTime = values time-            eAppear = filterJust $ snapshotWith (\t (tLast, interval) ->-                    if t >= tLast + interval then Just t else Nothing-                ) eTime ((,) <$> tLast <*> interval)-    return eAppear--newtype PoodleID = PoodleID Int deriving (Eq, Enum, Show)-data Action = Create PoodleID (Behaviour (PoodleID, Sprite)) | Destroy PoodleID--poodleGame :: StdGen -> Game-poodleGame rng eMouse time = do--    -- Random times for appearance of new poodles-    let (rng1, rng2_) = split rng-        (rng2, rng3) = split rng2_-    eAppear <- do-        randomTimes rng1 time--    -- Pick a position for each new poodle-    eNewPosition <- do-        -- Infinite list of random poodle positions-        let xs = randomRs (-900, 900) rng2-            ys = randomRs (-900, 500) rng3-        let idsAndPoses = zip [PoodleID 1..] (zip xs ys)-        -- Peel an item off the list for each new poodle-        collectE (\_ ((iD, pos):xs) -> ((iD, pos), xs)) idsAndPoses eAppear--    -- Construct a new active poodle for each new position-    let eCreations = execute $ (\(iD, pos) -> do-                beh <- poodle iD pos eMouse time-                return $ Create iD beh-            ) <$> eNewPosition--    rec-        -- Destroy poodles that are clicked on-        let eDestructions = filterJust $ snapshotWith (\mev poodles ->-                    case mev of-                        MouseDown clickPos -> listToMaybe-                            [ Destroy iD | (iD, (rect, _)) <- poodles,-                                   clickPos `inside` rect]-                        _ -> Nothing-                ) eMouse poodles--        -- Handle creations and destructions giving a behaviour containing a-        -- list of poodle behaviours.-        poodleBehs <- hold [] =<< collectE (\change poodles ->-                let poodles' = case change of-                        Create iD beh -> (iD, beh) : poodles-                        Destroy iD    -> filter (\(thisID, _) -> iD /= thisID) poodles-                in  (map snd poodles', poodles')-            ) [] (eCreations `merge` eDestructions)--        -- Convert list of behaviours into a behaviour containing a list,-        -- then flatten behaviour within behaviour down to a single behaviour of-        -- poodle sprites.-        poodles <- switch $ foldr (\ba bt -> (:) <$> ba <*> bt) (pure []) <$> poodleBehs--    -- Return poodle sprites without their ids-    return (map snd <$> poodles)--main = do-    rng <- newStdGen-    runGame "Poodle invasion - click the poodles to keep them under control" (poodleGame rng)-

binary file changed (148345 → absent bytes)

@@ -76,11 +76,24 @@         push '3'     assertEqual "filterE1" "23" =<< readIORef outRef +gate1 = TestCase $ do+    (c, pushc) <- sync newEvent+    (pred, pushPred) <- sync $ newBehavior True+    outRef <- newIORef []+    unlisten <- sync $ listen (gate c pred) $ \a -> modifyIORef outRef (++ [a])+    sync $ pushc 'H'+    sync $ pushPred False+    sync $ pushc 'O'+    sync $ pushPred True+    sync $ pushc 'I'+    unlisten+    assertEqual "gate1" "HI" =<< readIORef outRef+ beh1 = TestCase $ do     outRef <- newIORef []     (push, unlisten) <- sync $ do         (beh, push) <- newBehavior "init"-        unlisten <- listenValue beh $ \a -> modifyIORef outRef (++ [a])+        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])         return (push, unlisten)     sync $ do         push "next"@@ -91,7 +104,7 @@     outRef <- newIORef []     (push, unlisten) <- sync $ do         (beh, push) <- newBehavior "init"-        unlisten <- listenValue beh $ \a -> modifyIORef outRef (++ [a])+        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])         return (push, unlisten)     unlisten     sync $ do@@ -102,7 +115,7 @@     outRef <- newIORef []     (push, unlisten) <- sync $ do         (beh, push) <- newBehavior "init"-        unlisten <- listenValue beh $ \a -> modifyIORef outRef (++ [a])+        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])         return (push, unlisten)     sync $ do         push "first"@@ -116,7 +129,7 @@     outRef <- newIORef []     (push, unlisten) <- sync $ do         (beh, push) <- newBehavior "init"-        unlisten <- listenValue beh $ \a -> modifyIORef outRef (++ [a])+        unlisten <- listen (values beh) $ \a -> modifyIORef outRef (++ [a])         push "other"         return (push, unlisten)     sync $ do@@ -139,21 +152,137 @@     unlisten     assertEqual "beh5" ["OTHER", "SECOND"] =<< readIORef outRef -appl1 = TestCase $ do-    (ea, pusha) <- sync newEvent-    ba <- sync $ hold 0 ea-    (eb, pushb) <- sync newEvent-    bb <- sync $ hold 0 eb-    let esum = (+) <$> ba <*> bb+behConstant = TestCase $ do     outRef <- newIORef []-    unlisten <- sync $ listenValue esum $ \sum -> modifyIORef outRef (++ [sum])-    sync $ pusha 5-    sync $ pushb 100-    sync $ pusha 10 >> pushb 200+    unlisten <- sync $ listen (values $ pure 'X') $ \a -> modifyIORef outRef (++ [a])     unlisten-    assertEqual "appl1" [0, 5, 105, 210] =<< readIORef outRef+    assertEqual "behConstant" ['X'] =<< readIORef outRef -appl2 = TestCase $ do  -- variant that uses listen (valueEvent esum) instead of listenValue+valuesThenMap = TestCase $ do+    (b, push) <- sync $ newBehavior 9+    outRef <- newIORef []+    unlisten <- sync $ listen (values . fmap (+100) $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push (2 :: Int)+    sync $ push 7+    unlisten+    assertEqual "valuesThenMap" [109,102,107] =<< readIORef outRef ++-- | This is used for tests where values() produces a single initial value on listen,+-- and then we double that up by causing that single initial event to be repeated.+-- This needs testing separately, because the code must be done carefully to achieve+doubleUp :: Event a -> Event a+doubleUp e = merge e e++valuesTwiceThenMap = TestCase $ do+    (b, push) <- sync $ newBehavior 9+    outRef <- newIORef []+    unlisten <- sync $ listen (doubleUp . values . fmap (+100) $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push (2 :: Int)+    sync $ push 7+    unlisten+    assertEqual "valuesThenMap" [109,109,102,102,107,107] =<< readIORef outRef +    +valuesThenCoalesce = TestCase $ do+    (b, push) <- sync $ newBehavior 9+    outRef <- newIORef []+    unlisten <- sync $ listen (coalesce (\_ x -> x) . values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenCoalesce" [9,2,7] =<< readIORef outRef++valuesTwiceThenCoalesce = TestCase $ do+    (b, push) <- sync $ newBehavior 9+    outRef <- newIORef []+    unlisten <- sync $ listen (coalesce (+) . doubleUp. values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenCoalesce" [18,4,14] =<< readIORef outRef++valuesThenSnapshot = TestCase $ do+    (bi, pushi) <- sync $ newBehavior (9 :: Int)+    (bc, pushc) <- sync $ newBehavior 'a'+    outRef <- newIORef []+    unlisten <- sync $ listen (flip snapshot bc . values $ bi) $ \a -> modifyIORef outRef (++ [a])+    sync $ pushc 'b'+    sync $ pushi 2+    sync $ pushc 'c'+    sync $ pushi 7+    unlisten+    assertEqual "valuesThenSnapshot" ['a','b','c'] =<< readIORef outRef++valuesTwiceThenSnapshot = TestCase $ do+    (bi, pushi) <- sync $ newBehavior (9 :: Int)+    (bc, pushc) <- sync $ newBehavior 'a'+    outRef <- newIORef []+    unlisten <- sync $ listen (flip snapshot bc . doubleUp . values $ bi) $ \a -> modifyIORef outRef (++ [a])+    sync $ pushc 'b'+    sync $ pushi 2+    sync $ pushc 'c'+    sync $ pushi 7+    unlisten+    assertEqual "valuesThenSnapshot" ['a','a','b','b','c','c'] =<< readIORef outRef++valuesThenMerge = TestCase $ do+    (bi, pushi) <- sync $ newBehavior (9 :: Int)+    (bj, pushj) <- sync $ newBehavior (2 :: Int)+    outRef <- newIORef []+    unlisten <- sync $ listen (mergeWith (+) (values bi) (values bj)) $ \a -> modifyIORef outRef (++ [a])+    sync $ pushi 1+    sync $ pushj 4+    unlisten+    assertEqual "valuesThenMerge" [11,1,4] =<< readIORef outRef ++valuesThenFilter = TestCase $ do+    (b, push) <- sync $ newBehavior (9 :: Int)+    outRef <- newIORef []+    unlisten <- sync $ listen (filterE (const True) . values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenFilter" [9,2,7] =<< readIORef outRef++valuesTwiceThenFilter = TestCase $ do+    (b, push) <- sync $ newBehavior (9 :: Int)+    outRef <- newIORef []+    unlisten <- sync $ listen (filterE (const True) . doubleUp . values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenFilter" [9,9,2,2,7,7] =<< readIORef outRef++valuesThenOnce = TestCase $ do+    (b, push) <- sync $ newBehavior (9 :: Int)+    outRef <- newIORef []+    unlisten <- sync $ listen (once . values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenOnce" [9] =<< readIORef outRef++valuesTwiceThenOnce = TestCase $ do+    (b, push) <- sync $ newBehavior (9 :: Int)+    outRef <- newIORef []+    unlisten <- sync $ listen (once . doubleUp . values $ b) $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 7+    unlisten+    assertEqual "valuesThenOnce" [9] =<< readIORef outRef+    +-- | Test values being "executed" before listen. Somewhat redundant since this is+-- Haskell and "values b" is pure.+valuesLateListen = TestCase $ do+    (b, push) <- sync $ newBehavior (9 :: Int)+    outRef <- newIORef []+    let bv = values b+    sync $ push 8+    unlisten <- sync $ listen bv $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    unlisten+    assertEqual "valuesLateListen" [8,2] =<< readIORef outRef++appl1 = TestCase $ do     (ea, pusha) <- sync newEvent     ba <- sync $ hold 0 ea     (eb, pushb) <- sync newEvent@@ -165,7 +294,7 @@     sync $ pushb 100     sync $ pusha 10 >> pushb 200     unlisten-    assertEqual "appl2" [0, 5, 105, 210] =<< readIORef outRef+    assertEqual "appl1" [0, 5, 105, 210] =<< readIORef outRef      snapshot1 = TestCase $ do     (ea, pusha) <- sync newEvent@@ -182,6 +311,17 @@     unlisten     assertEqual "snapshot1" [('A',0),('B',50),('C',50),('D',60)] =<< readIORef outRef +holdIsDelayed = TestCase $ do+    (e, push) <- sync newEvent+    h <- sync $ hold (0 :: Int) e+    let pair = snapshotWith (\a b -> show a ++ " " ++ show b) e h+    outRef <- newIORef []+    unlisten <- sync $ listen pair $ \a -> modifyIORef outRef (++ [a])+    sync $ push 2+    sync $ push 3+    unlisten+    assertEqual "holdIsDelayed" ["2 0", "3 2"] =<< readIORef outRef+ count1 = TestCase $ do     (ea, push) <- sync newEvent     outRef <- newIORef []@@ -200,7 +340,7 @@     unlisten <- sync $ do         ba <- hold 100 ea         sum <- collect (\a s -> (a+s, a+s)) 0 ba-        listenValue sum $ \sum -> modifyIORef outRef (++ [sum])+        listen (values sum) $ \sum -> modifyIORef outRef (++ [sum])     sync $ push 5     sync $ push 7     sync $ push 1@@ -216,7 +356,7 @@         (ba, push) <- newBehavior 100         sum <- collect (\a s -> (a + s, a + s)) 0 ba         push 5-        unlisten <- listenValue sum $ \sum -> modifyIORef outRef (++ [sum])+        unlisten <- listen (values sum) $ \sum -> modifyIORef outRef (++ [sum])         return (unlisten, push)     sync $ push 7     sync $ push 1@@ -276,17 +416,14 @@     assertEqual "switchE1" "ABCdeFGhI" =<< readIORef outRef  switch1 = TestCase $ do-    (ea, pusha) <- sync newEvent-    (eb, pushb) <- sync newEvent-    (esw, pushsw) <- sync newEvent     outRef <- newIORef []-    (ba, bb, unlisten) <- sync $ do-        ba <- hold 'A' ea-        bb <- hold 'a' eb-        bsw <- hold ba esw+    (ba, bb, pusha, pushb, pushsw, unlisten) <- sync $ do+        (ba, pusha) <- newBehavior 'A'+        (bb, pushb) <- newBehavior 'a'+        (bsw, pushsw) <- newBehavior ba         bo <- switch bsw-        unlisten <- listenValue bo $ \o -> modifyIORef outRef (++ [o])-        return (ba, bb, unlisten)+        unlisten <- listen (values bo) $ \o -> modifyIORef outRef (++ [o])+        return (ba, bb, pusha, pushb, pushsw, unlisten)     sync $ pusha 'B' >> pushb 'b'     sync $ pushsw bb >> pusha 'C' >> pushb 'c'     sync $ pusha 'D' >> pushb 'd'@@ -304,8 +441,7 @@     (ea, pusha) <- sync newEvent     outRef <- newIORef []     unlisten <- sync $ do-        oea <- once ea-        listen oea $ \a -> modifyIORef outRef (++ [a])+        listen (once ea) $ \a -> modifyIORef outRef (++ [a])     sync $ pusha 'A'     sync $ pusha 'B'     sync $ pusha 'C'@@ -316,59 +452,13 @@     (ea, pusha) <- sync newEvent     outRef <- newIORef []     unlisten <- sync $ do-        oea <- once ea         pusha 'A'-        listen oea $ \a -> modifyIORef outRef (++ [a])+        listen (once ea) $ \a -> modifyIORef outRef (++ [a])     sync $ pusha 'B'     sync $ pusha 'C'     unlisten     assertEqual "switch1" "A" =<< readIORef outRef -{--crossE1 = TestCase $ do-    outRef <- newIORef []-    (ema :: Event Plain Char, push) <- newEvent-    (ena :: Event N Char) <- sync $ crossE ema-    unlisten <- sync $ listen ena $ \a -> modifyIORef outRef (++ [a])-    sync $ push 'A'-    sync $ push 'M'-    sync $ push 'T'-    -- Flush processing on partition N before unlistening-    sync (return () :: Reactive N ())-    unlisten-    assertEqual "crossE1" "AMT" =<< readIORef outRef--cross1 = TestCase $ do-    outRef <- newIORef []-    (ema :: Event Plain Char, push) <- newEvent-    bma <- sync $ hold 'A' ema-    sync $ push 'B'-    (bna :: Behavior N Char) <- sync $ cross bma-    unlisten <- sync $ listenValue bna $ \a -> modifyIORef outRef (++ [a])-    sync $ push 'C'-    sync $ push 'D'-    sync $ push 'E'-    -- Flush processing on partition N before unlistening-    sync (return () :: Reactive N ())-    unlisten-    assertEqual "cross1" "BCDE" =<< readIORef outRef--cross2 = TestCase $ do-    outRef <- newIORef []-    (ema :: Event Plain Char, push) <- newEvent-    bma <- sync $ hold 'A' ema-    (bna :: Behavior N Char) <- sync $ cross bma-    unlisten <- sync $ listenValue bna $ \a -> modifyIORef outRef (++ [a])-    sync $ push 'B'-    sync $ push 'C'-    sync $ push 'D'-    sync $ push 'E'-    -- Flush processing on partition N before unlistening-    sync (return () :: Reactive N ())-    unlisten-    assertEqual "cross1" "ABCDE" =<< readIORef outRef--}- data Page = Page { unPage :: Reactive (Char, Event Page) }  cycle1 = TestCase $ do@@ -380,7 +470,7 @@             bPair <- hold initPair ePage             let ePage = execute $ unPage <$> switchE (snd <$> bPair)         return (fst <$> bPair)-    unlisten <- sync $ listenValue bo $ \o -> modifyIORef outRef (++ [o])+    unlisten <- sync $ listen (values bo) $ \o -> modifyIORef outRef (++ [o])     sync $ push (Page $ return ('b', ep))     sync $ push (Page $ return ('c', ep))     unlisten@@ -436,9 +526,12 @@     unlisten     assertEqual "coalesce1" [2, 11] =<< readIORef outRef -tests = test [ event1, fmap1, merge1, filterJust1, filterE1, beh1, beh2, beh3, beh4, beh5,-    appl1, appl2, snapshot1, count1, collect1, collect2, collectE1, collectE2, switchE1,-    switch1, once1, once2, {-crossE1, cross1, cross2,-} cycle1, mergeWith1, mergeWith2, mergeWith3,+tests = test [ event1, fmap1, merge1, filterJust1, filterE1, gate1, beh1, beh2, beh3, beh4, beh5,+    behConstant, valuesThenMap, valuesTwiceThenMap, valuesThenCoalesce, valuesTwiceThenCoalesce,+    valuesThenSnapshot, valuesTwiceThenSnapshot, valuesThenMerge, valuesThenFilter,+    valuesTwiceThenFilter, valuesThenOnce, valuesTwiceThenOnce, valuesLateListen,+    holdIsDelayed, appl1, snapshot1, count1, collect1, collect2, collectE1, collectE2, switchE1,+    switch1, once1, once2, cycle1, mergeWith1, mergeWith2, mergeWith3,     coalesce1 ]  main = {-forever $-} runTestTT tests

@@ -1,5 +1,5 @@ name:                sodium-version:             0.4.0.0+version:             0.5.0.0 synopsis:            Sodium Reactive Programming (FRP) System description:            A general purpose Reactive Programming (FRP) system. This is part of a project to@@ -22,7 +22,8 @@   .   Changes: 0.2.0.0 fix some value recursion deadlocks and improve docs;            0.3.0.0 add mergeWith, make cross asynchronous;-           0.4.0.0 API revamp to remove an excess type variable. Parallelism stuff to be rethought.+           0.4.0.0 API revamp to remove an excess type variable. Parallelism stuff to be rethought;+           0.5.0.0 Improved tests cases + add Freecell example, API tweaks. license:             BSD3 license-file:        LICENSE author:              Stephen Blackheath@@ -32,10 +33,81 @@ build-type:          Simple cabal-version:       >=1.8 extra-source-files:  examples/tests.hs-                     examples/poodle/poodle.hs-                     examples/poodle/Engine.hs-                     examples/poodle/Image.hs-                     examples/poodle/poodle.png+                     examples/games/poodle.hs+                     examples/games/freecell.hs+                     examples/games/Engine.hs+                     examples/games/Image.hs+                     examples/games/poodle.png+                     examples/games/cards/b1fh.png+                     examples/games/cards/b1fv.png+                     examples/games/cards/b1pb.png+                     examples/games/cards/b1pl.png+                     examples/games/cards/b1pr.png+                     examples/games/cards/b1pt.png+                     examples/games/cards/b2fh.png+                     examples/games/cards/b2fv.png+                     examples/games/cards/b2pb.png+                     examples/games/cards/b2pl.png+                     examples/games/cards/b2pr.png+                     examples/games/cards/b2pt.png+                     examples/games/cards/c10.png+                     examples/games/cards/c1.png+                     examples/games/cards/c2.png+                     examples/games/cards/c3.png+                     examples/games/cards/c4.png+                     examples/games/cards/c5.png+                     examples/games/cards/c6.png+                     examples/games/cards/c7.png+                     examples/games/cards/c8.png+                     examples/games/cards/c9.png+                     examples/games/cards/cj.png+                     examples/games/cards/ck.png+                     examples/games/cards/cq.png+                     examples/games/cards/d10.png+                     examples/games/cards/d1.png+                     examples/games/cards/d2.png+                     examples/games/cards/d3.png+                     examples/games/cards/d4.png+                     examples/games/cards/d5.png+                     examples/games/cards/d6.png+                     examples/games/cards/d7.png+                     examples/games/cards/d8.png+                     examples/games/cards/d9.png+                     examples/games/cards/dj.png+                     examples/games/cards/dk.png+                     examples/games/cards/dq.png+                     examples/games/cards/ec.png+                     examples/games/cards/empty-space.png+                     examples/games/cards/h10.png+                     examples/games/cards/h1.png+                     examples/games/cards/h2.png+                     examples/games/cards/h3.png+                     examples/games/cards/h4.png+                     examples/games/cards/h5.png+                     examples/games/cards/h6.png+                     examples/games/cards/h7.png+                     examples/games/cards/h8.png+                     examples/games/cards/h9.png+                     examples/games/cards/hj.png+                     examples/games/cards/hk.png+                     examples/games/cards/hq.png+                     examples/games/cards/index.html+                     examples/games/cards/jb.png+                     examples/games/cards/jr.png+                     examples/games/cards/licence.txt+                     examples/games/cards/s10.png+                     examples/games/cards/s1.png+                     examples/games/cards/s2.png+                     examples/games/cards/s3.png+                     examples/games/cards/s4.png+                     examples/games/cards/s5.png+                     examples/games/cards/s6.png+                     examples/games/cards/s7.png+                     examples/games/cards/s8.png+                     examples/games/cards/s9.png+                     examples/games/cards/sj.png+                     examples/games/cards/sk.png+                     examples/games/cards/sq.png  source-repository head   type:     git

@@ -38,7 +38,6 @@         newEvent,         newBehavior,         listen,-        listenValue,         -- * FRP core language         Event,         Behavior,@@ -66,7 +65,7 @@         accum,         countE,         count,-        once,+        once     ) where  import FRP.Sodium.Plain

@@ -32,6 +32,8 @@     newEvent      :: Reactive r (Event r a, a -> Reactive r ())     -- | Listen for firings of this event. The returned @IO ()@ is an IO action     -- that unregisters the listener. This is the observer pattern.+    --+    -- To listen to a 'Behavior' use @listen (values b) handler@     listen        :: Event r a -> (a -> IO ()) -> Reactive r (IO ())     -- | An event that never fires.     never         :: Event r a@@ -39,76 +41,75 @@     --     -- In the case where two event occurrences are simultaneous (i.e. both     -- within the same transaction), both will be delivered in the same-    -- transaction.-    ---    -- The order is not defined, because simultaneous events should be considered-    -- to be order-agnostic.+    -- transaction. If the event firings are ordered for some reason, then+    -- their ordering is retained. In many common cases the ordering will+    -- be undefined.     merge         :: Event r a -> Event r a -> Event r a     -- | Unwrap Just values, and discard event occurrences with Nothing values.     filterJust    :: Event r (Maybe a) -> Event r a-    -- | Create a behaviour with the specified initial value, that gets updated-    -- by the values coming through the event. The \'current value\' of the behaviour+    -- | Create a behavior with the specified initial value, that gets updated+    -- by the values coming through the event. The \'current value\' of the behavior     -- is notionally the value as it was 'at the start of the transaction'.     -- That is, state updates caused by event firings get processed at the end of     -- the transaction.     hold          :: a -> Event r a -> Reactive r (Behavior r a)-    -- | An event that gives the updates for the behaviour. It doesn't do any equality+    -- | An event that gives the updates for the behavior. It doesn't do any equality     -- comparison as the name might imply.     changes       :: Behavior r a -> Event r a-    -- | An event that is guaranteed to fires once when you listen to it, giving-    -- the current value of the behaviour, and thereafter behaves like 'changes',-    -- firing for each update to the behaviour's value.+    -- | An event that is guaranteed to fire once when you listen to it, giving+    -- the current value of the behavior, and thereafter behaves like 'changes',+    -- firing for each update to the behavior's value.     values        :: Behavior r a -> Event r a-    -- | Sample the behaviour at the time of the event firing. Note that the 'current value'-    -- of the behaviour that's sampled is the value as at the start of the transaction+    -- | Sample the behavior at the time of the event firing. Note that the 'current value'+    -- of the behavior that's sampled is the value as at the start of the transaction     -- before any state changes of the current transaction are applied through 'hold's.     snapshotWith  :: (a -> b -> c) -> Event r a -> Behavior r b -> Event r c-    -- | Unwrap an event inside a behaviour to give a time-varying event implementation.+    -- | Unwrap an event inside a behavior to give a time-varying event implementation.     switchE       :: Behavior r (Event r a) -> Event r a-    -- | Unwrap a behaviour inside another behaviour to give a time-varying behaviour implementation.+    -- | Unwrap a behavior inside another behavior to give a time-varying behavior implementation.     switch        :: Behavior r (Behavior r a) -> Reactive r (Behavior r a)     -- | Execute the specified 'Reactive' action inside an event.     execute       :: Event r (Reactive r a) -> Event r a-    -- | Obtain the current value of a behaviour.+    -- | Obtain the current value of a behavior.     sample        :: Behavior r a -> Reactive r a     -- | If there's more than one firing in a single transaction, combine them into     -- one using the specified combining function.+    --+    -- If the event firings are ordered, then the first will appear at the left+    -- input of the combining function. In most common cases it's best not to+    -- make any assumptions about the ordering, and the combining function would+    -- ideally be commutative.     coalesce      :: (a -> a -> a) -> Event r a -> Event r a+    -- | Throw away all event occurrences except for the first one.+    once          :: Context r => Event r a -> Event r a  newBehavior :: forall r a . Context r =>-               a  -- ^ Initial behaviour value+               a  -- ^ Initial behavior value             -> Reactive r (Behavior r a, a -> Reactive r ()) newBehavior initA = do     (ev, push) <- newEvent     beh <- hold initA ev     return (beh, push) -listenValue   :: Context r => Behavior r a -> (a -> IO ()) -> Reactive r (IO ())-listenValue b handler = listen (values b) handler- -- | Merge two streams of events of the same type, combining simultaneous -- event occurrences. -- -- In the case where multiple event occurrences are simultaneous (i.e. all--- within the same transaction), they are combined using the supplied--- function. The output event is guaranteed not to have more than one--- event occurrence per transaction.------ The combine function should be commutative, because simultaneous events--- should be considered to be order-agnostic.+-- within the same transaction), they are combined using the same logic as+-- 'coalesce'. mergeWith :: Context r => (a -> a -> a) -> Event r a -> Event r a -> Event r a mergeWith f ea eb = coalesce f $ merge ea eb --- | Only keep event occurrences for which the predicate is true.+-- | Only keep event occurrences for which the predicate returns true. filterE :: Context r => (a -> Bool) -> Event r a -> Event r a filterE pred = filterJust . ((\a -> if pred a then Just a else Nothing) <$>) --- | Variant of snapshotWith that throws away the event's value and captures the behaviour's.+-- | Variant of snapshotWith that throws away the event's value and captures the behavior's. snapshot :: Context r => Event r a -> Behavior r b -> Event r b snapshot = snapshotWith (flip const) --- | Let event occurrences through only when the behaviour's value is True.--- Note that the behaviour's value is as it was at the start of the transaction,+-- | Let event occurrences through only when the behavior's value is True.+-- Note that the behavior's value is as it was at the start of the transaction, -- that is, no state changes from the current transaction are taken into account. gate :: Context r => Event r a -> Behavior r Bool -> Event r a gate ea = filterJust . snapshotWith (\a b -> if b then Just a else Nothing) ea@@ -124,7 +125,7 @@             es = snd <$> ebs     return eb --- | Transform a behaviour with a generalized state loop (a mealy machine). The function+-- | Transform a behavior with a generalized state loop (a mealy machine). The function -- is passed the input and the old state and returns the new state and output value. collect :: Context r => (a -> s -> (b, s)) -> s -> Behavior r a -> Reactive r (Behavior r b) collect f zs bea = do@@ -155,11 +156,7 @@ countE :: Context r => Event r a -> Reactive r (Event r Int) countE = accumE (+) 0 . (const 1 <$>) --- | Count event occurrences, giving a behaviour that starts with 0 before the first occurrence.+-- | Count event occurrences, giving a behavior that starts with 0 before the first occurrence. count :: Context r => Event r a -> Reactive r (Behavior r Int) count = hold 0 <=< countE---- | Throw away all event occurrences except for the first one.-once :: Context r => Event r a -> Reactive r (Event r a)-once ea = filterJust <$> collectE (\a active -> (if active then Just a else Nothing, False)) True ea 

@@ -70,9 +70,9 @@         }      data Behavior Plain a = Behavior {-            -- | Internal: Extract the underlyingEvent event for this behaviour.+            -- | Internal: Extract the underlyingEvent event for this behavior.             underlyingEvent :: Event a,-            -- | Obtain the current value of a behaviour.+            -- | Obtain the current value of a behavior.             behSample       :: Reactive a         }     sync = sync@@ -91,6 +91,7 @@     execute = execute     sample = sample     coalesce = coalesce+    once = once  -- | Execute the specified 'Reactive' within a new transaction, blocking the caller -- until all resulting processing is complete and all callbacks have been called.@@ -136,6 +137,8 @@  -- | Listen for firings of this event. The returned @IO ()@ is an IO action -- that unregisters the listener. This is the observer pattern.+--+-- To listen to a 'Behavior' use @listen (values b) handler@ listen        :: Event a -> (a -> IO ()) -> Reactive (IO ()) listen ev handle = listenTrans ev (ioReactive . handle) @@ -150,10 +153,9 @@ -- -- In the case where two event occurrences are simultaneous (i.e. both -- within the same transaction), both will be delivered in the same--- transaction.------ The order is not defined, because simultaneous events should be considered--- to be order-agnostic.+-- transaction. If the event firings are ordered for some reason, then+-- their ordering is retained. In many common cases the ordering will+-- be undefined. merge         :: Event a -> Event a -> Event a merge ea eb = Event gl cacheRef   where@@ -179,8 +181,8 @@             Nothing -> return ()         addCleanup unlistener l' --- | Create a behaviour with the specified initial value, that gets updated--- by the values coming through the event. The \'current value\' of the behaviour+-- | Create a behavior with the specified initial value, that gets updated+-- by the values coming through the event. The \'current value\' of the behavior -- is notionally the value as it was 'at the start of the transaction'. -- That is, state updates caused by event firings get processed at the end of -- the transaction.@@ -190,7 +192,7 @@     unlistener <- unlistenize $ listenTrans ea $ \a -> do         bs <- ioReactive $ readIORef bsRef         ioReactive $ writeIORef bsRef $ bs { bsUpdate = Just a }-        when (isNothing (bsUpdate bs)) $ onFinal $ do+        when (isNothing (bsUpdate bs)) $ scheduleLast $ do             bs <- readIORef bsRef             let newCurrent = fromJust (bsUpdate bs)                 bs' = newCurrent `seq` BehaviorState newCurrent Nothing@@ -205,19 +207,19 @@             }     return beh --- | An event that gives the updates for the behaviour. It doesn't do any equality+-- | An event that gives the updates for the behavior. It doesn't do any equality -- comparison as the name might imply. changes       :: Behavior a -> Event a changes = underlyingEvent  -- | An event that is guaranteed to fires once when you listen to it, giving--- the current value of the behaviour, and thereafter behaves like 'changes',--- firing for each update to the behaviour's value.+-- the current value of the behavior, and thereafter behaves like 'changes',+-- firing for each update to the behavior's value. values        :: Behavior a -> Event a values = eventify . linkedListenValue --- | Sample the behaviour at the time of the event firing. Note that the 'current value'--- of the behaviour that's sampled is the value as at the start of the transaction+-- | Sample the behavior at the time of the event firing. Note that the 'current value'+-- of the behavior that's sampled is the value as at the start of the transaction -- before any state changes of the current transaction are applied through 'hold's. snapshotWith  :: (a -> b -> c) -> Event a -> Behavior b -> Event c snapshotWith f ea bb = Event gl cacheRef@@ -230,7 +232,7 @@             push (f a b)         addCleanup unlistener l --- | Unwrap an event inside a behaviour to give a time-varying event implementation.+-- | Unwrap an event inside a behavior to give a time-varying event implementation. switchE       :: Behavior (Event a) -> Event a switchE bea = Event gl cacheRef   where@@ -252,7 +254,7 @@             ioReactive $ modifyIORef unlistensRef (M.insert iD unlisten2)         addCleanup unlistener1 l --- | Unwrap a behaviour inside another behaviour to give a time-varying behaviour implementation.+-- | Unwrap a behavior inside another behavior to give a time-varying behavior implementation. switch        :: Behavior (Behavior a) -> Reactive (Behavior a) switch bba = do     ba <- sample bba@@ -284,12 +286,17 @@             runListen l (Just nodeRef) $ \action -> action >>= push         addCleanup unlistener l' --- | Obtain the current value of a behaviour.+-- | Obtain the current value of a behavior. sample        :: Behavior a -> Reactive a sample = behSample  -- | If there's more than one firing in a single transaction, combine them into -- one using the specified combining function.+--+-- If the event firings are ordered, then the first will appear at the left+-- input of the combining function. In most common cases it's best not to+-- make any assumptions about the ordering, and the combining function would+-- ideally be commutative. coalesce      :: (a -> a -> a) -> Event a -> Event a coalesce combine e = Event gl cacheRef   where@@ -303,19 +310,36 @@             ioReactive $ modifyIORef outRef $ \ma -> Just $ case ma of                 Just a0 -> a0 `combine` a                 Nothing -> a-            when first $ scheduleLast (Just nodeRef) $ do+            when first $ schedulePrioritized (Just nodeRef) $ do                 Just out <- ioReactive $ readIORef outRef                 ioReactive $ writeIORef outRef Nothing                 push out         addCleanup unlistener l -newBehavior :: a  -- ^ Initial behaviour value+-- | Throw away all event occurrences except for the first one.+once :: Event a -> Event a+once e = Event gl cacheRef+  where+    cacheRef = unsafePerformIO $ newIORef Nothing+    gl = do+        l1 <- getListen e+        (l, push, nodeRef) <- ioReactive newEventImpl+        aliveRef <- ioReactive $ newIORef True+        unlistener <- unlistenize $ do+            rec+                unlisten <- runListen l1 (Just nodeRef) $ \a -> do+                    alive <- ioReactive $ readIORef aliveRef+                    when alive $ do+                        ioReactive $ writeIORef aliveRef False+                        scheduleLast unlisten+                        push a+            return unlisten+        addCleanup unlistener l++newBehavior :: a  -- ^ Initial behavior value             -> Reactive (Behavior a, a -> Reactive ()) newBehavior = R.newBehavior -listenValue   :: Behavior a -> (a -> IO ()) -> Reactive (IO ())-listenValue = R.listenValue- -- | Merge two streams of events of the same type, combining simultaneous -- event occurrences. --@@ -333,12 +357,12 @@ filterE :: (a -> Bool) -> Event a -> Event a filterE = R.filterE --- | Variant of 'snapshotWith' that throws away the event's value and captures the behaviour's.+-- | Variant of 'snapshotWith' that throws away the event's value and captures the behavior's. snapshot :: Event a -> Behavior b -> Event b snapshot = R.snapshot --- | Let event occurrences through only when the behaviour's value is True.--- Note that the behaviour's value is as it was at the start of the transaction,+-- | Let event occurrences through only when the behavior's value is True.+-- Note that the behavior's value is as it was at the start of the transaction, -- that is, no state changes from the current transaction are taken into account. gate :: Event a -> Behavior Bool -> Event a gate = R.gate@@ -348,7 +372,7 @@ collectE :: (a -> s -> (b, s)) -> s -> Event a -> Reactive (Event b) collectE = R.collectE --- | Transform a behaviour with a generalized state loop (a mealy machine). The function+-- | Transform a behavior with a generalized state loop (a mealy machine). The function -- is passed the input and the old state and returns the new state and output value. collect :: (a -> s -> (b, s)) -> s -> Behavior a -> Reactive (Behavior b) collect = R.collect@@ -365,14 +389,10 @@ countE :: Event a -> Reactive (Event Int) countE = R.countE --- | Count event occurrences, giving a behaviour that starts with 0 before the first occurrence.+-- | Count event occurrences, giving a behavior that starts with 0 before the first occurrence. count :: Event a -> Reactive (Behavior Int) count = R.count --- | Throw away all event occurrences except for the first one.-once :: Event a -> Reactive (Event a)-once = R.once- type ID = Int64  data ReactiveState = ReactiveState {@@ -411,11 +431,11 @@     }  -- | Queue the specified atomic to run at the end of the priority 1 queue-schedulePrioritized :: Reactive () -> Reactive ()-schedulePrioritized task = Reactive $ modify $ \as -> as { asQueue1 = asQueue1 as |> task }+scheduleEarly :: Reactive () -> Reactive ()+scheduleEarly task = Reactive $ modify $ \as -> as { asQueue1 = asQueue1 as |> task } -onFinal :: IO () -> Reactive ()-onFinal task = Reactive $ modify $ \as -> as { asFinal = asFinal as >> task }+scheduleLast :: IO () -> Reactive ()+scheduleLast task = Reactive $ modify $ \as -> as { asFinal = asFinal as >> task }  data Listen a = Listen { runListen_ :: Maybe (IORef Node) -> (a -> Reactive ()) -> Reactive (IO ()) } @@ -530,7 +550,7 @@             ob <- ioReactive $ modifyMVar mvObs $ \ob -> return $                 (ob { obFirings = a : obFirings ob }, ob)             -- If this is the first firing...-            when (null (obFirings ob)) $ onFinal $ do+            when (null (obFirings ob)) $ scheduleLast $ do                 modifyMVar_ mvObs $ \ob -> return $ ob { obFirings = [] }             let seqa = seq a a             mapM_ ($ seqa) (M.elems . obListeners $ ob)@@ -589,12 +609,12 @@  newtype Unlistener = Unlistener (MVar (Maybe (IO ()))) --- | Listen to an input event/behaviour and return an 'Unlistener' that can be+-- | Listen to an input event/behavior and return an 'Unlistener' that can be -- attached to an output event using 'addCleanup'. unlistenize :: Reactive (IO ()) -> Reactive Unlistener unlistenize doListen = do     unlistener@(Unlistener ref) <- newUnlistener-    schedulePrioritized $ do+    scheduleEarly $ do         mOldUnlisten <- ioReactive $ takeMVar ref         case mOldUnlisten of             Just _ -> do@@ -614,7 +634,7 @@     fromMaybe (return ()) mUnlisten     putMVar ref Nothing --- | Listen to the value of this behaviour with an initial callback giving+-- | Listen to the value of this behavior with an initial callback giving -- the current value. Can get multiple values per transaction, the last of -- which is considered valid. You would normally want to use 'listenValue', -- which removes the extra unwanted values.@@ -625,10 +645,10 @@     linkedListen (underlyingEvent ba) mNodeRef handle  -- | Queue the specified atomic to run at the end of the priority 2 queue-scheduleLast :: Maybe (IORef Node)+schedulePrioritized :: Maybe (IORef Node)                   -> Reactive ()                   -> Reactive ()-scheduleLast mNodeRef task = do+schedulePrioritized mNodeRef task = do     mNode <- case mNodeRef of         Just nodeRef -> Just <$> ioReactive (readIORef nodeRef)         Nothing -> pure Nothing@@ -648,12 +668,12 @@     listen mNodeRef $ \a -> do         ma <- ioReactive $ readIORef aRef         ioReactive $ writeIORef aRef (Just a)-        when (isNothing ma) $ scheduleLast mNodeRef $ do+        when (isNothing ma) $ schedulePrioritized mNodeRef $ do             Just a <- ioReactive $ readIORef aRef             ioReactive $ writeIORef aRef Nothing             handle a --- | Listen to the value of this behaviour with a guaranteed initial callback+-- | Listen to the value of this behavior with a guaranteed initial callback -- giving the current value, followed by callbacks for any updates.  linkedListenValue :: Behavior a -> Maybe (IORef Node) -> (a -> Reactive ()) -> Reactive (IO ()) linkedListenValue ba = tidy (listenValueRaw ba)@@ -720,11 +740,11 @@     unlisten <- listen epa $ async . push     return $ finalizeEvent ev unlisten --- | Cross the specified behaviour over to a different partition.+-- | Cross the specified behavior over to a different partition. cross :: (Typeable p, Typeable q) => Behavior a -> Reactive (Behavior q a) cross bpa = do     a <- sample bpa     ea <- crossE (underlyingEvent bpa)-    ioReactive $ sync $ hold a ea+    ioReactive $ sync $ 3 a ea -}