-- <pre>
module Fal where
import SOEGraphics hiding (Point, Region, Event)
import qualified SOEGraphics as G (Point, Region, Event)
import Draw
import Shape
import Region
import Picture
import Animation(picToGraphic)
import Memo
-- import Drawing (xWin,yWin,intToFloat)
import Win32Misc (timeGetTime)
import Word (word32ToInt)
import Channel
infixl 2 =>>, ->>
infixl 1 `switch`, `stepAccum`, `step`
infixl 0 .&#124;.
infixr 4 <*,>*
infixr 3 &&*
infixr 2 &#124;&#124;*
type Time = Float
type UserAction = G.Event
newtype Behavior1 a
 = Behavior1 ([(UserAction,Time)] -> Time -> a)
inList :: [Int] -> Int -> Bool
inList xs y = elem y xs
result1 :: [Bool]
result1 = map (inList xs) ys
xs = [2,4,6,8,10] :: [Int]
ys = [3,6,9] :: [Int]
result2 :: [Bool]
result2 = manyInList xs ys
manyInList :: [Int] -> [Int] -> [Bool]
manyInList [] _ = []
manyInList _ [] = []
manyInList (x:xs) (y:ys) =
 if y<x then manyInList xs (y:ys) else (y==x) : manyInList (x:xs) ys newtype Behavior2 a = Behavior2 ([(UserAction,Time)] -> [Time] -> [a])
newtype Behavior3 a
 = Behavior3 ([UserAction] -> [Time] -> [a])
newtype Behavior4 a
 = Behavior4 ([Maybe UserAction] -> [Time] -> [a])
newtype Behavior a
 = Behavior (([Maybe UserAction],[Time]) -> [a])
newtype Event a
 = Event (([Maybe UserAction],[Time]) -> [Maybe a])
-- Event a =iso= Behavior (Maybe a)
time :: Behavior Time
time = Behavior (\(_,ts) -> ts)
constB :: a -> Behavior a
constB x = Behavior (\_ -> repeat x)
($*) :: Behavior (a->b) -> Behavior a -> Behavior b
Behavior ff $* Behavior fb
 = Behavior (\uts -> zipWith ($) (ff uts) (fb uts))
lift0 :: a -> Behavior a
lift0 = constB
lift1 :: (a -> b) -> (Behavior a -> Behavior b)
lift1 f b1
 = lift0 f $* b1
lift2 :: (a -> b -> c) -> (Behavior a -> Behavior b -> Behavior c)
lift2 f b1 b2
 = lift1 f b1 $* b2
lift3 :: (a -> b -> c -> d) ->
 (Behavior a -> Behavior b -> Behavior c -> Behavior d)
lift3 f b1 b2 b3
 = lift2 f b1 b2 $* b3
pairB :: Behavior a -> Behavior b -> Behavior (a,b)
pairB = lift2 (,)
fstB :: Behavior (a,b) -> Behavior a
fstB = lift1 fst
sndB :: Behavior (a,b) -> Behavior b
sndB = lift1 snd
--- COLORS -----
red, blue, yellow, green, white :: Behavior Color
red = lift0 Red
blue = lift0 Blue
yellow = lift0 Yellow
green = lift0 Green
white = lift0 White
--- Shapes, Regions, and Pictures
shape :: Behavior Shape -> Behavior Region
shape = lift1 Shape
region ::Behavior Color -> Behavior Region -> Behavior Picture
region = lift2 Region
wordPic str pos = lift2 Text pos str
showPic n pos = lift2 Text pos (lift1 show n)
ell, rec :: Behavior Float -> Behavior Float -> Behavior Region
ell x y = shape (lift2 Ellipse x y)
rec x y = shape (lift2 Rectangle x y)
translate :: (Behavior Float, Behavior Float)
 -> Behavior Region -> Behavior Region
translate (Behavior fx, Behavior fy) (Behavior fp)
 = Behavior (\uts -> zipWith3 aux (fx uts) (fy uts) (fp uts))
 where aux x y p = Translate (x,y) p
