-- <pre>
import Draw
import Region
import SOEGraphics hiding (Region)
import qualified SOEGraphics as G (Region)
data Picture = Region Color Region
 &#124; Picture `Over` Picture
 &#124; EmptyPic
 deriving Show
-- The Color type is imported from SOEGraphics
-- and Exported from Picture
-- data Color = Black &#124; Blue &#124; Green &#124; Cyan
-- &#124; Red &#124; Magenta &#124; Yellow &#124; White
------ Changes here --------
drawRegionInWindow::Window -> Color -> Region -> IO ()
drawRegionInWindow w c r =
 drawInWindow w
 (withColor c (drawRegion (regionToGRegion r)))
----------- End Changes ------------------
drawPic :: Window -> Picture -> IO ()
drawPic w (Region c r) = drawRegionInWindow w c r
drawPic w (p1 `Over` p2) = do { drawPic w p2
 ; drawPic w p1
 }
drawPic w EmptyPic = return ()
-- First a little side trip
data NewRegion = Rect Side Side -- Abstracts G.Region
regToNReg1 :: Region -> NewRegion
regToNReg1 (Shape (Rectangle sx sy))
 = Rect sx sy
regToNReg1 (Scale (x,y) r)
 = regToNReg1 (scaleReg (x,y) r)
 where scaleReg (x,y) (Shape (Rectangle sx sy))
 = Shape (Rectangle (x*sx) (y*sy))
 scaleReg (x,y) (Scale s r)
 = Scale s (scaleReg (x,y) r)
reverse1 [] = []
reverse1 (x:xs) = (reverse1 xs) ++ [x]
 where [] ++ zs = zs
 (y:ys) ++ zs = y : (ys ++ zs)
reverse2 xs = revhelp xs []
 where revhelp [] zs = zs
 revhelp (x:xs) zs = revhelp xs (x:zs)
regToNReg2 :: Region -> NewRegion
regToNReg2 r = rToNR (1,1) r
 where rToNR :: (Float,Float) -> Region -> NewRegion
 rToNR (x1,y1) (Shape (Rectangle sx sy))
 = Rect (x1*sx) (y1*sy)
 rToNR (x1,y1) (Scale (x2,y2) r)
 = rToNR (x1*x2,y1*y2) r
--- Return from side trip
regToGReg1 :: Vector -> Vector -> Region -> G.Region
regToGReg1 trans sca (Shape s) = shapeToGRegion trans sca s
regToGReg1 (x,y) sca (Translate (u,v) r)
 = regToGReg1 (x+u, y+v) sca r
regToGReg1 trans (x,y) (Scale (u,v) r)
 = regToGReg1 trans (x*u, y*v) r
regToGReg1 trans sca Empty = createRectangle (0,0) (0,0)
regToGReg1 trans sca (r1 `Union` r2)
 = let gr1 = regToGReg1 trans sca r1
 gr2 = regToGReg1 trans sca r2
 in orRegion gr1 gr2
---------- Changes here ------------
primGReg trans sca r1 r2 op
 = let gr1 = regToGReg trans sca r1
 gr2 = regToGReg trans sca r2
 in op gr1 gr2
regToGReg :: Vector -> Vector -> Region -> G.Region
regToGReg (trans @ (x,y)) (sca @ (a,b)) shape =
 case shape of
 (Shape s) -> shapeToGRegion trans sca s
 (Translate (u,v) r) -> regToGReg (x+u, y+v) sca r
 (Scale (u,v) r) -> regToGReg trans (a*u, b*v) r
 (Empty) -> createRectangle (0,0) (0,0)
 (r1 `Union` r2) -> primGReg trans sca r1 r2 orRegion
 (r1 `Intersect` r2) -> primGReg trans sca r1 r2 andRegion
 (Complement r) -> primGReg trans sca winRect r diffRegion
 where winRect :: Region
 winRect = Shape (Rectangle
 (pixelToInch xWin) (pixelToInch yWin))
regionToGRegion :: Region -> G.Region
regionToGRegion r = regToGReg (0,0) (1,1) r
----------- End Changes -----------------
xWin2 = xWin `div` 2
yWin2 = yWin `div` 2
shapeToGRegion1
 :: Vector -> Vector -> Shape -> G.Region
shapeToGRegion1 (lx,ly) (sx,sy) (Rectangle s1 s2)
 = createRectangle (trans(-s1/2,-s2/2)) (trans (s1/2,s2/2))
 where trans (x,y) = ( xWin2 + inchToPixel ((x+lx)*sx),
 yWin2 - inchToPixel ((y+ly)*sy) )
shapeToGRegion1 (lx,ly) (sx,sy) (Ellipse r1 r2)
 = createEllipse (trans (-r1,-r2)) (trans ( r1, r2))
 where trans (x,y) =
 ( xWin2 + inchToPixel ((x+lx)*sx),
 yWin2 - inchToPixel ((y+ly)*sy) )
shapeToGRegion1 (lx,ly) (sx,sy) (Polygon pts)
 = createPolygon (map trans pts)
 where trans (x,y) =
 ( xWin2 + inchToPixel ((x+lx)*sx),
 yWin2 - inchToPixel ((y+ly)*sy) )
shapeToGRegion1 (lx,ly) (sx,sy) (RtTriangle s1 s2) =
 createPolygon (map trans [(0,0),(s1,0),(0,s2)])
 where trans (x,y) =
 ( xWin2 + inchToPixel ((x+lx)*sx),
 yWin2 - inchToPixel ((y+ly)*sy) )
