Haskellで図形言語
HaskellでGUIに挑戦してみた。gtk2hsとcairoでSICPの図形言語に挑戦。
まずは、簡単なベクトル演算のclass
data Vector2d = Vector2d { xcor :: Double, ycor :: Double } deriving (Show,Eq) instance Num Vector2d where (+) v1 v2 = Vector2d { xcor = xcor v1 + xcor v2, ycor = ycor v1 + ycor v2 } (-) v1 v2 = Vector2d { xcor = xcor v1 - xcor v2, ycor = ycor v1 - ycor v2 } (*) = undefined abs = undefined signum = undefined fromInteger = undefined scale :: Double -> Vector2d -> Vector2d scale s v = Vector2d { xcor = s * xcor v, ycor = s * ycor v } makeVector2d :: Double -> Double -> Vector2d makeVector2d x y = Vector2d { xcor = x, ycor = y }
で、本丸のPainter
--wave.hs --SICP 図形言語 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の向きが違うので…。 drawFrame :: Main.Frame drawFrame = Main.Frame { origin = makeVector2d 0 400, edge1 = makeVector2d 400 0, edge2 = makeVector2d 0 (-400) } 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 = do \frame -> 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.50 ans1) below :: Painter -> Painter -> Painter below bottomp' topp' frame = do let splitPoint = makeVector2d 0.0 0.5 topp = transformPainter topp' splitPoint (makeVector2d 1.0 0.5) (makeVector2d 0.0 1.0) bottomp = transformPainter bottomp' (makeVector2d 0.0 0.0) (makeVector2d 1.0 0.0) splitPoint topp frame bottomp frame -- right-split rightSplit :: Painter -> Int -> Painter rightSplit painter n | n > 0 = beside painter $ below smaller smaller | otherwise = painter where smaller = rightSplit painter $ n-1 -- up-split (ex 2.44) upSplit :: Painter -> Int -> Painter upSplit painter n | n > 0 = below painter (beside smaller smaller) | otherwise = painter where smaller = upSplit painter $ n-1 -- 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 = below (flipVert half) half where quarter = cornerSplit painter n half = beside (flipHoriz quarter) quarter 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 Gtk.renderWithDrawable drawin $ painter drawFrame return True doPainter :: Painter -> IO() doPainter painter = do Gtk.initGUI window <- Gtk.windowNew -- 描画エリアを400x400で固定する Gtk.set window [ windowTitle := "Painter", windowResizable := False ] 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
例えば
% ghci wave.hs [~/work/Haskell/sicp/wave] GHCi, version 7.0.3: http://www.haskell.org/ghc/ :? for help Loading package ghc-prim ... linking ... done. Loading package integer-gmp ... linking ... done. Loading package base ... linking ... done. Loading package ffi-1.0 ... linking ... done. [1 of 2] Compiling Vector ( Vector.hs, interpreted ) [2 of 2] Compiling Main ( wave.hs, interpreted ) Ok, modules loaded: Vector, Main. *Main> doPainter $ splitLimit wave 4
とすると、
参考ページ
SICP の図形言語 - あどけない話
Gtk2Hs(Carino)でお絵描き - Life Goes On
