続・Haskellで図形言語
高階関数版とWindowsSizeが可変しても、サイズに合うように。
--waveModify.hs --SICP 図形言語 --Window Sizeが可変可能であることに対応 --高階関数版 import Vector import Graphics.UI.Gtk as Gtk import Graphics.Rendering.Cairo as Cairo data Frame = Frame { origin :: Vector.Vector2d, edge1 :: Vector.Vector2d, edge2 :: Vector.Vector2d } deriving (Show) data Segment = Segment { start :: Vector.Vector2d, end :: Vector.Vector2d } deriving (Show) type Painter = Main.Frame -> Cairo.Render() -- segmentの座標系とdrawAreaの座標系はyの向きが違うので…。 makeDrawFrame :: Double -> Double -> Main.Frame makeDrawFrame witdh height = Main.Frame { origin = makeVector2d 0 height, edge1 = makeVector2d witdh 0, edge2 = makeVector2d 0 (-height) } makeSegment :: Vector2d -> Vector2d -> Segment makeSegment s e = Segment { start = s, end = e } -- frame-coord-map mapVectorToFrameCoord :: Main.Frame -> Vector2d -> Vector2d mapVectorToFrameCoord frame vector = origin frame + Vector.scale (xcor vector) (edge1 frame) + Vector.scale (ycor vector) (edge2 frame) -- segments->painter segmentsToPainter :: [Segment] -> Painter segmentsToPainter segments frame = do mapM_ (\s -> Main.drawLine (mapVectorToFrameCoord frame $ start s) (mapVectorToFrameCoord frame $ end s)) segments -- transform-painter transformPainter :: Painter -> Vector2d -> Vector2d -> Vector2d -> Painter transformPainter painter origin corner1 corner2 baseFrame = painter newFrame where mapToBaseFrame = mapVectorToFrameCoord baseFrame newOrigin = mapToBaseFrame origin newFrame = Main.Frame { origin = newOrigin, edge1 = mapToBaseFrame corner1 - newOrigin, edge2 = mapToBaseFrame corner2 - newOrigin } -- flip-vert flipVert :: Painter -> Painter flipVert painter = transformPainter painter (makeVector2d 0.0 1.0) (makeVector2d 1.0 1.0) (makeVector2d 0.0 0.0) -- flip-horiz (ex 2.50) flipHoriz :: Painter -> Painter flipHoriz painter = transformPainter painter (makeVector2d 1.0 0.0) (makeVector2d 0.0 0.0) (makeVector2d 1.0 1.0) -- shrink-to-upper-right shrinkToUpperRight :: Painter -> Painter shrinkToUpperRight painter = transformPainter painter (makeVector2d 0.5 0.5) (makeVector2d 1.0 0.5) (makeVector2d 0.5 1.0) -- rotate90 rotate90 :: Painter -> Painter rotate90 painter = transformPainter painter (makeVector2d 1.0 0.0) (makeVector2d 1.0 1.0) (makeVector2d 0.0 0.0) -- rotate180 (ex 2.50) rotate180 :: Painter -> Painter rotate180 = rotate90 . rotate90 -- rotate270 (ex 2.50) rotate270 :: Painter -> Painter rotate270 = rotate180 . rotate90 -- squash-inwards squashInwards :: Painter -> Painter squashInwards painter = transformPainter painter (makeVector2d 0.0 0.0) (makeVector2d 0.65 0.35) (makeVector2d 0.35 0.65) -- beside beside :: Painter -> Painter -> Painter beside leftp' rightp' frame = do let splitPoint = makeVector2d 0.5 0.0 leftp = transformPainter leftp' (makeVector2d 0.0 0.0) splitPoint (makeVector2d 0.0 1.0) rightp = transformPainter rightp' splitPoint (makeVector2d 1.0 0.0) (makeVector2d 0.5 1.0) leftp frame rightp frame -- below (ex 2.51 ans2) below :: Painter -> Painter -> Painter below bottomp' topp' frame = rotate90 (beside (rotate270 bottomp') (rotate270 topp')) frame identity :: Painter -> Painter identity painter = painter -- square-of-four squareOfFour :: (Painter -> Painter) -> (Painter -> Painter) -> (Painter -> Painter) -> (Painter -> Painter) -> Painter -> Painter squareOfFour tl tr bl br painter = below bottom top where top = beside (tl painter) (tr painter) bottom = beside (bl painter) (br painter) -- flipped-pairs flippedPairs :: Painter -> Painter flippedPairs painter = combine4 painter where combine4 = squareOfFour identity flipVert identity flipVert -- split (ex 2.45) split :: (Painter -> Painter -> Painter) -> (Painter -> Painter -> Painter) -> Painter -> Int -> Painter split origSide splitedSide painter n | n > 0 = origSide painter $ splitedSide smaller smaller | otherwise = painter where smaller = split origSide splitedSide painter $ n-1 -- right-split (ex 2.45) rightSplit :: Painter -> Int -> Painter rightSplit = split beside below -- up-split (ex 2.45) upSplit :: Painter -> Int -> Painter upSplit = split below beside -- corner-split cornerSplit :: Painter -> Int -> Painter cornerSplit painter n | n > 0 = beside (below painter topLeft) (below bottomRight corner) | otherwise = painter where up = upSplit painter (n-1) right = rightSplit painter (n-1) topLeft = beside up up bottomRight = below right right corner = cornerSplit painter (n-1) -- split-limit splitLimit :: Painter -> Int -> Painter splitLimit painter n = combine4 $ cornerSplit painter n where combine4 = squareOfFour flipHoriz identity rotate180 flipVert crossSegments :: [Segment] crossSegments = [ makeSegment (makeVector2d 0 0) (makeVector2d 1 1), makeSegment (makeVector2d 1 0) (makeVector2d 0 1) ] crossPainter :: Painter crossPainter = do segmentsToPainter crossSegments diaSegments :: [Segment] diaSegments = [ makeSegment (makeVector2d 0.5 0.0) (makeVector2d 1.0 0.5), makeSegment (makeVector2d 1.0 0.5) (makeVector2d 0.5 1.0), makeSegment (makeVector2d 0.5 1.0) (makeVector2d 0.0 0.5), makeSegment (makeVector2d 0.0 0.5) (makeVector2d 0.5 0.0) ] diaPainter :: Painter diaPainter = do segmentsToPainter diaSegments waveSegments = [ makeSegment (makeVector2d 0.0 0.65) (makeVector2d 0.15 0.4), makeSegment (makeVector2d 0.15 0.4) (makeVector2d 0.3 0.6), makeSegment (makeVector2d 0.3 0.6) (makeVector2d 0.35 0.55), makeSegment (makeVector2d 0.35 0.55) (makeVector2d 0.25 0.0), makeSegment (makeVector2d 0.4 0.0) (makeVector2d 0.5 0.3), makeSegment (makeVector2d 0.5 0.3) (makeVector2d 0.6 0.0), makeSegment (makeVector2d 0.75 0.0) (makeVector2d 0.6 0.5), makeSegment (makeVector2d 0.6 0.5) (makeVector2d 1.0 0.15), makeSegment (makeVector2d 1.0 0.35) (makeVector2d 0.75 0.65), makeSegment (makeVector2d 0.75 0.65) (makeVector2d 0.6 0.65), makeSegment (makeVector2d 0.6 0.65) (makeVector2d 0.65 0.85), makeSegment (makeVector2d 0.65 0.85) (makeVector2d 0.6 1.0), makeSegment (makeVector2d 0.4 1.0) (makeVector2d 0.35 0.85), makeSegment (makeVector2d 0.35 0.85) (makeVector2d 0.4 0.65), makeSegment (makeVector2d 0.4 0.65) (makeVector2d 0.3 0.65), makeSegment (makeVector2d 0.3 0.65) (makeVector2d 0.15 0.6), makeSegment (makeVector2d 0.15 0.6) (makeVector2d 0.0 0.85) ] wave :: Painter wave = do segmentsToPainter waveSegments wave2 :: Painter wave2 = beside wave $ flipVert wave wave4 :: Painter wave4 = below wave2 wave2 drawLine :: Vector2d -> Vector2d -> Cairo.Render() drawLine startSegment endSegment = do Cairo.setSourceRGB 0 0 0 Cairo.setLineWidth 1 Cairo.moveTo (xcor startSegment) (ycor startSegment) Cairo.lineTo (xcor endSegment) (ycor endSegment) Cairo.stroke -- 描画 render :: Gtk.DrawingArea -> Painter -> IO Bool render drawArea painter = do drawin <- Gtk.widgetGetDrawWindow drawArea (width', height') <- Gtk.drawableGetSize drawin let drawFrame = makeDrawFrame (fromIntegral width') (fromIntegral height') Gtk.renderWithDrawable drawin $ painter drawFrame return True doPainter :: Painter -> IO() doPainter painter = do Gtk.initGUI window <- Gtk.windowNew Gtk.set window [ windowTitle := "Painter", windowDefaultWidth := 400, windowDefaultHeight := 400 ] frame <- Gtk.frameNew Gtk.containerAdd window frame canvas <- Gtk.drawingAreaNew --windowResizable = Falseの時は、SetSizeRequestで指定しないといけない。 Gtk.widgetSetSizeRequest canvas 400 400 Gtk.containerAdd frame canvas Gtk.widgetModifyBg canvas StateNormal (Color 65535 65535 65535) Gtk.widgetShowAll window Gtk.onExpose canvas $ const $ render canvas painter Gtk.onDestroy window Gtk.mainQuit Gtk.mainGUI main :: IO() main = doPainter wave