shapeToGRegion (lx,ly) (sx,sy) s =
 case s of
 Rectangle s1 s2 -> createRectangle
 (trans (-s1/2,-s2/2))
 (trans (s1/2,s2/2))
 Ellipse r1 r2 -> createEllipse
 (trans (-r1,-r2))
 (trans ( r1, r2))
 Polygon pts -> createPolygon (map trans pts)
 RtTriangle s1 s2 -> createPolygon
 (map trans [(0,0),
 (s1,0),
 (0,s2)])
 where trans (x,y) = ( xWin2 + inchToPixel ((x+lx)*sx),
 yWin2 - inchToPixel ((y+ly)*sy) )
 -- IMPORTANT that the WHERE be indented less than the patterns
 -- of the case. Because it then attaches to the last clause of
 -- the case rather than the defining equation. Since the Draw
 -- defines a trans function (with the right type) but the wrong
 -- functionality, the other clauses of the case appear well defined
 -- but do very strange things.
draw :: Picture -> IO ()
draw p
 = runGraphics (
 do w <- openWindow "Region Test" (xWin,yWin) drawPic w p spaceClose w ) r1 = Shape (Rectangle 3 2) r2 = Shape (Ellipse 1 1.5) r3 = Shape (RtTriangle 3 2) r4 = Shape (Polygon [(-2.5,2.5), (-3.0,0), (-1.7,-1.0), (-1.1,0.2), (-1.5,2.0)] ) reg1 = r3 `Union` --RtTriangle r1 `Intersect` -- Rectangle Complement r2 `Union` -- Ellispe r4 -- Polygon pic1 = Region Cyan reg1 main1 = draw pic1 reg2 = let circle = Shape (Ellipse 0.5 0.5) square = Shape (Rectangle 1 1) in (Scale (2,2) circle) `Union` (Translate (2,1) square) `Union` (Translate (-2,0) square) pic2 = Region Yellow reg2 main2 = draw pic2 pic3 = pic2 `Over` pic1 main3 = draw pic3 oneCircle = Shape (Ellipse 1 1) manyCircles = [ Translate (x,0) oneCircle &#124; x <- [0,2..] ] fiveCircles = foldr Union Empty (take 5 manyCircles) pic4 = Region Magenta (Scale (0.25,0.25) fiveCircles) main4 = draw pic4 x0 = Region Magenta oneCircle x1 = Region Magenta (Scale (0.25,0.25) oneCircle) ---- Ordering Pictures pictToList :: Picture -> [(Color,Region)]
pictToList EmptyPic = []
pictToList (Region c r) = [(c,r)]
pictToList (p1 `Over` p2)
 = pictToList p1 ++ pictToList p2
pic6 = pic4 `Over` pic2 `Over` pic1 `Over` pic3
zz = pictToList pic6
-- [(Magenta,?), (yellow,?),(Cyan,?),(Cyan,?)]
adjust :: [(Color,Region)] -> Vertex ->
 (Maybe (Color,Region), [(Color,Region)])
adjust [] p = (Nothing, [])
adjust ((c,r):regs) p =
 if r `containsR` p
 then (Just (c,r), regs)
 else let (hit, rs) = adjust regs p
 in (hit, (c,r) : rs)
adjust2 regs p
 = case (break (\(_,r) -> r `containsR` p) regs) of
 (top,hit:rest) -> (Just hit, top++rest)
 (_,[]) -> (Nothing, [])
loop :: Window -> [(Color,Region)] -> IO ()
loop w regs =
 do clearWindow w
 sequence [ drawRegionInWindow w c r &#124;
 (c,r) <- reverse regs ] (x,y) <- getLBP w print "Before adjust\n" case (adjust2 regs (pixelToInch (x - xWin2), pixelToInch (yWin2 - y) )) of (Nothing, _ ) -> do { print "Nothing"; closeWindow w }
 (Just hit, newRegs) -> do { print "after adjust"
 ; loop w (hit : newRegs) }
draw2 :: Picture -> IO ()
draw2 pic
 = runGraphics (
 do w <- openWindow "Picture demo" (xWin,yWin) loop w (pictToList pic)) p1,p2,p3,p4 :: Picture p1 = Region Magenta r1 p2 = Region Cyan r2 p3 = Region Green r3 p4 = Region Yellow r4 pic :: Picture pic = foldl Over EmptyPic [p1,p2,p3,p4] main5 = draw2 pic loop2 w regs = do clearWindow w sequence [ drawRegionInWindow w c r &#124; (c,r) <- reverse regs ] (x,y) <- getLBP w let aux (_,r) = r `containsR` ( pixelToInch (x-xWin2), pixelToInch (yWin2-y) ) case (break aux regs) of (_,[]) -> closeWindow w
 (top,hit:bot) -> loop w (hit : (top++bot))
draw3 :: Picture -> IO ()
draw3 pic
 = runGraphics (
 do w <- openWindow "Picture demo" (xWin,yWin) loop2 w (pictToList pic) ) main6 = draw3 pic -- </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/lect09.html">(-&gt;オリジナル)</a>
/ <label>アドレス: <input type="text" name="naked_post_url" value="http://web.cecs.pdx.edu/~sheard/course/funprog/lecturenotes/lect09.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>