続・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