-- <pre>
import Shape
import Draw
import Region
import Picture
import SOEGraphics hiding (Region)
import qualified SOEGraphics as G (Region)
import Win32Misc (timeGetTime)
import Word (Word32)
-------------- The animation stuff ----------
word32ToInt :: Word32 -> Int
word32ToInt x = fromInteger(toInteger x)
type Animation a = Time -> a
type Time = Float
rubberBall :: Animation Shape
rubberBall t = Ellipse (sin t) (cos t)
revolvingBall :: Animation Region
revolvingBall t
 = let ball = Shape (Ellipse 0.2 0.2)
 in Translate (sin t, cos t) ball
planets :: Animation Picture
planets t
 = let p1 = Region Red (Shape (rubberBall t))
 p2 = Region Yellow (revolvingBall t)
 in p1 `Over` p2
tellTime :: Animation String
tellTime t = "The time is: " ++ show t
{-
openWindowEx :: String -> Maybe Point -> Maybe Point ->
 (Graphic -> DrawFun) -> Maybe Word32 ->
 IO Window
-}
animate :: String -> Animation a -> (a -> IO Graphic) -> IO ()
animate title anim toGraphic
 = runGraphics (
 do w <- openWindowEx title (Just (0,0)) (Just (xWin,yWin)) drawBufferedGraphic (Just 30) t0 <- timeGetTime let loop = do t <- timeGetTime -- print ("the time is" ++ (show t)) let ft = intToFloat (word32ToInt (t-t0)) / 1000 -- print "past let" gr <- toGraphic (anim ft) -- print "past toGraphic" setGraphic w gr getWindowTick w loop loop ) main1 = animate "Animation of a Shape" rubberBall (return . withColor Blue . shapeToGraphic) main2 = animate "Animated Text" tellTime (return . text (100,200)) main3 = animate "Animated Region" revolvingBall (\r -> return (withColor Yellow
 (regionToGraphic r)))
main4 = animate "Animated Picture" planets (return.picToGraphic)
main4a :: IO ()
main4a = animate "Experiment" both (return.picToGraphic)
 where both t = Over (Text (1,2) (tellTime t)) (planets t)
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 (Text v str) = (text (trans v) str)
picToGraphic EmptyPic = emptyGraphic
type Anim = Animation Picture
emptyA :: Anim
emptyA t = EmptyPic
overA :: Anim -> Anim -> Anim
overA a1 a2 t = a1 t `Over` a2 t
overManyA :: [Anim] -> Anim
overManyA = foldr overA emptyA
-- timeTransA :: (Time -> Time) -> Animation a -> Animation a
timeTransA :: Animation Time -> Animation a -> Animation a
-- timeTransA f a t = a (f t)
timeTransA f a = a . f
{-
 timeTransA (2*) anim
 timeTransA (5+) anim
 timeTransA negate anim
-}
rBall :: Anim
rBall t = let ball = Shape (Ellipse 0.2 0.2)
 in Region Red (Translate (sin t, cos t) ball)
