Binary files afrp-0.4.orig/.DS_Store and afrp-0.4/.DS_Store differ diff -crN afrp-0.4.orig/Setup.hs afrp-0.4/Setup.hs *** afrp-0.4.orig/Setup.hs 1970-01-01 09:00:00.000000000 +0900 --- afrp-0.4/Setup.hs 2005-02-27 10:15:53.000000000 +0900 *************** *** 0 **** --- 1,8 ---- + + module Main (main) where + + import Distribution.Simple + + main :: IO () + main = defaultMain + diff -crN afrp-0.4.orig/afpr.cabal afrp-0.4/afpr.cabal *** afrp-0.4.orig/afpr.cabal 1970-01-01 09:00:00.000000000 +0900 --- afrp-0.4/afpr.cabal 2005-07-19 12:37:07.000000000 +0900 *************** *** 0 **** --- 1,35 ---- + Name: afrp + Version: 0.4 + License: BSD3 + License-File: LICENSE + Copyright: Henrik Nilsson, Antony Courtney and Yale University, (c) 2003 + Author: Antony Courtney, Paul Hudak, Henrik Nilsson, John Peterson + Maintainer: Antony Courtney , Paul Hudak , Henrik Nilsson , John Peterson + Stability: provisional + Homepage: http://www.haskell.org/yampa/ + Synopsis: Arrowised Functional Reactive Programming + Description: + Category: Arrow + Tested-With: GHC + hs-source-dir: src + ghc-options: -fglasgow-exts + Build-Depends: base, lang, haskell98 + Exposed-modules: + AFRP, + AFRPAffineSpace, + AFRPDiagnostics, + AFRPEvent, + AFRPForceable, + AFRPGeometry, + AFRPInternals, + AFRPMiscellany, + AFRPMergeableRecord, + AFRPPoint2, + AFRPPoint3, + AFRPTask, + AFRPUtilities, + AFRPVector2, + AFRPVector3, + AFRPVectorSpace + + Binary files afrp-0.4.orig/examples/.DS_Store and afrp-0.4/examples/.DS_Store differ Binary files afrp-0.4.orig/examples/SpaceInvaders/.DS_Store and afrp-0.4/examples/SpaceInvaders/.DS_Store differ Binary files afrp-0.4.orig/examples/SpaceInvaders/src/.DS_Store and afrp-0.4/examples/SpaceInvaders/src/.DS_Store differ diff -crN afrp-0.4.orig/examples/SpaceInvaders/src/Animate.hs afrp-0.4/examples/SpaceInvaders/src/Animate.hs *** afrp-0.4.orig/examples/SpaceInvaders/src/Animate.hs 2004-03-23 07:48:55.000000000 +0900 --- afrp-0.4/examples/SpaceInvaders/src/Animate.hs 2005-07-31 10:36:46.000000000 +0900 *************** *** 40,46 **** -- getSysVar, getProcessTimes, elapsedTime) -- import Concurrent (yield) import IOExts (IORef, newIORef, readIORef, writeIORef) ! import qualified Graphics.HGL.Utils as HGL import AFRP import AFRPInternals -- Breaking the Event abstraction barrier here! --- 40,46 ---- -- getSysVar, getProcessTimes, elapsedTime) -- import Concurrent (yield) import IOExts (IORef, newIORef, readIORef, writeIORef) ! import qualified Graphics.HGL as HGL import AFRP import AFRPInternals -- Breaking the Event abstraction barrier here! diff -crN afrp-0.4.orig/examples/SpaceInvaders/src/Colors.hs afrp-0.4/examples/SpaceInvaders/src/Colors.hs *** afrp-0.4.orig/examples/SpaceInvaders/src/Colors.hs 2004-03-23 07:48:55.000000000 +0900 --- afrp-0.4/examples/SpaceInvaders/src/Colors.hs 2005-07-30 18:10:50.000000000 +0900 *************** *** 14,20 **** module Colors (Color(..), RGB, colorTable) where import Array ! import Graphics.HGL.Utils (RGB(..)) ------------------------------------------------------------------------------ --- 14,20 ---- module Colors (Color(..), RGB, colorTable) where import Array ! import Graphics.HGL.Draw.Text (RGB(..)) ------------------------------------------------------------------------------ diff -crN afrp-0.4.orig/examples/SpaceInvaders/src/Main.hs afrp-0.4/examples/SpaceInvaders/src/Main.hs *** afrp-0.4.orig/examples/SpaceInvaders/src/Main.hs 1970-01-01 09:00:00.000000000 +0900 --- afrp-0.4/examples/SpaceInvaders/src/Main.hs 2005-07-31 10:39:33.000000000 +0900 *************** *** 0 **** --- 1,207 ---- + {- $Id: Main.as,v 1.3 2003/11/13 20:11:00 henrik Exp $ + ****************************************************************************** + * I N V A D E R S * + * * + * Module: Main * + * Purpose: Main module. * + * Author: Henrik Nilsson * + * * + * Copyright (c) Yale University, 2003 * + * * + ****************************************************************************** + -} + + module Main where + + import Random + + import Maybe (isJust) + import Array + + import AFRP + import AFRPInternals (Event(..)) + import AFRPGeometry + import AFRPUtilities + import qualified Graphics.HGL as HGL + + -- Temporary, just to make sure all modules compile. + import Animate + import ColorBindings + import Colors + import Command + import Diagnostics + import IdentityList + import Object + import ObjectBehavior + import Parser + import PhysicalDimensions + import RenderLandscape + import RenderObject + import WorldGeometry + + type Score = Int + + main = do + g <- newStdGen + animate 20 "S P A C E I N V A D E R S" worldSizeX worldSizeY + (\(score, ooss) -> + renderScore score + `HGL.overGraphic` renderObjects ooss + `HGL.overGraphic` landscape) + (\_ -> []) + (parseWinInput >>> restartingGame g) + + + -- Change name to "game"? What's now "game" would become "gameRound". + -- What about "game'"? + restartingGame :: RandomGen g => g -> SF GameInput (Int, [ObsObjState]) + restartingGame g = rgAux g nAliens0 vydAlien0 0 + where + nAliens0 = 2 + vydAlien0 = -10 + + rgAux g nAliens vydAlien score = + switch (game g' nAliens vydAlien score) $ \status -> + case status of + Left score' -> rgAux g'' (nAliens + 1) (vydAlien - 10) score' + Right finalScore -> rgAux g'' nAliens0 vydAlien0 0 + where + (g', g'') = split g + + + -- How to arrange for splitting of g in general if we have spawning of aliens + -- "inside" the game? The spawner should + -- keep control over the supply of random generators. + + game :: RandomGen g => g -> Int -> Velocity -> Score -> + SF GameInput ((Int, [ObsObjState]), Event (Either Score Score)) + game g nAliens vydAlien score0 = proc gi -> do + -- One could argue that feeding back only the ObsObjState part would + -- make things a little smoother. But possibly somewhat less general. + -- iPre not needed in the feedback path as long as dpSwitch is used, + -- but there are many side conditions related to the game. E.g. + -- the parts of the fed-back output used for hit detection not depending + -- on the result of the hit detection and so on. So for robustness, + -- maybe safest to leave the delay in. + -- + -- BUT! We cannot have BOTH dpSwitch and iPre! That will cause e.g. + -- hitting shots to be "seen" twice, due to a "double delay", and + -- that in turn will inflict double dammage. + -- + -- We could do score keeping *in this case* by simply *continusouly* + -- counting the number of aliens. This count can be used both to detect + -- a new round, and for computing the score as nAliens - alienCount. + -- But this does not exactly invite to more elaborate scoring schemes. + -- it would also be difficult to have different kinds of aliens of + -- varying value, since the natural way to do that is to look at the + -- actual object that is being removed in order to figure out its value, + -- rather than tryingto figure out a score indirectly through the + -- absence of objects! + rec + oos <- game' objs0 -< (gi, oos {- oosp -}) + {- oosp <- iPre emptyIL -< oos -} + score <- accumHold score0 -< aliensDied oos + gameOver <- edge -< alienLanded oos + newRound <- edge -< noAliensLeft oos + returnA -< ((score, map ooObsObjState (elemsIL oos)), + (newRound `tag` (Left score)) + `lMerge` (gameOver `tag` (Right score))) + where + objs0 = listToIL (gun (Point2 0 50) + : mkAliens g (worldXMin + d) 900 nAliens) + d = (worldXMax - worldXMin) / fromIntegral (nAliens + 1) + + mkAliens g x y 0 = [] + mkAliens g x y n | n > 0 = alien g' (Point2 x y) vydAlien + : mkAliens g'' (x + d) y (n - 1) + where + (g', g'') = split g + + aliensDied :: IL ObjOutput -> Event (Score -> Score) + aliensDied oos = + fmap (\es -> (+length es)) + (catEvents (map ooKillReq (findAllIL isAlien' oos))) + where + isAlien' (_, ObjOutput {ooObsObjState = oos}) = isAlien oos + + alienLanded :: IL ObjOutput -> Bool + alienLanded oos = isJust (findIL isLanded oos) + where + isLanded (_, ObjOutput {ooObsObjState = oos}) = + isAlien oos && point2Y (oosPos oos) <= 0 + + noAliensLeft :: IL ObjOutput -> Bool + noAliensLeft oos = null (findAllIL isAlien' oos) + where + isAlien' (_, ObjOutput {ooObsObjState = oos}) = isAlien oos + + -- dpSwitch for now. This makes kill/spawn events observable, + -- and allows feedback without iPre *in this case*, since only the + -- switching depends on the feedback, and hit detection does not + -- depend on any part of the fed-back output that in turn depends on + -- the hit detection. But this is a really fragile property! + -- Not that notYet is needed regardless of whether pSwictch or + -- dpSwitch is used. + {- + game' :: IL Object -> SF (GameInput, IL ObjOutput) (IL ObjOutput) + game' objs = dpSwitch route + objs + (arr killOrSpawn >>> notYet) + (\sfs' f -> game' (f sfs')) + -} + -- Slightly more efficient, and maybe clearer? + game' :: IL Object -> SF (GameInput, IL ObjOutput) (IL ObjOutput) + game' objs = dpSwitch route + objs + (noEvent --> arr killOrSpawn) + (\sfs' f -> game' (f sfs')) + + + route :: (GameInput, IL ObjOutput) -> IL sf -> IL (ObjInput, sf) + route (gi,oos) objs = mapIL routeAux objs + + where + routeAux (k, obj) = + (ObjInput {oiHit = if k `elem` hs + then Event () + else noEvent, + oiGameInput = gi}, + obj) + hs = hits (assocsIL (fmap ooObsObjState oos)) + + + -- This could be refined to full-fledged collision detection with + -- computation of proper impulses, and merging (adding) of multiple + -- impulses influencing a signle object. + hits :: [(ILKey, ObsObjState)] -> [ILKey] + hits kooss = concat (hitsAux kooss) + where + hitsAux [] = [] + hitsAux ((k,oos):kooss) = + [ [k, k'] | (k', oos') <- kooss, oos `hit` oos' ] + ++ hitsAux kooss + + oos1 `hit` oos2 + | isMissile oos1 && isAlien oos2 + || isAlien oos1 && isMissile oos2 = oos1 `colliding` oos2 + | otherwise = False + + killOrSpawn :: (a, IL ObjOutput) -> (Event (IL Object -> IL Object)) + killOrSpawn (_, oos) = + foldl (mergeBy (.)) noEvent es + where + es :: [Event (IL Object -> IL Object)] + es = [ mergeBy (.) + (ooKillReq oo `tag` (deleteIL k)) + (fmap (foldl (.) id . map insertIL_) + (ooSpawnReq oo)) + | (k,oo) <- assocsIL oos ] + + + renderScore :: Score -> HGL.Graphic + renderScore score = + HGL.withTextColor (colorTable ! White) $ + HGL.withTextAlignment (HGL.Left', HGL.Top) $ + HGL.text gp (show score) + where + gp = position2ToGPoint (Point2 worldXMin worldYMax) diff -crN afrp-0.4.orig/examples/SpaceInvaders/src/ObjectBehavior.hs afrp-0.4/examples/SpaceInvaders/src/ObjectBehavior.hs *** afrp-0.4.orig/examples/SpaceInvaders/src/ObjectBehavior.hs 1970-01-01 09:00:00.000000000 +0900 --- afrp-0.4/examples/SpaceInvaders/src/ObjectBehavior.hs 2004-03-23 07:48:55.000000000 +0900 *************** *** 0 **** --- 1,254 ---- + {- $Id: ObjectBehavior.as,v 1.2 2003/11/10 21:28:58 antony Exp $ + ****************************************************************************** + * I N V A D E R S * + * * + * Module: ObjectBehavior * + * Purpose: Behavior of objects. * + * Author: Henrik Nilsson * + * * + * Copyright (c) Yale University, 2003 * + * * + ****************************************************************************** + -} + + module ObjectBehavior ( + gun, -- :: Position2 -> Object + missile, -- :: Position2 -> Velocity2 -> Object + alien -- :: RandomGen g => g -> Position2 -> Object + ) where + + import qualified Random + + import AFRP + import AFRPUtilities + import AFRPGeometry + + import PhysicalDimensions + import WorldGeometry + import Parser + import Object + + + ------------------------------------------------------------------------------ + -- Gun + ------------------------------------------------------------------------------ + + gun :: Position2 -> Object + gun (Point2 x0 y0) = proc (ObjInput {oiGameInput = gi}) -> do + -- Position. + (Point2 xd _) <- ptrPos -< gi -- Desired position + rec + -- Controller. + let ad = 10 * (xd - x) - 5 * v -- Desired acceleration + + -- Physics with hard limits on acceleration and speed. + v <- integral -< let a = symLimit gunAccMax ad + in + if (-gunSpeedMax) <= v && v <= gunSpeedMax + || v < (-gunSpeedMax) && a > 0 + || v > gunSpeedMax && a < 0 + then a + else 0 + x <- (x0+) ^<< integral -< v + + -- Fire mechanism and ammunition level. + trigger <- lbp -< gi + (level, fire) <- magazine 20 0.5 -< trigger + + returnA -< ObjOutput { + ooObsObjState = oosGun (Point2 x y0) (vector2 v 0) level, + ooKillReq = noEvent, + ooSpawnReq = + fire `tag` [missile (Point2 x (y0 + (gunHeight/2))) + (vector2 v missileInitialSpeed)] + } + + + -- Ammunition magazine. Reloaded up to maximal + -- capacity at constant rate. + -- n ... Maximal and initial number of missiles. + -- f .......... Reload rate. + -- input ...... Trigger. + -- output ..... Tuple: + -- #1: Current number of missiles in magazine. + -- #2: Missile fired event. + magazine :: + Int -> Frequency + -> SF (Event ()) (Int, Event ()) + magazine n f = proc trigger -> do + reload <- repeatedly (1/f) () -< () + (level,canFire) + <- accumHold (n,True) -< + (trigger `tag` dec) + `lMerge` (reload `tag` inc) + returnA -< (level, + trigger `gate` canFire) + where + inc :: (Int,Bool) -> (Int, Bool) + inc (l,_) | l < n = (l + 1, l > 0) + | otherwise = (l, True) + dec :: (Int,Bool) -> (Int, Bool) + dec (l,_) | l > 0 = (l - 1, True) + | otherwise = (l, False) + + -- Ammunition magazine. Reloaded up to maximal capacity at constant rate. + -- n .......... Maximal and initial number of missiles. + -- f .......... Reload rate. + -- input ...... Trigger. + -- output ..... Tuple: + -- #1 .... Current number of missiles in magazine. + -- #2 .... Missile fired. + + {- + Henrik's original version, commented out for now: + + magazine :: Int -> Frequency -> SF (Event ()) (Int, Event ()) + magazine n f = proc trigger -> do + reload <- repeatedly (1/f) () -< () + -- We have a reverse application operator #, but for some reason arrowp + -- chokes on (#). + newLevelFire <- accumFilter (flip ($)) n -< (trigger `tag` dec) + `lMerge` (reload `tag` inc) + level <- hold n -< fmap fst newLevelFire + returnA -< (level, filterE snd newLevelFire `tag` ()) + where + -- inc, dec :: Int -> (Int, Maybe (Int, Bool)) + inc l | l < n = (l + 1, Just (l + 1, False)) + | otherwise = (l, Nothing) + dec l | l > 0 = (l - 1, Just (l - 1, True)) + | otherwise = (l, Nothing) + + -} + + ------------------------------------------------------------------------------ + -- Missile + ------------------------------------------------------------------------------ + + -- Of course, this would be much better if we used the real impulse stuff: + -- No bogus iPre, for instance. + missile :: Position2 -> Velocity2 -> Object + missile p0 v0 = proc oi -> do + rec + -- Basic physics + vp <- iPre v0 -< v + ffi <- forceField -< (p, vp) + v <- (v0 ^+^) ^<< impulseIntegral -< (gravity, ffi) + p <- (p0 .+^) ^<< integral -< v + die <- after missileLifeSpan () -< () + returnA -< ObjOutput { + ooObsObjState = oosMissile p v, + ooKillReq = oiHit oi `lMerge` die, + ooSpawnReq = noEvent + } + + + ------------------------------------------------------------------------------ + -- Alien + ------------------------------------------------------------------------------ + + type ShieldLevel = Double + + + -- Alien behavior. + -- g .......... Random generator. + -- p0 ......... Initial position. + -- vyd ........ Desired vertical speed. + + alien :: RandomGen g => g -> Position2 -> Velocity -> Object + alien g p0 vyd = proc oi -> do + rec + -- Pick a desired horizontal position. + rx <- noiseR (worldXMin, worldXMax) g -< () + sample <- occasionally g 5 () -< () + xd <- hold (point2X p0) -< sample `tag` rx + + -- Controller. Control constants not optimized. Who says aliens know + -- anything about control theory? + let axd = 5 * (xd - point2X p) - 3 * (vector2X v) + ayd = 20 * (vyd - (vector2Y v)) + ad = vector2 axd ayd + h = vector2Theta ad + + -- Physics + let a = vector2Polar (min alienAccMax (vector2Rho ad)) h + vp <- iPre v0 -< v + ffi <- forceField -< (p, vp) + v <- (v0 ^+^) ^<< impulseIntegral -< (gravity ^+^ a, ffi) + p <- (p0 .+^) ^<< integral -< v + + -- Shields + sl <- shield -< oiHit oi + die <- edge -< sl <= 0 + + returnA -< ObjOutput { + ooObsObjState = oosAlien p h v, + ooKillReq = die, + ooSpawnReq = noEvent + } + where + v0 = zeroVector + + + shield :: SF (Event ()) ShieldLevel + shield = proc hit -> do + rec + let rechargeRate = if sl < slMax then slMax / 10 else 0 + sl <- (slMax +) ^<< impulseIntegral -< (rechargeRate, hit `tag` damage) + returnA -< sl + where + slMax = 100 + damage = -50 + + + ------------------------------------------------------------------------------ + -- Force fields acting on objects + ------------------------------------------------------------------------------ + + -- Object are subject to gravity and a strange repellent forcefield that + -- drives objects away from the edges, effectively creating a corridor. + -- The strange field is inversely proportional to the cube of the distance + -- from either edge. It is thought that the field is a remnant of a defence + -- system put in place by the mythical and technologically advanced + -- "Predecessors" eons ago. + + {- + field :: Position2 -> Acceleration2 + field (Point2 x _) = vector2 (leftAcc - rightAcc) 0 ^+^ gravity + where + leftAcc = min (if x > worldXMin + then k / (x - worldXMin)^3 + else maxAcc) + maxAcc + rightAcc = min (if x < worldXMax + then k / (worldXMax - x)^3 + else maxAcc) + maxAcc + k = 10000000 + maxAcc = 10000 + -} + + -- New attempt. Force fields act like invisible walls. + -- The fact that this is a stateful *signal* function (Fields having state? + -- Come on ...), can be attributed to the fact that we are cheating in the + -- first place by abstracting events of short duration to instantaneous + -- events. "field" being a stateful signal functio is part of the price + -- one have to pay for that to make this work in practice. + + forceField :: SF (Position2, Velocity2) (Event Acceleration2) + forceField = proc (p, v) -> do + lfi <- edge -< point2X p < worldXMin && vector2X v < 0 + rfi <- edge -< point2X p > worldXMax && vector2X v > 0 + returnA -< (mergeBy (^+^) (lfi `tag` (vector2 (-2 * vector2X v) 0)) + (rfi `tag` (vector2 (-2 * vector2X v) 0))) + + + gravity = vector2 0 (-20) + + + ------------------------------------------------------------------------------ + -- Support + ------------------------------------------------------------------------------ + + limit ll ul x = if x < ll then ll else if x > ul then ul else x + + symLimit l = let absl = abs l in limit (-absl) absl diff -crN afrp-0.4.orig/examples/SpaceInvaders/src/Parser.hs afrp-0.4/examples/SpaceInvaders/src/Parser.hs *** afrp-0.4.orig/examples/SpaceInvaders/src/Parser.hs 2004-03-23 07:48:55.000000000 +0900 --- afrp-0.4/examples/SpaceInvaders/src/Parser.hs 2005-07-31 10:37:54.000000000 +0900 *************** *** 35,41 **** ) where import Maybe (isNothing, isJust) ! import qualified Graphics.HGL.Utils as HGL (Event(..)) import Char (ord, isSpace, isDigit) import AFRP --- 35,41 ---- ) where import Maybe (isNothing, isJust) ! import qualified Graphics.HGL as HGL (Event(..)) import Char (ord, isSpace, isDigit) import AFRP diff -crN afrp-0.4.orig/examples/SpaceInvaders/src/RenderLandscape.hs afrp-0.4/examples/SpaceInvaders/src/RenderLandscape.hs *** afrp-0.4.orig/examples/SpaceInvaders/src/RenderLandscape.hs 2004-03-23 07:48:55.000000000 +0900 --- afrp-0.4/examples/SpaceInvaders/src/RenderLandscape.hs 2005-07-31 10:38:46.000000000 +0900 *************** *** 16,22 **** ) where import Array ! import qualified Graphics.HGL.Utils as HGL import AFRPPoint2 (Point2(..)) --- 16,22 ---- ) where import Array ! import qualified Graphics.HGL as HGL import AFRPPoint2 (Point2(..)) diff -crN afrp-0.4.orig/examples/SpaceInvaders/src/RenderObject.hs afrp-0.4/examples/SpaceInvaders/src/RenderObject.hs *** afrp-0.4.orig/examples/SpaceInvaders/src/RenderObject.hs 2004-03-23 07:48:55.000000000 +0900 --- afrp-0.4/examples/SpaceInvaders/src/RenderObject.hs 2005-07-31 10:38:28.000000000 +0900 *************** *** 16,22 **** ) where import Array ! import qualified Graphics.HGL.Utils as HGL import AFRPGeometry import PhysicalDimensions --- 16,22 ---- ) where import Array ! import qualified Graphics.HGL as HGL import AFRPGeometry import PhysicalDimensions diff -crN afrp-0.4.orig/examples/SpaceInvaders/src/SimpleGun.hs afrp-0.4/examples/SpaceInvaders/src/SimpleGun.hs *** afrp-0.4.orig/examples/SpaceInvaders/src/SimpleGun.hs 1970-01-01 09:00:00.000000000 +0900 --- afrp-0.4/examples/SpaceInvaders/src/SimpleGun.hs 2004-03-23 07:48:55.000000000 +0900 *************** *** 0 **** --- 1,208 ---- + {- $Id: SimpleGun.as,v 1.2 2003/11/10 21:28:58 antony Exp $ + ****************************************************************************** + * I N V A D E R S * + * * + * Module: SimpleGun * + * Purpose: A simple gun as a signal function * + * Author: Antony Courtney * + * * + * Copyright (c) Yale University, 2003 * + * * + ****************************************************************************** + -} + + module SimpleGun ( + simpleGunObject -- :: Object + ) where + + import qualified Random + + import AFRP + import AFRPUtilities + import AFRPGeometry + + import PhysicalDimensions + import WorldGeometry + import Parser + import Object + + + ------------------------------------------------------------------------------ + -- Gun + ------------------------------------------------------------------------------ + + data SimpleGunState = SimpleGunState { + sgsPos :: Position2, + sgsVel :: Velocity2, + sgsFired :: Event () + } + + type SimpleGun = SF GameInput SimpleGunState + + simpleGun :: Position2 -> SimpleGun + simpleGun (Point2 x0 y0) = proc gi -> do + -- Desired position: + (Point2 xd _) <- ptrPos -< gi + rec + -- Controller. + -- Desired acceleration: + let ad = 10 * (xd - x) - 5 * v + + -- basic physics: + v <- integral -< clampAcc v ad + x <- (x0+) ^<< integral -< v + + fire <- lbp -< gi + returnA -< SimpleGunState { + sgsPos = (Point2 x y0), + sgsVel = (vector2 v 0), + sgsFired = fire + } + + ------------------------------------------------------------------------------ + -- Support + ------------------------------------------------------------------------------ + + -- Compute actual acceleration from + -- desired acceleration by setting + -- hard limits on acceleration and velocity: + clampAcc v ad = + let a = symLimit gunAccMax ad + in if (-gunSpeedMax) <= v && v <= gunSpeedMax + || v < (-gunSpeedMax) && a > 0 + || v > gunSpeedMax && a < 0 + then a + else 0 + + limit ll ul x = if x < ll then ll else if x > ul then ul else x + + symLimit l = let absl = abs l in limit (-absl) absl + + -- We really aught to test this, but we'll just settle for type checking + -- for now, since we know the gun works... + simpleGunObject :: Object + simpleGunObject = undefined + + -- Since this file doesn't import ObjectBehavior, I'm going to place a + -- couple of versions of the code for ObjectBehavior.gun here. These + -- correspond exactly with what is presented in the paper; they are + -- copied here just to ensure we don't make any obvious mistakes + -- that could be caught by parsing / typechecking. + + -- *sigh*. So much for typechecking...we have to comment this out anyway, + -- because oosGun is undefined. + {- + gun :: Position2 -> Object + gun (Point2 x0 y0) = proc objIn -> do + let gi = oiGameInput objIn + -- Desired position: + (Point2 xd _) <- ptrPos -< gi + rec + -- Controller. + -- Desired acceleration: + let ad = 10 * (xd - x) - 5 * v + + -- basic physics: + v <- integral -< clampAcc v ad + x <- (x0+) ^<< integral -< v + + fire <- lbp -< gi + returnA -< + ObjOutput { + ooObsObjState = oosGun (Point2 x y0) + (vector2 v 0), + ooKillReq = noEvent, + ooSpawnReq = + fire `tag` + [missile (Point2 x (y0 + (gunHeight/2))) + (vector2 v missileInitialSpeed)] + } + -} + + -- Ammunition magazine. Reloaded up to maximal + -- capacity at constant rate. + -- n ... Maximal and initial number of missiles. + -- f .......... Reload rate. + -- input ...... Trigger. + -- output ..... Tuple: + -- #1: Current number of missiles in magazine. + -- #2: Missile fired event. + magazine :: + Int -> Frequency + -> SF (Event ()) (Int, Event ()) + magazine n f = proc trigger -> do + reload <- repeatedly (1/f) () -< () + (level,canFire) + <- accumHold (n,True) -< + (trigger `tag` dec) + `lMerge` (reload `tag` inc) + returnA -< (level, + trigger `gate` canFire) + where + inc :: (Int,Bool) -> (Int, Bool) + inc (l,_) | l < n = (l + 1, l > 0) + | otherwise = (l, True) + dec :: (Int,Bool) -> (Int, Bool) + dec (l,_) | l > 0 = (l - 1, True) + | otherwise = (l, False) + + -- Of course, this would be much better if we used the real impulse stuff: + -- No bogus iPre, for instance. + missile :: Position2 -> Velocity2 -> Object + missile p0 v0 = proc oi -> do + rec + -- Basic physics + vp <- iPre v0 -< v + ffi <- forceField -< (p, vp) + v <- (v0 ^+^) ^<< impulseIntegral -< (gravity, ffi) + p <- (p0 .+^) ^<< integral -< v + die <- after missileLifeSpan () -< () + returnA -< ObjOutput { + ooObsObjState = oosMissile p v, + ooKillReq = oiHit oi `lMerge` die, + ooSpawnReq = noEvent + } + + ------------------------------------------------------------------------------ + -- Force fields acting on objects + ------------------------------------------------------------------------------ + + -- Object are subject to gravity and a strange repellent forcefield that + -- drives objects away from the edges, effectively creating a corridor. + -- The strange field is inversely proportional to the cube of the distance + -- from either edge. It is thought that the field is a remnant of a defence + -- system put in place by the mythical and technologically advanced + -- "Predecessors" eons ago. + + {- + field :: Position2 -> Acceleration2 + field (Point2 x _) = vector2 (leftAcc - rightAcc) 0 ^+^ gravity + where + leftAcc = min (if x > worldXMin + then k / (x - worldXMin)^3 + else maxAcc) + maxAcc + rightAcc = min (if x < worldXMax + then k / (worldXMax - x)^3 + else maxAcc) + maxAcc + k = 10000000 + maxAcc = 10000 + -} + + -- New attempt. Force fields act like invisible walls. + -- The fact that this is a stateful *signal* function (Fields having state? + -- Come on ...), can be attributed to the fact that we are cheating in the + -- first place by abstracting events of short duration to instantaneous + -- events. "field" being a stateful signal functio is part of the price + -- one have to pay for that to make this work in practice. + + forceField :: SF (Position2, Velocity2) (Event Acceleration2) + forceField = proc (p, v) -> do + lfi <- edge -< point2X p < worldXMin && vector2X v < 0 + rfi <- edge -< point2X p > worldXMax && vector2X v > 0 + returnA -< (mergeBy (^+^) (lfi `tag` (vector2 (-2 * vector2X v) 0)) + (rfi `tag` (vector2 (-2 * vector2X v) 0))) + + + gravity = vector2 0 (-20) diff -crN afrp-0.4.orig/examples/SpaceInvaders/src/WorldGeometry.hs afrp-0.4/examples/SpaceInvaders/src/WorldGeometry.hs *** afrp-0.4.orig/examples/SpaceInvaders/src/WorldGeometry.hs 2004-03-23 07:48:55.000000000 +0900 --- afrp-0.4/examples/SpaceInvaders/src/WorldGeometry.hs 2005-07-31 10:37:24.000000000 +0900 *************** *** 16,22 **** import AFRPPoint2 (Point2(..)) import PhysicalDimensions ! import qualified Graphics.HGL.Utils as HGL (Point) -- Everything in the world is measured in meters. --- 16,22 ---- import AFRPPoint2 (Point2(..)) import PhysicalDimensions ! import qualified Graphics.HGL as HGL (Point) -- Everything in the world is measured in meters. Binary files afrp-0.4.orig/examples/TailgatingDetector/.DS_Store and afrp-0.4/examples/TailgatingDetector/.DS_Store differ diff -crN afrp-0.4.orig/examples/TailgatingDetector/TailgatingDetector.hs afrp-0.4/examples/TailgatingDetector/TailgatingDetector.hs *** afrp-0.4.orig/examples/TailgatingDetector/TailgatingDetector.hs 1970-01-01 09:00:00.000000000 +0900 --- afrp-0.4/examples/TailgatingDetector/TailgatingDetector.hs 2005-07-30 16:44:08.000000000 +0900 *************** *** 0 **** --- 1,322 ---- + {- + ****************************************************************************** + * A F R P * + * * + * Module: TailgatingDetector * + * Purpose: AFRP Expressitivity Test * + * Authors: Henrik Nilsson * + * * + * Copyright (c) Yale University, 2003 * + * * + ****************************************************************************** + -} + + -- Context: an autonomous flying vehicle carrying out traffic surveillance + -- through an on-board video camera. + -- + -- Objective: finding a tailgater among a group of vehicles traveling along + -- a highway lane. The group is defined by the section of the highway in + -- view and thus changes dynamically as ground vehicles with non-zero + -- relative speed to the flying vehicles enters or leaves the field of + -- vision. + -- + -- Simplifying assumptions: + -- * The positive x-axis of the video images is supposed to correspond to the + -- direction of travel. + -- * The flying vehicle is assumed to travel directly over and along the + -- highway lane when looking for tailgaters. The y-coordinate of the + -- highway is thus roughly 0. + -- * It is enough to consider the x-coordinate of ground vehicle positions. + -- Thus the position and velocity types are both just (signed) Double + -- for our purposes. + -- + -- I find this example interesting because it makes use of TWO COLLECTION of + -- signal functions, these collections HAVE TO BE DYNAMIC by the very + -- nature of the problem, and it makes use of the the fact that CONTINUATIONS + -- ARE FIRST CLASS ENTITIES in a way which arguably also is justified + -- by the nature of the problem. + + module TailgatingDetector where + + import List (sortBy, (\\)) + + import AFRP + import AFRPUtilities + + + ------------------------------------------------------------------------------ + -- Testing framework + ------------------------------------------------------------------------------ + + type Position = Double -- [m] + type Distance = Double -- [m] + type Velocity = Double -- [m/s] + + -- We'll call any ground vehicle "car". For our purposes, a car is + -- represented by its ground position and ground velocity. + type Car = (Position, Velocity) + + + -- A highway is just a list of cars. In this simple setting, we assume all + -- cars are there all the time (no enter or exit ramps etc.) + type Highway = [Car] + + + -- Type of the Video signal. Here just an association list of cars *in view* + -- with *relative* positions. + type Video = [(Int, Car)] + + + -- System info, such as height and ground speed. Here, just the position. + type UAVStatus = Position + + + -- Various ways of making cars. + switchAfter :: Time -> SF a b -> (b -> SF a b) -> SF a b + switchAfter t sf k = switch (sf &&& after t () >>^ \(b,e) -> (b, e `tag` b)) k + + + mkCar1 :: Position -> Velocity -> SF a Car + mkCar1 p0 v = constant v >>> (integral >>^ (+p0)) &&& identity + + mkCar2 :: Position -> Velocity -> Time -> Velocity -> SF a Car + mkCar2 p0 v0 t0 v = switchAfter t0 (mkCar1 p0 v0) (flip mkCar1 v . fst) + + + mkCar3 :: Position->Velocity->Time->Velocity->Time->Velocity->SF a Car + mkCar3 p0 v0 t0 v1 t1 v = switchAfter t0 (mkCar1 p0 v0) $ \(p1, _) -> + switchAfter t1 (mkCar1 p1 v1) $ \(p2, _) -> + mkCar1 p2 v + + + highway :: SF a Highway + highway = parB [mkCar1 (-600) 30.9, + mkCar1 0 30, + mkCar3 (-1000) 40 95 30 200 30.9, + mkCar1 (-3000) 45, + mkCar1 700 28, + mkCar1 800 29.1] + + + -- The status of the UAV. For now, it's just flying at constant speed. + uavStatus :: SF a UAVStatus + uavStatus = constant 30 >>> integral + + + -- Tracks a car in the video stream. An event is generated when tracking is + -- lost, which we assume only happens if the car leaves the field of vision. + -- We don't concern ourselves with realistic creation of trackers. + -- The UAVStatus signal provides the current flying height and ground speed + -- which allows the perceived position to be scaled to a position in meters + -- relative to the origin directly under the flying vehicle, and the perceived + -- velocity to be transformed to ground velocity. + type CarTracker = SF (Video, UAVStatus) (Car, Event ()) + + range = 500 + + -- Creation of video stream subject to field of view and car trackers + -- as cars enters the field of view. + mkVideoAndTrackers :: SF (Highway, UAVStatus) (Video, Event CarTracker) + mkVideoAndTrackers = arr mkVideo >>> identity &&& carEntry + where + mkVideo :: (Highway, Position) -> Video + mkVideo (cars, p_uav) = + [ (i, (p_rel, v)) + | (i, (p, v)) <- zip [0..] cars, + let p_rel = p - p_uav, abs p_rel <= range] + + carEntry :: SF Video (Event CarTracker) + carEntry = edgeBy newCar [] + where + newCar v_prev v = + case (map fst v) \\ (map fst v_prev) of + [] -> Nothing + (i : _) -> Just (mkCarTracker i) + + mkCarTracker :: Int -> CarTracker + mkCarTracker i = arr (lookup i . fst) + >>> trackAndHold undefined + &&& edgeBy justToNothing (Just undefined) + where + justToNothing Nothing Nothing = Nothing + justToNothing Nothing (Just _) = Nothing + justToNothing (Just _) (Just _) = Nothing + justToNothing (Just _) Nothing = Just () + + + videoAndTrackers :: SF a (Video, Event CarTracker) + videoAndTrackers = highway &&& uavStatus >>> mkVideoAndTrackers + + + smplFreq = 2.0 + smplPer = 1/smplFreq + + + ------------------------------------------------------------------------------ + -- Tailgating detector + ------------------------------------------------------------------------------ + + -- Looks at the positions of two cars and determines if the first is + -- tailgating the second. Tailgating is assumed to have occurred if: + -- * the first car is behind the second; + -- * the absolute speed of the first car is greater than 5 m/s; + -- * the relative speed of the cars is within 20 % of the absolute speed; + -- * the first car is no more than 5 s behind the second; and + -- * after 30 s, the average distance between the cars normalized by + -- the absolute speed is less than a second. + + tailgating :: SF (Car, Car) (Event ()) + tailgating = provided follow tooClose never + where + follow ((p1, v1), (p2, v2)) = p1 < p2 + && v1 > 5.0 + && abs ((v2 - v1)/v1) < 0.2 + && (p2 - p1) / v1 < 5.0 + + -- Under the assumption that car c1 is following car c2, generate an + -- event if car1 has been too close to car2 on average during the + -- last 30 s. + tooClose :: SF (Car, Car) (Event ()) + tooClose = proc (c1, c2) -> do + ead <- recur (snapAfter 30 <<< avgDist) -< (c1, c2) + returnA -< (filterE (<1.0) ead) `tag` () + + avgDist = proc ((p1, v1), (p2, v2)) -> do + let nd = (p2 - p1) / v1 + ind <- integral -< nd + t <- localTime -< () + returnA -< if t > 0 then ind / t else nd + + + ------------------------------------------------------------------------------ + -- Multi-Car tracker + ------------------------------------------------------------------------------ + + -- Auxiliary definitions + + type Id = Int + + data MCTCol a = MCTCol Id [(Id, a)] + + + instance Functor MCTCol where + fmap f (MCTCol n ias) = MCTCol n [ (i, f a) | (i, a) <- ias ] + + + -- Tracking of individual cars in a group. The arrival of a new car is + -- signalled by an external event, which causes a new tracker to be added + -- to internal collection of car trackers. A tracker is removed as soon + -- as it looses tracking. + -- + -- The output consists of the output from the individual trackers, tagged + -- with an assigned identity unique to each tracker. + -- + -- I'M GIVING UP ON THIS BIT FOR NOW + -- The external identity event signals that the car being tracked by the + -- tracker tagged by the identity carried by the event is guilty of + -- tailgating. This causes an event carrying the *continuation* of the + -- corresponding tracker to be generated, e.g. allowing the overall + -- controll system to focus on follwing that particular car without first + -- having to start a new tracker (risking misidentification). + + mct :: SF (Video, UAVStatus, Event CarTracker) [(Id, Car)] + mct = pSwitch route cts_init addOrDelCTs (\cts' f -> mctAux (f cts')) + >>^ getCars + where + mctAux cts = pSwitch route + cts + (noEvent --> addOrDelCTs) + (\cts' f -> mctAux (f cts')) + + route (v, s, _) = fmap (\ct -> ((v, s), ct)) + + -- addOrDelCTs :: SF _ (Event (MCTCol CarTracker -> MCTCol carTracker)) + addOrDelCTs = proc ((_, _, ect), ces) -> do + let eAdd = fmap addCT ect + let eDel = fmap delCTs (catEvents (getEvents ces)) + returnA -< mergeBy (.) eAdd eDel + + cts_init :: MCTCol CarTracker + cts_init = MCTCol 0 [] + + addCT :: CarTracker -> MCTCol CarTracker -> MCTCol CarTracker + addCT ct (MCTCol n icts) = MCTCol (n+1) ((n, ct) : icts) + + delCTs :: [Id] -> MCTCol CarTracker -> MCTCol CarTracker + delCTs is (MCTCol n icts) = + MCTCol n (filter (flip notElem is . fst) icts) + + getCars :: MCTCol (Car, Event ()) -> [(Id, Car)] + getCars (MCTCol _ ices) = [(i, c) | (i, (c, _)) <- ices ] + + getEvents :: MCTCol (Car, Event ()) -> [Event Id] + getEvents (MCTCol _ ices) = [e `tag` i | (i,(_,e)) <- ices] + + + ------------------------------------------------------------------------------ + -- Multi tailgating detector + ------------------------------------------------------------------------------ + + -- Auxiliary definitions + + newtype MTGDCol a = MTGDCol [((Id,Id), a)] + + + instance Functor MTGDCol where + fmap f (MTGDCol iias) = MTGDCol [ (ii, f a) | (ii, a) <- iias ] + + + -- Run tailgating above for each pair of tracked cars. A structural change + -- to the list of tracked cars is signalled by an event, at which point + -- the signal function will figure which old tailgating detectors that have + -- to be removed and which new that have to be started based on an initial + -- sample of the new configuration. An event carrying the identity of + -- a tailgater and the one being tailgated is generated when one of the + -- tailgating signal functions generates an event. + + mtgd :: SF [(Id, Car)] (Event [(Id, Id)]) + mtgd = proc ics -> do + let ics' = sortBy relPos ics + eno <- newOrder -< ics' + etgs <- rpSwitch route (MTGDCol []) -< (ics', fmap updateTGDs eno) + returnA -< tailgaters etgs + where + route ics (MTGDCol iitgs) = MTGDCol $ + let cs = map snd ics + in + [ (ii, (cc, tg)) + | (cc, (ii, tg)) <- zip (zip cs (tail cs)) iitgs ] + + relPos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 + + newOrder :: SF [(Id, Car)] (Event [Id]) + newOrder = edgeBy (\ics ics' -> if sameOrder ics ics' then + Nothing + else + Just (map fst ics')) + [] + where + sameOrder [] [] = True + sameOrder [] _ = False + sameOrder _ [] = False + sameOrder ((i,_):ics) ((i',_):ics') + | i == i' = sameOrder ics ics' + | otherwise = False + + updateTGDs is (MTGDCol iitgs) = MTGDCol $ + [ (ii, maybe tailgating id (lookup ii iitgs)) + | ii <- zip is (tail is) ] + + tailgaters :: MTGDCol (Event ()) -> Event [(Id, Id)] + tailgaters (MTGDCol iies) = catEvents [ e `tag` ii | (ii, e) <- iies ] + + + -- Finally, we can tie the individaul pieces together into a signal + -- function which finds tailgaters: + + findTailgaters :: + SF (Video, UAVStatus, Event CarTracker) ([(Id, Car)], Event [(Id, Id)]) + findTailgaters = proc (v, s, ect) -> do + ics <- mct -< (v, s, ect) + etgs <- mtgd -< ics + returnA -< (ics, etgs) diff -crN afrp-0.4.orig/examples/TailgatingDetector/TestTGMain.hs afrp-0.4/examples/TailgatingDetector/TestTGMain.hs *** afrp-0.4.orig/examples/TailgatingDetector/TestTGMain.hs 1970-01-01 09:00:00.000000000 +0900 --- afrp-0.4/examples/TailgatingDetector/TestTGMain.hs 2005-07-30 18:05:27.000000000 +0900 *************** *** 0 **** --- 1,102 ---- + {- + ****************************************************************************** + * A F R P * + * * + * Example: Test TG * + * Purpose: Testing of the tailgating detector. * + * Authors: Henrik Nilsson * + * * + * Copyright (c) Yale University, 2003 * + * * + ****************************************************************************** + -} + + module Main where + + import List (sortBy) + + import AFRP + import AFRPUtilities + import AFRPInternals -- Just for testing purposes. + + import TailgatingDetector + + + -- Looks for interesting events in the video stream (cars entering, + -- leaving, overtaking) in the interval [0, t]. + testVideo :: Time -> [(Time, Event Video)] + testVideo t_max = filter (isEvent . snd) $ + takeWhile (\(t, _) -> t <= t_max) $ + embed (localTime &&& (videoAndTrackers >>^ fst) + >>> filterVideo) + (deltaEncode smplPer (repeat ())) + where + filterVideo = second (edgeBy change []) + where + change v_prev v = + if (map fst (sortBy comparePos v_prev)) + /= (map fst (sortBy comparePos v)) then + Just v + else + Nothing + + comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 + + + ppTestVideo t = mapM_ (putStrLn . show) (testVideo t) + + + testTailgating t_max = filter (isEvent . snd) $ + takeWhile (\(t, _) -> t <= t_max) $ + embed (localTime + &&& (mkCar3 (-1000) 40 95 30 200 30.9 + &&& mkCar1 0 30 + >>> tailgating)) + (deltaEncode smplPer (repeat ())) + + + testMCT :: Time -> [(Time, Event [(Id, Car)])] + testMCT t_max = filter (isEvent . snd) $ + takeWhile (\(t, _) -> t <= t_max) $ + embed (localTime + &&& (uavStatus + >>> (highway &&& identity >>> mkVideoAndTrackers) + &&& identity + >>> arr (\((v, ect), s) -> (v, s, ect)) + >>> mct) + >>> filterMCTOutput) + (deltaEncode smplPer (repeat ())) + where + filterMCTOutput = second (edgeBy change []) + where + change v_prev v = + if (map fst (sortBy comparePos v_prev)) + /= (map fst (sortBy comparePos v)) then + Just v + else + Nothing + + comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 + + + ppTestMCT t = mapM_ (putStrLn . show) (testMCT t) + + + testMTGD :: Time -> [(Time, (Event [(Id,Id)], [(Id, Car)]))] + testMTGD t_max = filter (isEvent . fst . snd) $ + takeWhile (\(t, _) -> t <= t_max) $ + embed (localTime + &&& (proc _ -> do + s <- uavStatus -< () + h <- highway -< () + (v, ect) <- mkVideoAndTrackers -< (h, s) + (ics, etgs) <- findTailgaters -< (v,s,ect) + etgs <- mtgd -< ics + returnA -< (etgs, ics))) + (deltaEncode smplPer (repeat ())) + + ppTestMTGD t = mapM_ (putStrLn . show) (testMTGD t) + + + -- We could read the car specification from standard input. + main = ppTestMTGD 2000 Binary files afrp-0.4.orig/src/.DS_Store and afrp-0.4/src/.DS_Store differ diff -crN afrp-0.4.orig/src/AFRPUtilities.hs afrp-0.4/src/AFRPUtilities.hs *** afrp-0.4.orig/src/AFRPUtilities.hs 2004-03-23 07:48:55.000000000 +0900 --- afrp-0.4/src/AFRPUtilities.hs 2005-09-01 14:46:27.000000000 +0900 *************** *** 32,42 **** module AFRPUtilities ( - -- General arrow utilities - (^>>), -- :: Arrow a => (b -> c) -> a c d -> a b d - (>>^), -- :: Arrow a => a b c -> (c -> d) -> a b d - (^<<), -- :: Arrow a => (c -> d) -> a b c -> a b d - (<<^), -- :: Arrow a => a c d -> (b -> c) -> a b d -- Liftings arr2, -- :: Arrow a => (b->c->d) -> a (b,c) d --- 32,37 ---- *************** *** 89,118 **** import AFRPDiagnostics import AFRP - - infixr 1 ^<<, ^>> - infixl 1 <<^, >>^ infixr 0 `fby` - ------------------------------------------------------------------------------ - -- General arrow utilities - ------------------------------------------------------------------------------ - - (^>>) :: Arrow a => (b -> c) -> a c d -> a b d - f ^>> a = arr f >>> a - - (>>^) :: Arrow a => a b c -> (c -> d) -> a b d - a >>^ f = a >>> arr f - - - (^<<) :: Arrow a => (c -> d) -> a b c -> a b d - f ^<< a = arr f <<< a - - - (<<^) :: Arrow a => a c d -> (b -> c) -> a b d - a <<^ f = a <<< arr f - ------------------------------------------------------------------------------ -- Liftings --- 84,92 ----