Hi Daan, Daan Leijen wrote:
Hi Anthony,
Very interesting to see your program -- it is neat how one can separate the model from the interface! (allthough the wiring still seems a bit convoluted.)
Hmmm. Can you expand on why you think the wiring is a bit convoluted? Is it the syntax that you find difficult, or the conceptual framework of signal functions?
I don't know if you have seen Koen Claessens bouncing balls demo, but I would be quite interested to see how that would look in Fruit (I think that especially the behaviour of the balls can be modelled nicer in Fruit). See http://www.cs.chalmers.se/Cs/Grundutb/Kurser/afp/yahu.html for the demo.
I hadn't seen Koen's demo, but I had already done something quite similar. If you think the previous code looked convoluted, you ain't seen nothin' yet.... :-) The attached file contains a few increasingly sophisticated versions of the bouncing balls demo. Most versions use the pSwitch family of combinators to maintain a dynamic collection of bouncing balls. The user can spawn a new ball at any location using the mouse, and the balls bounce off of each other as well as off of the walls. One version also includes self-termination, where each ball only "lives" for 5 seconds after it is spawned. The pSwitch combinators are described in the paper: Henrik Nilsson, Antony Courtney and John Peterson, Functional Reactive Programming, Continued. In Proceedings of the Haskell Workshop, September, 2002. which is available here: http://apocalypse.org/~antony/pubs/genuinely-functional-guis.pdf regards, -antony -- Antony Courtney Grad. Student, Dept. of Computer Science, Yale University antony@apocalypse.org http://www.apocalypse.org/pub/u/antony -- -- BallTests.as -- animated bouncing balls to illustrate the basics -- of using pSwitch to switch over dynamic collections. -- module BallTests where import AFRP import Haven import GUI import FMUI -- hmmm. should probably put this in HavenCoreUtils: rpath :: Point -> Double -> Double -> Path rpath pt w h = outline $ rectangle pt w h -- walls: vWalls :: Path vWalls = rpath (point 0 0) 10 300 <++> rpath (point 290 0) 10 300 hWalls :: Path hWalls = rpath (point 0 290) 300 10 <++> rpath (point 0 0) 300 10 wallPath :: Path wallPath = hWalls <++> vWalls wallPic :: Picture wallPic = withColor red $ picFill wallPath wallGUI :: GUI () () wallGUI = constant (wallPic,()) ballShape :: Path ballShape = outline (circle origin 25) ballPic :: Picture ballPic = withColor green (picFill ballShape) -- A simple ball bouncing inside the walls: simpleBall :: Point -> Double -> SF () (Path) simpleBall pt0 vel = proc _ -> do rec xi <- integral -< xvel yi <- integral -< yvel let xpos = (pointX pt0) + xi let ypos = (pointY pt0) + yi let ball = translate (vector xpos ypos) %$ ballShape let bbounds = bounds ball xbounce <- edge -< intersectsRect vWalls bbounds ybounce <- edge -< intersectsRect hWalls bbounds xvel <- accumHold vel -< xbounce `tag` negate yvel <- accumHold vel -< ybounce `tag` negate returnA -< ball simpleBallGUI :: Point -> Double -> GUI () Path simpleBallGUI pt0 vel = proc _ -> do b <- simpleBall pt0 vel -< () let bpic = withColor green $ picFill b returnA -< (bpic,b) sbGUI :: GUI () () sbGUI = guiDropIO $ simpleBallGUI (point 75 120) 120 -- just sbTest in front of walls: dynTest0 :: GUI () () dynTest0 = let wallGUI :: GUI () () wallGUI = constGUI wallPic in guiDropIO $ sbGUI `overGUI` wallGUI -- first: let's just try a version of dynTest0 which is a singleton -- collection used in rpSwitch: dynTest1 :: GUI () () dynTest1 = proc (gin,_) -> do neChild <- never -< () pps <- rpSwitchB [dynTest0] -< ((gin,()),neChild) let pic = foldr (\ (p,_) bg -> p <++> bg) picEmpty pps returnA -< (pic,()) -- now let's try to spawn a ball under the mouse on lbp: spawnTest1 :: GUI () () spawnTest1 = proc (gin,_) -> do lbPress <- ginLbp -< gin mouse <- ginMouse -< gin let forkE = lbPress `tag` ((guiDropIO $ simpleBallGUI mouse 120):) pps <- rpSwitchB [dynTest0] -< ((gin,()),forkE) let pic = foldr (\ (p,_) bg -> p <++> bg) wallPic pps returnA -< (pic,()) -- a variation on simpleBallGUI that terminates after 5 seconds: -- -- could make a more general-purpose wrapper that would -- terminate ANY signal function after N seconds... -- termBallGUI :: Point -> Double -> GUI a (Event ()) termBallGUI pt0 vel = proc (gin,_) -> do t <- time -< () done <- edge -< (t > 5) (bpic,_) <- simpleBallGUI pt0 vel -< (gin,()) returnA -< (bpic,done) -- now let's try a version of spawnTest that allows for self-termination: -- We use pSwitch here. Note, however, that a switching Event may occur -- either because we are adding a new ball to the collection, or because -- some of the balls have terminated. We account for this by using the -- type (Maybe (GUI () Event ()),[Bool]) on the event occurence. The -- first component of the pair is (Just b) if we spawn a new ball b, -- and the second component is the indices of balls to remove from -- the collection. -- compute spawn or kill events for spawnTest2: spawnOrKill :: SF ((GUIInput,()),[(Picture,Event ())]) (Event ((Maybe (GUI () (Event ()))),[Bool])) spawnOrKill = proc ((gin,_),pes) -> do lbPress <- ginLbp -< gin mouse <- ginMouse -< gin let spawnE = lbPress `tag` (Just (termBallGUI mouse 120),repeat False) let termEs = map snd pes let killE = (mergeEvents termEs) `tag` (Nothing,map isEvent termEs) returnA -< mergeBy (\ (x,_) (_,y) -> (x,y)) spawnE killE -- A simple auxiliary filtering function: dropSome :: [a] -> [Bool] -> [a] dropSome as bs = [ a | (a,b) <- zip as bs, not b ] -- given the current World (a list of TermBallGUI's), and a -- (spawn,kill) pair, compute a new World: nextWorld :: [GUI () (Event ())] -> (Maybe (GUI () (Event ())),[Bool]) -> SF (GUIInput,()) [(Picture,Event ())] nextWorld world (Nothing,termEs) = let world' = dropSome world termEs in pSwitchB world' spawnOrKill nextWorld nextWorld world (Just b,termEs) = let world' = b:(dropSome world termEs) in pSwitchB world' spawnOrKill nextWorld spawnTest2 :: GUI () () spawnTest2 = let world0 = [termBallGUI (point 100 100) 120] in proc (gin,_) -> do pes <- pSwitchB world0 spawnOrKill nextWorld -< (gin,()) let pic = foldr (\ (p,_) bg -> p <++> bg) wallPic pes returnA -< (pic,()) -- A ball that changes direction whenever it hits another ball: -- like simpleBallGUI, but takes an input event whose occurence -- indicates a collision: hitBall :: Point -> Double -> SF (Event ()) (Path) hitBall pt0 vel = proc hitE -> do rec xi <- integral -< xvel yi <- integral -< yvel let xpos = (pointX pt0) + xi let ypos = (pointY pt0) + yi let ball = translate (vector xpos ypos) %$ ballShape let bbounds = bounds ball xHitWallE <- edge -< intersectsRect vWalls bbounds yHitWallE <- edge -< intersectsRect hWalls bbounds let xbounce = xHitWallE `lMerge` hitE let ybounce = yHitWallE `lMerge` hitE xvel <- accumHold vel -< xbounce `tag` negate yvel <- accumHold vel -< ybounce `tag` negate returnA -< ball hitBallGUI :: Point -> Double -> GUI (Event ()) Path hitBallGUI pt0 vel = proc (_,hitE) -> do b <- hitBall pt0 vel -< hitE let bpic = withColor green $ picFill b returnA -< (bpic,b) termHitBallGUI :: Point -> Double -> GUI (Event ()) (Path,Event ()) termHitBallGUI pt0 vel = proc (gin,hitE) -> do t <- time -< () done <- edge -< (t > 5) (pic,path) <- hitBallGUI pt0 vel -< (gin,hitE) returnA -< (pic,(path,done)) -- A WorldBall is a Ball that observes a World. However, we'll arrange -- it so that every ball sees all other balls but itself. worldBallGUI :: Point -> Double -> GUI [Path] Path worldBallGUI pt0 vel = proc (gin,others) -> do rec (bpic,b) <- hitBallGUI pt0 vel -< (gin,hitE) let bbounds = bounds b let touches = any (\ p -> intersectsRect p bbounds) others hitE <- edge -< touches returnA -< (bpic,b) -- Given a World of length n, construct n localized perceptions of the -- world, in which each member does not see himself. locPercept :: [a] -> [[a]] locPercept world = map (\i -> dropNth i world) [0..(length world)-1] dropNth :: Int -> [a] -> [a] dropNth n as = let (pre,suf) = splitAt n as in pre ++ (drop 1 suf) -- An implementation of the bouncing balls where each ball bounces off the -- walls and off all other balls. Note that each balls has a localized -- perception of the world in which it observes all other balls but does -- not see itself. -- other balls but itself. -- -- The implementation here is like spawnTest1, but using rpSwitchZ -- instead of rpSwitchB: spawnTest3 :: GUI () () spawnTest3 = proc (gin,_) -> do rec lbPress <- ginLbp -< gin mouse <- ginMouse -< gin let forkE = lbPress `tag` ((worldBallGUI mouse 120):) pps <- rpSwitchZ [worldBallGUI (point 100 100) 120] -< (zip (repeat gin) locWorlds, forkE) let locWorlds = locPercept (map snd pps) let pic = foldr (\ (p,_) bg -> p <++> bg) wallPic pps returnA -< (pic,())