rBalls :: Anim
rBalls = overManyA [ timeTransA ((t*pi/4)+) rBall &#124; t <- [0..7]] main5 = animate "Lots of Balls" rBalls (return . picToGraphic) ------- Type Classes and Animations --------- newtype Behavior a = Beh (Time -> a)
lift0 :: a -> Behavior a
lift0 x = Beh (\t -> x)
lift1 :: (a -> b) -> (Behavior a -> Behavior b)
lift1 f (Beh a)
 = Beh (\t -> f (a t))
lift2 :: (a -> b -> c) -> (Behavior a -> Behavior b -> Behavior c)
lift2 g (Beh a) (Beh b)
 = Beh (\t -> g (a t) (b t))
lift3 :: (a -> b -> c -> d) ->
 (Behavior a -> Behavior b -> Behavior c -> Behavior d)
lift3 g (Beh a) (Beh b) (Beh c)
 = Beh (\t -> g (a t) (b t) (c t))
instance Eq (Behavior a) where
 a1 == a2 = error "Can't compare animations."
instance Show (Behavior a) where
 showsPrec n a1 = error "Can't coerce animation to String."
instance Num a => Num (Behavior a) where
 (+) = lift2 (+); (*) = lift2 (*)
 negate = lift1 negate; abs = lift1 abs
 signum = lift1 signum
 fromInteger = lift0 . fromInteger
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
time :: Behavior Time
time = Beh (\t -> t)
instance Ani [a] where
 empty = []
 over = (++)
instance Ani (Fun a) where
 empty = Fun id
 Fun a `over` Fun b = Fun (a . b)
data Fun a = Fun (a->a)
class Ani a where
 empty :: a
 over :: a -> a -> a
instance Ani a => Ani (Float -> a) where
 empty t = empty
 over f g t = over (f t) (g t)
instance Ani Picture where
 empty = EmptyPic
 over = Over
instance Ani a => Ani (Behavior a) where
 empty = lift0 empty
 over = lift2 over
overMany :: Ani a => [a] -> a
overMany = foldr over empty
m :: Behavior Picture
m = let a = lift0 (empty `over` p)
 in a `over` empty
p :: Picture
p = empty
timeTrans (Beh t) (Beh a) = Beh (timeTransA t a)
reg = lift2 Region
shape = lift1 Shape
ell = lift2 Ellipse
red = lift0 Red
blue = lift0 Blue
translate (Beh a1, Beh a2) (Beh p)
 = Beh (\t -> Translate (a1 t, a2 t) (p t))
rBall2 :: Behavior Picture
rBall2
 = let ball = shape (ell 0.2 0.2)
 in reg red (translate (sin time, cos time) ball)
(>*) :: Ord a => Behavior a -> Behavior a -> Behavior Bool
(>*) = lift2 (>)
ifFun :: Bool -> a -> a -> a
ifFun p c a = if p then c else a
cond :: Behavior Bool -> Behavior a -> Behavior a -> Behavior a
cond = lift3 ifFun
rb :: Behavior Color
rb = cond (sin time>* 0) red blue
animate2 :: String -> Behavior Picture -> IO ()
animate2 s (Beh pf) =
 animate s pf (return . picToGraphic)
main6 = animate2 "Wild" rBall2
----- Kaleidoscope example
class Turnable a where
 turn :: Float -> a -> a
instance Turnable Picture where
 turn theta (Region c r) = Region c (turn theta r) -- turn on Regions
 turn theta (p1 `Over` p2) = turn theta p1 `Over` turn theta p2
 turn theta EmptyPic = EmptyPic
instance Turnable a => Turnable (Behavior a) where
 turn theta (Beh b) = Beh(turn theta . b)
rotate :: Float -> Coordinate -> Coordinate
rotate theta (x,y) =
 (x*c + y*s, y*c - x*s)
 where (s,c) = (sin theta,cos theta)
instance Turnable Shape where
 turn theta (Polygon ps) = Polygon (map (rotate theta) ps)
 -- lots of missing cases here for
 -- turn theta (Rectangle s1 s2) =
 -- turn theta (Ellipse r1 r2) =
 -- turn theta (RtTriangle s1 s2) =
instance Turnable Region where
 turn theta (Shape sh) = Shape (turn theta sh)
 -- lots of missing cases here for
 -- turn theta (Translate (u,v) r) =
 -- turn theta (Scale (u,v) r) =
 -- turn theta (Complement r) =
 -- turn theta (r1 `Union` r2) =
 -- turn theta (r1 `Intersect` r2) =
 -- turn theta Empty = Empty
spectrum = [ c &#124; c <- [minBound..], c/= Black] -- All colors but black slowTime = 0.1 * time kaleido :: Integer -> (Float -> Behavior Coordinate) -> Behavior Picture
kaleido n f =
 lift2 turn (pi * sin slowTime)
 (overMany (zipWith reg (map lift0 (cycle spectrum))
 (map (flip turn poly) rads)))
 where rads = map (((2 * pi/fromInteger n)*).fromInteger) [0..n-1]
 poly = polyShapeAnim (map f rads)
polyShapeAnim :: [Behavior Coordinate] -> Behavior Region
polyShapeAnim = lift1 (Shape . Polygon).synclist
 where synclist :: [Behavior a] -> Behavior[a]
 synclist l = Beh(\t -> map (\(Beh f) -> f t) l)
syncPair :: (Behavior a,Behavior b) -> Behavior(a,b)
syncPair (Beh f,Beh g) = Beh(\t -> (f t,g t))
kaleido1 = kaleido 6 star
 where star x = syncPair (2*cos(v*c+l),2 * abs(sin(slowTime * s - l)))
 where v = lift0 x
 l = v * (slowTime + 1)
 (s,c) = (sin l,cos l)
animateB :: String -> Behavior Picture -> IO ()
animateB s (Beh x) = animate s x
 (return . picToGraphic)
main7 = animateB "kaleido1" kaleido1
-- </pre>
</div><div class="naked_ctrl">
<form action="/index.cgi/contrast" method="get" name="gate">
<p><a href="http://altstyle.alfasado.net">AltStyle</a> によって変換されたページ <a href="http://web.cecs.pdx.edu/~sheard/course/funprog/lecturenotes/lect13.html">(-&gt;オリジナル)</a>
/ <label>アドレス: <input type="text" name="naked_post_url" value="http://web.cecs.pdx.edu/~sheard/course/funprog/lecturenotes/lect13.html" size="22" /></label> <label>モード: <select name="naked_post_mode">
<option value="default">デフォルト</option>
<option value="speech">音声ブラウザ</option>
<option value="ruby">ルビ付き</option>
<option value="contrast" selected="selected">配色反転</option>
<option value="larger-text">文字拡大</option>
<option value="mobile">モバイル</option>
</select>
<input type="submit" value="表示" />
</p>
</form>
</div>