あどけない話

インターネットに関する技術的な話など

SICP の図形言語

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