[GUI] Re: fruit demo

[Antony Courtney]

This is a multi-part message in MIME format.
--------------070607090600000707000600
Content-Type: text/plain; charset=us-ascii; format=flowed
Content-Transfer-Encoding: 7bit

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

--------------070607090600000707000600
Content-Type: text/plain;
 name="BallTests.as"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
 filename="BallTests.as"

--
-- 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,())



--------------070607090600000707000600--