SICP の図形言語を Haskell で書いていて、最後に draw-line が未定義になっていることに気付き、倒れそうになりました。図形言語なのに、絵が描けないじゃん!しかし、なんとか踏みとどまって完成させました。誰かの役に立つかもしれないので、公開しておきます。
デフォルトでは OpenGL で表示し、-p オプションを付けると PostScript を生成します。また、デフォルトでは Square Limit ですが、-r、-u、-c でそれぞれ Right Split、Up Split、Corner Split になります。
人の絵は、和田先生の関数画家から取り出して、適当に Haskell で加工しました。
module Main where import Graphics.UI.GLUT import System.Console.GetOpt import System.Environment ---------------------------------------------------------------- -- 2.46 data Vector = Vector { xcor :: Float , ycor :: Float } deriving (Eq,Show) instance Num Vector where v1 + v2 = Vector { xcor = xcor v1 + xcor v2 , ycor = ycor v1 + ycor v2 } v1 - v2 = Vector { xcor = xcor v1 - xcor v2 , ycor = ycor v1 - ycor v2 } (*) = undefined abs = undefined signum = undefined fromInteger = undefined infixl 7 *: (*:) :: Float -> Vector -> Vector s *: v = Vector { xcor = s * xcor v , ycor = s * ycor v } makeVector :: Float -> Float -> Vector makeVector x y = Vector { xcor = x, ycor = y } ---------------------------------------------------------------- -- 2.47 data Frame = Frame { origin :: Vector , edge1 :: Vector , edge2 :: Vector } deriving (Eq,Show) makeFrame :: Vector -> Vector -> Vector -> Frame makeFrame o e1 e2 = Frame { origin = o , edge1 = e1 , edge2 = e2 } ---------------------------------------------------------------- -- 2.48 data Segment = Segment { start :: Vector , end :: Vector } deriving (Eq,Show) makeSegment :: Vector -> Vector -> Segment makeSegment s e = Segment { start = s , end = e } ---------------------------------------------------------------- type Painter = Frame -> IO () ---------------------------------------------------------------- squareLimit :: Int -> Painter -> Painter squareLimit n painter = combine4 $ cornerSplit n painter where combine4 = squareOfFour flipHoriz id rotate180 flipVert flippedPairs :: Painter -> Painter flippedPairs painter = combine4 painter where combine4 = squareOfFour id flipVert id flipVert 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) ---------------------------------------------------------------- rightSplit :: Int -> Painter -> Painter rightSplit 0 painter = painter rightSplit n painter = beside painter (below smaller smaller) where smaller = rightSplit (n - 1) painter -- 2.44 upSplit :: Int -> Painter -> Painter upSplit 0 painter = painter upSplit n painter = below painter (beside smaller smaller) where smaller = upSplit (n - 1) painter cornerSplit :: Int -> Painter -> Painter cornerSplit 0 painter = painter cornerSplit n painter = beside (below painter topLeft) (below bottomRight corner) where topLeft = beside up up bottomRight = below right right corner = cornerSplit (n - 1) painter up = upSplit (n - 1) painter right = rightSplit (n - 1) painter ---------------------------------------------------------------- transformPainter :: Painter -> Vector -> Vector -> Vector -> Painter transformPainter painter orig corner1 corner2 frame = painter frame' where m = frameCoordMap frame newOrigin = m orig frame' = makeFrame newOrigin (m corner1 - newOrigin) (m corner2 - newOrigin) frameCoordMap :: Frame -> Vector -> Vector frameCoordMap frame v = origin frame + xcor v *: edge1 frame + ycor v *: edge2 frame ---------------------------------------------------------------- flipHoriz :: Painter -> Painter flipHoriz painter = transformPainter painter (makeVector 1.0 0.0) (makeVector 0.0 0.0) (makeVector 1.0 1.0) flipVert :: Painter -> Painter flipVert painter = transformPainter painter (makeVector 0.0 1.0) (makeVector 1.0 1.0) (makeVector 0.0 0.0) ---------------------------------------------------------------- rotate90 :: Painter -> Painter rotate90 painter = transformPainter painter (makeVector 1.0 0.0) (makeVector 1.0 1.0) (makeVector 0.0 0.0) -- 2.50 rotate180 :: Painter -> Painter rotate180 = rotate90 . rotate90 rotate270 :: Painter -> Painter rotate270 = rotate90 . rotate90 . rotate90 ---------------------------------------------------------------- beside :: Painter -> Painter -> Painter beside painter1 painter2 frame = do paintLeft frame paintRight frame where paintLeft = transformPainter painter1 (makeVector 0.0 0.0) (makeVector 0.5 0.0) (makeVector 0.0 1.0) paintRight = transformPainter painter2 (makeVector 0.5 0.0) (makeVector 1.0 0.0) (makeVector 0.5 1.0) -- 2.51 below :: Painter -> Painter -> Painter below painter1 painter2 frame = do paintUpper frame paintLower frame where paintUpper = transformPainter painter2 (makeVector 0.0 0.5) (makeVector 1.0 0.5) (makeVector 0.0 1.0) paintLower = transformPainter painter1 (makeVector 0.0 0.0) (makeVector 1.0 0.0) (makeVector 0.0 0.5) ---------------------------------------------------------------- type DrawLine = (Vector,Vector) -> IO () segmentsToPainter :: [Segment] -> DrawLine -> Painter segmentsToPainter segs drawLine = \frame -> mapM_ (drawLine . transformSegment frame) segs transformSegment :: Frame -> Segment -> (Vector,Vector) transformSegment frame seg = (v1,v2) where v1 = frameCoordMap frame $ start seg v2 = frameCoordMap frame $ end seg drawLinePS :: DrawLine drawLinePS (v1,v2) = do putStrLn $ show (xcor v1) ++ " " ++ show (ycor v1) ++ " moveto" putStrLn $ show (xcor v2) ++ " " ++ show (ycor v2) ++ " lineto" putStrLn "stroke" drawLineOpenGL :: DrawLine drawLineOpenGL (v1,v2) = renderPrimitive Lines $ do vertex $ vectorToVertex v1 vertex $ vectorToVertex v2 where vectorToVertex v = Vertex2 (xcor v) (ycor v) ---------------------------------------------------------------- man :: DrawLine -> Painter man = segmentsToPainter manFig manFig :: [Segment] manFig = [ Segment (Vector 0.0 0.65) (Vector 0.15 0.4) , Segment (Vector 0.15 0.4) (Vector 0.3 0.6) , Segment (Vector 0.3 0.6) (Vector 0.35 0.55) , Segment (Vector 0.35 0.55) (Vector 0.25 0.0) , Segment (Vector 0.4 0.0) (Vector 0.5 0.3) , Segment (Vector 0.5 0.3) (Vector 0.6 0.0) , Segment (Vector 0.75 0.0) (Vector 0.6 0.5) , Segment (Vector 0.6 0.5) (Vector 1.0 0.15) , Segment (Vector 1.0 0.35) (Vector 0.75 0.65) , Segment (Vector 0.75 0.65) (Vector 0.6 0.65) , Segment (Vector 0.6 0.65) (Vector 0.65 0.85) , Segment (Vector 0.65 0.85) (Vector 0.6 1.0) , Segment (Vector 0.4 1.0) (Vector 0.35 0.85) , Segment (Vector 0.35 0.85) (Vector 0.4 0.65) , Segment (Vector 0.4 0.65) (Vector 0.3 0.65) , Segment (Vector 0.3 0.65) (Vector 0.15 0.6) , Segment (Vector 0.15 0.6) (Vector 0.0 0.85) ] ---------------------------------------------------------------- squareFramePS :: Frame squareFramePS = Frame (Vector 20 20) (Vector 500 0) (Vector 0 500) squareFrameOpenGL :: Frame squareFrameOpenGL = Frame (Vector (-1) (-1)) (Vector 2 0) (Vector 0 2) ---------------------------------------------------------------- drawPS :: IO () -> IO () drawPS draw = draw drawOpenGL :: IO () -> IO () drawOpenGL draw = do getArgsAndInitialize createWindow "Square Limit" windowSize $= Size 400 400 displayCallback $= display mainLoop where display = do clear [ColorBuffer] draw flush ---------------------------------------------------------------- data Device = PostScript | OpenGL data Pattern = SquareLimit | RightSplit | UpSplit | CornerSplit data Config = Config { device :: Device , pattern :: Pattern } defaultConfig :: Config defaultConfig = Config { device = OpenGL , pattern = SquareLimit } options :: [OptDescr (Config -> Config)] options = [ Option ['p'] ["postscript"] (NoArg (\cnf -> cnf { device = PostScript })) "draw with PostScript" , Option ['g'] ["opengl"] (NoArg (\cnf -> cnf { device = OpenGL })) "draw with OpenGL" , Option ['s'] ["squarelimit"] (NoArg (\cnf -> cnf { pattern = SquareLimit })) "draw SquareLimit" , Option ['r'] ["rightsplit"] (NoArg (\cnf -> cnf { pattern = RightSplit })) "draw RightSplit" , Option ['u'] ["upsplit"] (NoArg (\cnf -> cnf { pattern = UpSplit })) "draw UpLimit" , Option ['c'] ["cornerlimit"] (NoArg (\cnf -> cnf { pattern = CornerSplit })) "draw CornerLimit" ] compilerOpts :: [String] -> IO (Config, [String]) compilerOpts argv = case getOpt Permute options argv of (o,n,[] ) -> return (foldl (flip id) defaultConfig o, n) _ -> error "Painter [-p|-g] [-s|-r|-u|-c]" main :: IO () main = do (cnf,_) <- compilerOpts =<< getArgs let n = 3 wave = man (draw,painter,frame) = case device cnf of PostScript -> (drawPS, wave drawLinePS, squareFramePS) OpenGL -> (drawOpenGL, wave drawLineOpenGL, squareFrameOpenGL) pat = case pattern cnf of SquareLimit -> squareLimit n RightSplit -> rightSplit n UpSplit -> upSplit n CornerSplit -> cornerSplit n draw $ pat painter frame