Functional Animations

Credits: Lecture and literate Haskell file borrowed from Ranjit Jhala, UCSD CSE 230

> {-# LANGUAGE NoMonomorphismRestriction #-}
> import Shape
> import Draw
> import Picture
> import SOE hiding (Region)
> import qualified SOE as G (Region)

Graphics Recap

Representing Regions

Recall the Shape type from a few lectures back (here we’ll just use the definitions in the SOE library.)

data Shape = Rectangle Side Side
| Ellipse Radius Radius
| RtTriangle Side Side
| Polygon [Vertex]
deriving Show

type Radius = Float
type Side = Float
type Vertex = (Float,Float)

We can create specific shape values like

> s1 = Rectangle 3 2
> s2 = Ellipse 1 1.5
> s3 = RtTriangle 3 2
> s4 = Polygon [(-2.5, 2.5)
> ,(-3, 0)
> ,(-1.7,-1.0)
> ,(-1.1,0.2)
> ,(-1.5,2.0)]

We can convert a Shape into a more general Region that contains atomic shapes, which can be operated on in various ways.

data Region = Shape Shape		-- primitive shape
| Translate Vector Region -- translated region
| Scale Vector Region -- scaled region
| Complement Region -- inverse of region
| Region `Union` Region -- union of regions
| Region `Intersect` Region -- intersection of regions
| Region `Xor` Region -- XOR of regions
| Empty -- empty region
deriving Show

We can convert our basic shapes to atomic regions

> r1 = Shape s1
> r2 = Shape s2
> r3 = Shape s3
> r4 = Shape s4

and combine the atomic regions

> reg1  = r3 `Union` (r1 `Intersect` (Complement r2 `Union` r4)) 

Representing Pictures

Finally, we have a Picture type which comprises colored regions, which can be layered over each other

data Picture = Region Color Region
| Picture `Over` Picture
| EmptyPic
deriving Show

Here is an atomic picture

> pic1  = Region Red reg1

Here’s another region

> r5   = Shape $ Rectangle 1 1
> r6 = Shape $ Ellipse 0.5 0.5
> reg2 = (Scale (2,2) r6) `Union`
> (Translate (2,1) r6) `Union`
> (Translate (-2,0) r5)

which we color yellow

> pic2 = Region Yellow reg2

and we can layer the two pictures over each other

> pic3 =pic2 `Over` pic1

Drawing Pictures

We can render a picture in a window via the function draw

> main1 = draw "Picture 1" pic1

Lets render the other pictures

> main2 = draw "Picture 2" pic2

and

> main3 = draw "Picture 3" $ pic3 

From Pictures To Animations

So far, our pictures have been static, nothing moves.

Suppose we wanted to create animations. The standard trick for how moving images work is by exploiting persistence of vision wherein an illusion of motion is created by rapidly rendering a series of images. This seems like an inherently imperative activity

  1. initialize image
  2. render image
  3. pause
  4. change image
  5. go to step 1.

However, this is hideously low-level: it is hard to compose animations from simpler ones, hard to reuse animations, and generally rather brittle. Instead, we will take a radically different view, where we will represent an animation as a purely functional value. How? A type is worth a thousand pictures…

> type Animation a = Time -> a
> type Time = Float

That is, an animation is a function that tells us, at each time instant, what the image to be rendered at that instant is!

> rubberBall :: Animation Shape
> rubberBall = \t -> Ellipse (sin t) (cos t)

or Region animations

> revolvingBall :: Animation Region
> revolvingBall = \t -> Translate (sin t, cos t) ball
> where ball = Shape (Ellipse 0.2 0.2)

or Picture animations

> planets ::  Animation Picture
> planets t = p1 `Over` p2
> where p1 = Region Red $ Shape (rubberBall t)
> p2 = Region Yellow $ revolvingBall t

or just plain old String animations

> ticker :: Animation String
> ticker t = "The time is :" ++ show t

How do we render all these animations? Well, all we need is a function that renders graphics, that is, takes a window name, an Animation Graphic and returns an action (the rendering.)

> animate :: String -> Animation Graphic -> IO ()

with this, rendering is trivial. First, lets create an appropriate animation

> blueBall ::  Animation Graphic
> blueBall = withColor Blue . shapeToGraphic . rubberBall

The above type looks a bit surprising, but lets slowly step through the expression.

withColor Blue :: Graphic -> Graphic
shapeToGraphic :: Shape -> Graphic

and so

withColor Blue . shapeToGraphic :: Shape -> Graphic

Finally,

rubberBall :: Time -> Shape 

and so

withColor Blue . shapeToGraphic . rubberBall :: Time -> Graphic

Now, lets run some animations!

> main4 = animate "Shape"   $ withColor Blue . shapeToGraphic . rubberBall 
> main5 = animate "Text"    $ text (100,200) . ticker 
> main6 = animate "Region"  $ withColor Yellow . regionToGraphic . revolvingBall
> main7 = animate "Picture" $ picToGraphic . planets

A DSL for Animations

We can build animations up at a low-level, by constructing functions from Time to Graphic but this is a bit ugly. Next, we will use type classes to design some generic operators for animations, which will allow us to write animations much more easily and smoothly.

When we are done, we will be able to create very rich animations, from very simple ones, by elegantly composing the animations, thereby allowing us reuse sub-animations and animation combinators in a safe and flexible way.

  1. We start with a trivial behavior which is a stationary object.
> demo1 = animateB "1" $ reg yellow $ ballB
  1. Next, we can simply translate a picture behavior with an xy-coordinate behavior thereby giving us a shifted animation.
> demo2 = animateB "2" $ reg yellow $ tx (0, sin time) ballB
  1. We can trivially reuse the bouncing mechanism, by translating a different object with the same rotation behavior.
> demo3 = animateB "3" $ reg red $ tx (0, sin time) pentaB
  1. We can think of the color itself as a behavior and if we replace red with flash then the rendered image’s color now changes dynamically!
> demo4 = animateB "4" $ reg flash $ tx (0, sin time) ballB 
  1. Next, we can layer multiple animations by simply putting them over each other.
> demo5 = animateB "5" $ a1 `over` a2 
> where a1 = reg red $ tx (0, sin time) ballB
> a2 = reg yellow $ tx (sin time, 0) pentaB
  1. We can design a rotation combinator to rotate each individual element
> demo6 = animateB "6" $ a1 `over` a2 
> where a1 = reg red $ tx (0, sin time) ballB
> a2 = reg yellow $ lift2 turn (pi * sin time) pentaB
  1. We can even think of time as a behavior and can manipulate it. For example, here is an animation layered with itself 2 seconds in the future,
> demo7 = animateB "7" $ a1 `over` a2 
> where a1 = reg red $ tx (sin time, cos time) ballB
> a2 = timeTx (2 + time) a1
  1. Or we can speed up time (fast-forward)
> demo8 = animateB "8" $ a1 `over` a2 
> where a1 = reg red $ tx (sin time, cos time) ballB
> a2 = timeTx (2 * time) a1
  1. or slow it down (slow-motion)
> demo9 = animateB "9" $ a1 `over` a2 
> where a1 = reg red $ tx (sin time, cos time) ballB
> a2 = timeTx (0.5 * time) a1
  1. or go backwards in time (rewind)
> demo0 = animateB "0" $ a1 `over` a2 
> where a1 = reg red $ tx (sin time, cos time) ballB
> a2 = timeTx (-1 * time) a1

Pretty sweet! You can imagine a variety of other combinators for manipulating animations. Seems pretty magical doesn’t it? It turns out, its not hard, once you put on the Haskell goggles.

Our strategy for creating the DSL for animations, will be to

A Type For Behaviors

First, lets define a newtype which is basically a wrapper around the old animation type.

> newtype Behavior a = Beh (Time -> a)

There are several reasons for doing this.

  1. The typeclass instantiation is not very happy with type synonyms (we just saw an example, but that was after pleading with haskell via some command line options.) There are rather technical reasons for this, which we will avoid going into right now.

  2. More importantly, we will want to hide the actual implementation of behaviors from clients (ie make the definition private), so that they can only be constructed using the high-level operations that we provide. To use the BST example, we would want to hide the implementation of the BST to prevent a client from creating a raw BST that does not satisfy the binary-search-ordered invariant.

Now, we can easily define an animation function for this new behavior type.

> animateB ::  String -> Behavior Picture -> IO ()
> animateB s (Beh f) = animate s (picToGraphic. f)

Next, lets look at how to build our DSL for writing Behavior Picture values.

Lifting Operations To Behaviors

Remember the good old map function? It showed how to convert a function from a to b into one from [a] to [b]. We say that map lifts a function from a to b into one from lists of a to lists of b.

The notion of “lifting” is quite general (and has been studied formally.) Rather than getting too abstract, lets just replace “[]” above with Behavior and map with lift1 and we can imagine functions like

> lift1 :: (a -> b) -> Behavior a -> Behavior b
> lift1 f (Beh a) = Beh $ \t -> f (a t)

thus, lift1 lifts 1-ary functions similarly, we can lift 2-ary functions and 3-ary functions

> lift2 :: (a -> b -> c) -> Behavior a -> Behavior b -> Behavior c
> lift2 f (Beh a) (Beh b) = Beh $ \t -> f (a t) (b t)
>
> lift3 :: (a -> b -> c -> d) -> Behavior a -> Behavior b -> Behavior c -> Behavior d
> lift3 f (Beh a) (Beh b) (Beh c) = Beh $ \t -> f (a t) (b t) (c t)

What do you think lift0 might do? Yes, it just “lifts” a constant value into a behaviour that returns that value at each instant in time.

> lift0 :: a -> Behavior a
> lift0 x = Beh $ \t -> x

and a function that lifts a function over a list.

> liftXs ::  ([t] -> a) -> [Behavior t] -> Behavior a
> liftXs f bs = Beh (\t -> f (map (\(Beh b) -> b t) bs))

Now, we will make Behavior an instance of Num by simply lifting the various operations over a to Behavior a (whenever Num a holds.)

> instance Num a => Num (Behavior a) where
> (+) = lift2 (+)
> (*) = lift2 (*)
> negate = lift1 negate
> abs = lift1 abs
> signum = lift1 signum
> fromInteger = lift0 . fromInteger

We can do the same for operations defined over Fractional and Floating values.

> instance Fractional a => Fractional (Behavior a) where
> (/) = lift2 (/)
> fromRational = lift0 . fromRational
> instance Floating a => Floating (Behavior a) where
> pi = lift0 pi
> sqrt = lift1 sqrt
> exp = lift1 exp
> log = lift1 log
> sin = lift1 sin
> cos = lift1 cos
> tan = lift1 tan
> asin = lift1 asin
> acos = lift1 acos
> atan = lift1 atan
> sinh = lift1 sinh
> cosh = lift1 cosh
> tanh = lift1 tanh
> asinh = lift1 asinh
> acosh = lift1 acosh
> atanh = lift1 atanh

As a result of the above, the operations that we perform on floating point numbers (eg adding them, multiplying them, taking their sin) can be lifted to behaviors on floating point numbers. For example, if we define the behavior

> time :: Behavior Time
> time = Beh $ \t -> t

then sin time is the behavior

sin time == {- unfold overloading for time, sin -} 
lift1 sin (\t -> t)
== {- unfold definition of lift1 -}
\t -> sin ((\t -> t) t)
== {- unfold the anonymous functions -}
\t -> sin t

Similarly, we can lift the basic shape and color constructors to Behavior

> reg    = lift2 Region
> shape = lift1 Shape
> poly = liftXs Polygon
> ell = lift2 Ellipse
> red = lift0 Red
> yellow = lift0 Yellow
> green = lift0 Green
> blue = lift0 Blue
> tx (Beh a1, Beh a2) (Beh r)
> = Beh (\t -> Translate (a1 t, a2 t) (r t))

Now, we can define a simple ball and pentagon behavior

> ballB    = shape $ ell 0.2 0.2
> pentaB   = shape $ poly (map lift0 vs) 
> where vs = [ ( 0.0, 0.8)
> , ( 0.3,-0.5)
> , (-0.3,-0.5)]

we can define a function that takes any Behavior Region and makes it go around in a circle

> revolveRegion = tx (sin time, cos time) 

after which we get the spinning behaviors

> revBallB  = revolveRegion ballB
> revPentaB = revolveRegion pentaB
reg :: Behavior Color -> Behavior Region -> Behavior Picture

defined above, takes a Behavior Color and a Behavior Region and returns a Behavior Picture which is the colored version of the region, thereby allowing us build a simple atomic animation

> anim1 = animateB "Yellow Revolving Sphere" $ reg yellow revBallB

Next, we can define a multiplexer or conditional combinator for behaviors like so

> cond :: Behavior Bool -> Behavior a -> Behavior a -> Behavior a
> cond = lift3 $ \b x y -> if b then x else y

Huh? Simple. We made a function of three arguments that uses the first argument to choose between the second or third, and simply hoist it up to work over behaviors!

We can similarly lift primitive comparison operators up into Behavior land

> (>*) = lift2 (>)
> (<*) = lift2 (<)

Now, we can use these combinators to define different Behavior Bool values, and hence, get different Behavior Color values

> flash   = cond (cos time >* 0) red yellow
> flash' = cond (cos time >* 0) green blue

which we can drop into our old animation to get different color schemes!

> anim2 = animateB "Revolving Sphere" $ reg flash   revBallB
> anim3 = animateB "Revolving Sphere" $ reg flash' revBallB

Indeed, we can conditionally compose the two flashing colors, to get a four-way flash

> flash'' = cond (sin time >* 0) flash flash' 
> anim4 = animateB "Revolving Sphere" $ reg flash'' revBallB

New Typeclasses For Graphical Operations

Next, lets see how we can layer behaviors. To do so, lets define a typeclass that supports layering

> class Combine a where
> empty :: a
> over :: a -> a -> a

We can layer multiple values using the combinator

> overMany = foldr over empty

NOTE: the type for overMany, behold automatic propagation at work! We can make Picture and Behavior instances of Combine

> instance Combine Picture where
> empty = EmptyPic
> over = Over
> instance Combine a => Combine (Behavior a) where
> empty = lift0 empty
> over = lift2 over

The names are quite self-explanatory. By virtue of the above, we can use overMany to layer multiple Picture and Behavior values

> anim5 = animateB "Many Spheres" $ overMany [b1,b2,b3]
> where b1 = reg flash $ tx ((sin time)-1, cos time) ballB
> b2 = reg flash' $ tx ((sin time)+1, cos time) ballB
> b3 = reg flash'' $ tx (2 * sin time, cos time) pentaB

Similarly, we can define a richer class of operations on Shapes and lift them to behaviors

> class Deformable a where
> turn :: Float -> a -> a
> stretch :: Float -> a -> a

that is, we can turn (rotate) and stretch (resize) by some amount. For now, lets just define these for Polygons

> instance Deformable Shape where
> turn theta (Polygon ps) = Polygon (map (rotate theta) ps)
> stretch x (Polygon ps) = Polygon (map (\(a,b) -> (a*x, b*x)) ps)
>
> instance Deformable Region where
> turn theta (Shape sh) = Shape (turn theta sh)
> stretch x (Shape sh) = Shape (stretch x sh)

where the helper function rotate is defined as

> rotate :: Float -> Coordinate -> Coordinate
> rotate theta (x,y)
> = (x*c+y*s, y*c-x*s)
> where (s,c) = (sin theta, cos theta)

and lift to Pictures

> instance Deformable Picture where
> turn theta (Region c r) = Region c (turn theta r)
> turn theta (p1 `Over` p2) = turn theta p1 `Over` turn theta p2
> turn theta EmptyPic = EmptyPic
> stretch x (Region c r) = Region c (stretch x r)
> stretch x (p1 `Over` p2) = stretch x p1 `Over` stretch x p2
> stretch x EmptyPic = EmptyPic

and Behaviors

> instance Deformable a => Deformable (Behavior a) where
> turn theta (Beh b) = Beh (turn theta . b)
> stretch x (Beh b) = Beh (stretch x . b)

Now, we can pull even neater effects from our DSL

> anim6 = animateB "Pendulum" $ f pentaB
> where f = reg flash''
> . lift2 stretch (1.2 + sin time)
> . lift2 turn (pi * sin time)

Time Travel Via Time Transformation

As one last trick, let us see how we do time travel as it were, by using the following function, that translates a behavior in time.

> timeTx (Beh tb) (Beh b) = Beh (b. tb)

Lets look at the type of this function, it takes a Behavior Time and any other Behavior a, and returns a new Behavior a which is the old one translated according to the first signal! That is, at any given instant t the time behavior is used to look up a t' from which the new behavior draws its value. This can really provide for some interesting effects.

For example, to fast-forward an animation, we write a combinator

> fastForward = timeTx (2   * time)

to watch it in slow-motion

> slowMotion  = timeTx (0.5 * time)

and to rewind an animation, we might do

> rewind      = timeTx (-1  * time)

Check it out!

> anim7 = animateB "Many Spheres" $ overMany [b1,b2,b3,b4]
> where b1 = reg flash revBallB
> b2 = rewind b1
> b3 = fastForward b1
> b4 = slowMotion b1

Of course, we can apply the time transformation to the individual behaviors, for example

> anim8 = animateB "Fast Flash" $ overMany [b1,b2]
> where b1 = reg (fflash 4) $ tx ((sin time)-1, cos time) ballB
> b2 = reg (fflash 8) $ tx ((sin time)+1, cos time) ballB

where fflash is flash sped up by some factor

> fflash n = timeTx (n*time) flash''

And one last example

> anim9 = animateB "Last!" $ overMany (map stagger [0..7])
> where stagger = \t -> timeTx (lift0 (t * pi/4) + time) bB
> bB = reg (fflash 8) revBallB

Thats all for lecture, see the detailed implementation of a Kaleidoscope animation given in SOE.

Details

See the book for more info about these helper functions.

Dummy Instances for Eq and Show

We need to make Behavior a an instance of Eq and Show in order that it to satisfy the requirements of Num. Of course these operations don’t really make sense so we’ll just make a dummy instantiation.

> instance Eq (Behavior a) where
> a1 == a2 = error "Can't compare behaviors."
>
> instance Show (Behavior a) where
> showsPrec n a1 = error "<< Behavior >>"

Conversion Between Graphic Values

> regionToGraphic :: Region -> Graphic
> regionToGraphic = drawRegion . regionToGRegion
> picToGraphic :: Picture -> Graphic
> picToGraphic (Region c r)
> = withColor c (regionToGraphic r)
> picToGraphic (p1 `Over` p2)
> = picToGraphic p1 `overGraphic` picToGraphic p2
> picToGraphic EmptyPic
> = emptyGraphic

Rendering

> animate title anim = runGraphics $ do
> w <- openWindowEx title (Just (0,0)) (Just (xWin, yWin)) drawBufferedGraphic
> t0 <- timeGetTime
> animateLoop w t0 anim
> animateLoop w t0 anim = do 
> t <- timeGetTime
> let ft = intToFloat (fromInteger (toInteger (t - t0))) / 1000
> setGraphic w (anim ft)
> spaceCloseEx w $ animateLoop w t0 anim
> spaceCloseEx w loop = do 
> k <- maybeGetWindowEvent w
> case k of
> Just (Key c d) | c == ' ' && d -> closeWindow w
> Just Closed -> closeWindow w
> Nothing -> loop
> _ -> spaceCloseEx w loop