sdl2-cairo-0.1.1.0: example/Main.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Monad (unless)
import Control.Monad.State (lift)

import SDL hiding (point, rotate)
import Linear.V2 (V2(..))
import Linear.Affine (Point(..))

import SDL.Cairo
import SDL.Cairo.Canvas
import qualified Graphics.Rendering.Cairo as C

main :: IO ()
main = do
  initializeAll
  window <- createWindow "SDL2 Cairo Canvas" defaultWindow
  renderer <- createRenderer window (-1) defaultRenderer

  -- create a texture suitable to use cairo on
  texture <- createCairoTexture' renderer window

  appLoop renderer texture 0 (V2 0 0)

  -- clean up
  destroyTexture texture
  destroyRenderer renderer
  destroyWindow window
  return ()

appLoop :: Renderer -> Texture -> Int -> V2 Double -> IO ()
appLoop renderer texture framecount mousepos = do
  events <- pollEvents
  let quitEvent event = case eventPayload event of
                          QuitEvent -> True
                          _ -> False
      mouseMoveEvent e = case eventPayload e of
                          MouseMotionEvent _ -> True
                          _ -> False
      getMousePos (MouseMotionEvent (MouseMotionEventData _ _ _ (P p) _)) = fromIntegral <$> p
      getMousePos _ = V2 0 0
      mousePositions = map getMousePos $ map eventPayload $ filter mouseMoveEvent events
      quit = any quitEvent events
      mousepos' = if null mousePositions then mousepos else head mousePositions

  -- draw on the texture
  withCanvas texture $ do
    drawExample
    drawRndCircle
    drawStars (fromIntegral framecount)
    drawTriangleStrip mousepos'
    drawBezierTest

  -- apply texture and show on screen
  copy renderer texture Nothing Nothing
  present renderer

  delay $ 1000 `div` 60     -- slow down to approx. 60 FPS

  unless quit (appLoop renderer texture (framecount+1) mousepos')

-- | draw a circle in a random color
drawRndCircle :: Canvas ()
drawRndCircle = do
    rnd <- random (0,255)
    fill $ gray rnd
    circle (V2 700 500) 100
    fill $ gray 255

-- | some shapes, show some features
drawExample :: Canvas ()
drawExample = do
    background $ gray 102

    stroke $ blue 255
    point $ V2 500 10

    line (V2 0 0) (V2 100 100)
    line (V2 100 0) (V2 0 100)
    fill $ red 255 !@ 128
    noStroke
    rect $ D 200 200 100 100
    stroke $ green 255 !@ 128
    fill $ blue 255 !@ 128
    rect $ centered $ D 200 200 100 100
    triangle (V2 700 300) (V2 750 400) (V2 700 400)

    strokeWeight 5
    strokeJoin LineJoinRound
    stroke $ (blue 255 + red 255) !@ 128
    fill $ rgb 0 255 255 !@ 128
    polygon [V2 600 500,V2 610 505,V2 620 530, V2 600 530]

    circle (V2 200 500) 30

    strokeWeight 1
    ellipse $ D 100 500 30 50

    pushMatrix
    translate $ V2 350 350
    rotate $ pi/4
    ellipse $ D 0 0 100 50
    popMatrix
    ellipse $ D 0 0 100 50

    -- render some text
    let txtpos = V2 100 50
    textFont $ Font "Monospace" 30 False True
    offset <- text "sdl2-cairo " txtpos
    textFont $ Font "" 30 True False
    text "is AWESOME." $ txtpos + offset
    return ()

    -- use Cairo Render API directly
    lift $ do
      C.setSourceRGB 1 1 0
      C.moveTo 100 300
      C.lineTo 200 400
      C.stroke

-- | ported star example from Processing home page
drawStars :: Double -> Canvas ()
drawStars frameCount = do
  (V2 w h) <- getCanvasSize
  stroke $ gray 0

  pushMatrix
  translate $ V2 (0.2*w) (0.3*h)
  rotate $ frameCount / 200
  star 0 0 5 70 3
  popMatrix

  pushMatrix
  translate $ V2 (0.5*w) (0.3*h)
  rotate $ frameCount / 400
  star 0 0 80 100 40
  popMatrix

  pushMatrix
  translate $ V2 (0.8*w) (0.3*h)
  rotate $ frameCount / (-100)
  star 0 0 30 70 5
  popMatrix

star :: Double -> Double -> Double -> Double -> Double -> Canvas ()
star x y r1 r2 n = do
  let angle = 2*pi/n
      halfAngle = angle/2
      p1 a = V2 (x+cos a*r2) (y+sin a*r2)
      p2 a = V2 (x+cos (a+halfAngle)*r1) (y+sin (a+halfAngle)*r1)
      vertices = concatMap snd $ takeWhile (\(a, _) -> a<2*pi+angle)
               $ iterate (\(a, _) -> (a+angle,[p1 a, p2 a])) (0,[])
  polygon vertices

-- | ported triangle strip example from Processing homepage
drawTriangleStrip :: V2 Double -> Canvas ()
drawTriangleStrip mousePos = do
  (V2 w h) <- getCanvasSize
  let (V2 mouseX mouseY) = mousePos
      pos = V2 (w/2) (h/4*3)
      n = fromIntegral $ round $ mapRange mouseX (0,w) (6,60)
      astep = 180/n
      insideRadius = 100
      outsideRadius = 150
      cossin a = V2 (cos a) (sin a)
      makeVert a = [ pos+cossin (radians a) * outsideRadius
                   , pos+cossin (radians $ a+astep)*insideRadius
                   ]
      vertices = concatMap makeVert $ map (2*astep*) [0..n]
  shape ShapeTriangleStrip vertices
  return ()

-- | draw bezier curve examples
drawBezierTest :: Canvas ()
drawBezierTest = do
  pushMatrix
  translate $ V2 600 0
  stroke $ rgb 255 102 0
  line (V2 85 20) (V2 10 10)
  line (V2 90 90) (V2 15 80)
  stroke $ gray 0
  bezier (V2 85 20) (V2 10 10) (V2 90 90) (V2 15 80)
  translate $ V2 100 0
  stroke $ rgb 255 102 0
  noFill
  line (V2 30 20) (V2 80 5)
  line (V2 80 75) (V2 30 75)
  stroke $ gray 0
  bezier (V2 30 20) (V2 80 5) (V2 80 75) (V2 30 75)
  popMatrix