paint :: Behavior Color -> Behavior Region -> Behavior Picture
paint = lift2 Region
over :: Behavior Picture -> Behavior Picture -> Behavior Picture
over = lift2 Over
--- Lifted OPERATORS ----
(>*),(<*), (>=*), (<=*) :: Ord a => Behavior a -> Behavior a -> Behavior Bool
(>*) = lift2 (>)
(<*) = lift2 (<) (<=*) = lift2 (<=) (>=*) = lift2 (>=)
(&&*),(&#124;&#124;*) :: Behavior Bool -> Behavior Bool -> Behavior Bool
(&&*) = lift2 (&&)
(&#124;&#124;*) = lift2 (&#124;&#124;)
instance Fractional a => Fractional (Behavior a) where
 (/) = lift2 (/)
 fromRational = lift0 . fromRational
instance Num a => Num (Behavior a) where
 (+) = lift2 (+)
 (*) = lift2 (*)
 negate = lift1 negate
 abs = lift1 abs
 signum = lift1 signum
 fromInteger = lift0 . fromInteger
instance Show (Behavior a) where
 showsPrec n a s = "<< Behavior>>"
instance Eq (Behavior a) where
 a1 == a2 = error "Can't compare behaviors."
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
--- Simple or Primitive EVENTS
lbp :: Event ()
lbp = Event (\(uas,_) -> map getlbp uas)
 where getlbp (Just (Button _ True True)) = Just ()
 getlbp _ = Nothing
rbp :: Event ()
rbp = Event (\(uas,_) -> map getrbp uas)
 where getrbp (Just (Button _ False True)) = Just ()
 getrbp _ = Nothing
key :: Event Char
key = Event (\(uas,_) -> map getkey uas)
 where getkey (Just (Key ch True)) = Just ch
 getkey _ = Nothing
mm :: Event Vertex
mm = Event (\(uas,_) -> map getmm uas)
 where getmm (Just (MouseMove pt)) = Just (gPtToPt pt)
 getmm _ = Nothing
gPtToPt :: G.Point -> Vertex
gPtToPt (x,y) = ( pixelToInch (x - 300)
 , pixelToInch (250 - y) )
mouse :: (Behavior Float, Behavior Float)
mouse = (fstB m, sndB m)
 where m = (0,0) `step` mm
---- Behavior and Event Combinators ---
switch :: Behavior a -> Event (Behavior a) -> Behavior a
Behavior fb `switch` Event fe =
 memoB $ Behavior (\uts@(us,ts) -> loop us ts (fe uts) (fb uts))
 where loop (_:us) (_:ts) ~(e:es) (b:bs) =
 b : case e of
 Nothing -> loop us ts es bs
 Just (Behavior fb') -> loop us ts es (fb' (us,ts))
memoB :: Behavior a -> Behavior a
memoB (Behavior fb) = Behavior (memo1 fb)
(=>>) :: Event a -> (a->b) -> Event b
Event fe =>> f = Event (\uts -> map aux (fe uts))
 where aux (Just a) = Just (f a)
 aux Nothing = Nothing
-- Event fe =>> f = Event (map (map f) . fe)
e ->> v = e =>> \_ -> v
withElem :: Event a -> [b] -> Event (a,b)
withElem (Event fe) bs = Event (\uts -> loop (fe uts) bs)
 where loop (Just a : evs) (b:bs) = Just (a,b) : loop evs bs
 loop (Nothing : evs) bs = Nothing : loop evs bs
withElem_ :: Event a -> [b] -> Event b
withElem_ e bs = e `withElem` bs =>> snd
(.&#124;.) :: Event a -> Event a -> Event a
Event fe1 .&#124;. Event fe2
 = Event (\uts -> zipWith aux (fe1 uts) (fe2 uts))
 where aux Nothing Nothing = Nothing
 aux (Just x) _ = Just x
 aux _ (Just x) = Just x
snapshot :: Event a -> Behavior b -> Event (a,b)
Event fe `snapshot` Behavior fb
 = Event (\uts -> zipWith aux (fe uts) (fb uts))
 where aux (Just x) y = Just (x,y)
 aux Nothing _ = Nothing
snapshot_ :: Event a -> Behavior b -> Event b
snapshot_ e b = e `snapshot` b =>> snd
step :: a -> Event a -> Behavior a
a `step` e = constB a `switch` e =>> constB
stepAccum :: a -> Event (a->a) -> Behavior a
a `stepAccum` e = b
 where b = a `step` (e `snapshot` b =>> uncurry ($))
counter = 0 `stepAccum` lbp ->> (+1)
test1 = let Behavior fb = counter
 in take 20 (fb (uas,ts))
predicate :: Behavior Bool -> Event ()
predicate (Behavior fb)
 = Event (\uts -> map aux (fb uts))
 where aux True = Just ()
 aux False = Nothing
integral :: Behavior Float -> Behavior Float
integral (Behavior fb)
 = Behavior (\uts@(us,t:ts) -> 0 : loop t 0 ts (fb uts))
 where loop t0 acc (t1:ts) (a:as)
 = let acc' = acc + (t1-t0)*a
 in acc' : loop t1 acc' ts as
--- INTERFACE TO THE WINDOW AND USER
reactimate :: String -> Behavior a -> (a -> IO Graphic) -> IO ()
reactimate title franProg toGraphic
 = runGraphics $
 do w <- openWindowEx title (Just (0,0)) (Just (xWin,yWin)) drawBufferedGraphic (Just 30) (us,ts,addEvents) <- windowUser w addEvents let drawPic (Just p) = do g <- toGraphic p setGraphic w g addEvents getWindowTick w drawPic Nothing = return () let Event fe = sample `snapshot_` franProg mapM_ drawPic (fe (us,ts)) sample :: Event () sample = Event (\(us,_) -> map aux us)
 where aux Nothing = Just ()
 aux (Just _) = Nothing
windowUser :: Window -> IO ([Maybe UserAction], [Time], IO ())
windowUser w
 = do (evs, addEv) <- makeStream t0 <- timeGetTime let addEvents = let loop rt = do mev <- maybeGetWindowEvent w case mev of Nothing -> return ()
 Just e -> addEv (rt, Just e)>> loop rt
 in do t <- timeGetTime let rt = w32ToTime (t-t0) loop rt addEv (rt, Nothing) return (map snd evs, map fst evs, addEvents) w32ToTime t = intToFloat (word32ToInt t) / 1000 makeStream :: IO ([a], a -> IO ())
makeStream = do
 ch <- newChan contents <- getChanContents ch return (contents, writeChan ch) ---- PADDLE BALL EXAMPLE paddleball vel = walls `over` paddle `over` ball vel main = test (paddleball 1) walls = let upper = paint blue (translate ( 0,1.7) (rec 4.4 0.05)) left = paint blue (translate (-2.2,0) (rec 0.05 3.4)) right = paint blue (translate ( 2.2,0) (rec 0.05 3.4)) in upper `over` left `over` right paddle = paint red (translate (fst mouse, -1.7) (rec 0.5 0.05)) ball vel = let xvel = vel `stepAccum` xbounce ->> negate
 xpos = integral xvel
 xbounce = predicate (xpos>* 2 &&* xvel>* 0
 &#124;&#124;* xpos <* -2 &&* xvel <* 0) yvel = vel `stepAccum` ybounce ->> negate
 ypos = integral yvel
 roofbounce = ypos>* 1.5 &&* yvel>* 0
 paddlebounce = (ypos `between` (-2.0,-1.5)) &&*
 (fst mouse `between` (xpos-0.25,xpos+0.25)) &&*
 (yvel <* 0) ybounce = predicate (roofbounce &#124;&#124;* paddlebounce) in (paint yellow (translate (xpos, ypos) (ell 0.2 0.2))) x `between` (a,b) = x>* a &&* x <* b ------ Examples test beh = reactimate "FAL Test" beh (return . picToGraphic) color0 :: Behavior Color color0 = red `switch` lbp ->> blue
color1 = red `switch` (lbp `withElem_` cycle [blue,red])
color2 = red `switch` (lbp ->> blue .&#124;. key ->> yellow)
color3 = white `switch` (key =>> \c ->
 case c of 'r' -> red
 'b' -> blue
 'y' -> yellow
 _ -> white )
color4 = white `switch` (key `snapshot` color4 =>> \(c,old) ->
 case c of 'r' -> red
 'b' -> blue
 'y' -> yellow
 _ -> constB old)
color5 = red `switch` predicate (time>* 5) ->> blue
uas = cycle [Nothing, Just (Button (0,0) True True), Nothing]
ts = [1,2 ..] :: [Time]
test0 = let Behavior fb = color0
 in take 3 (fb (uas,ts))
ball1 = paint color4 circle1
circle1 = translate mouse (ell 0.2 0.2)
cball0 = paint color0 circle0
cball1 = paint color1 circle0
cball2 = paint color2 circle0
cball3 = paint color3 circle0
cball4 = paint color4 circle0
circle0 = translate (cos time, sin time) (ell 0.2 0.2)
--- Ball falling under gravity
ball2 = paint red (translate (0,y) (ell 0.2 0.2))
 where g = -1
 y = 1.5 + integral v
 v = integral g `switch` (hit `snapshot_` v =>> \v->
 lift0 (-v) + integral g)
 hit = predicate (y <* -1.5 &&* v <* 0) ------------------------------------------------------------------ -- type "test exN" to run example N dot = (ell 0.2 0.2) ex1 = paint red (translate (0, time / 2) dot) ex2 = paint blue (translate (sin time,cos time) dot) wander x y color = paint color (translate (x,y) dot) ex3 = wander (time /2) (sin time) red modula x y = (period,w) where (whole,fract) = properFraction x n = whole `mod` y period = (whole `div` y) w = (fromInt (toInt n)) + fract bounce t = f fraction where (period,fraction) = modula t 2 f = funs !! (period `mod` 4) funs = [id,(2.0 -),negate,(\x -> x - 2.0)]
ex4 = wander (lift1 bounce time) 0 yellow
moon = (translate (sin time,cos time) dot)
ex5 = paint color0 moon
ex6 = paint color1 moon
ex7 = paint color2 moon
ex8 = paint color3 moon
ex9 = paint color4 moon
growCircle :: Char -> Region
growCircle x = Shape(Ellipse (size x) (size x))
size '2' = 0.2 -- size :: Char -> Float
size '3' = 0.4
size '4' = 0.6
size '5' = 0.8
size '6' = 1.0
size '7' = 1.2
size '8' = 1.4
size '9' = 1.6
size _ = 0.1
ex10 = paint red (Shape(Ellipse 1 1)
 `step` (key =>> growCircle))
power2 :: Event(Float -> Float)
power2 = (lbp ->> \ x -> x*2) .&#124;.
 (rbp ->> \ x -> x * 0.5)
dynSize = 1.0 `stepAccum` power2
ex11 = paint red (ell dynSize dynSize)
ex12 = wander x 0 yellow
 where xvel = 1 `stepAccum` (hit ->> negate)
 x = integral xvel
 left = x <=* -2.0 &&* xvel <*0 right = x>=* 2.0 &&* xvel>*0
 hit = predicate (left &#124;&#124;* right)
mouseDot =
 mm =>> \ (x,y) ->
 translate (constB x,constB y)
 dot
ex13 = paint red (dot `switch` mouseDot)
main1 = test ex1
main2 = test ex2
main3 = test ex3
main4 = test ex4
main5 = test ex5
main6 = test ex6
main7 = test ex7
main8 = test ex8
main9 = test ex9
main10 = test ex10
main11 = test ex11
main12 = test ex12
main13 = test ex13
main14 = test paddle
main15 = main
-- </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/lect15.html">(-&gt;オリジナル)</a>
/ <label>アドレス: <input type="text" name="naked_post_url" value="http://web.cecs.pdx.edu/~sheard/course/funprog/lecturenotes/lect15.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>