Haskell Art Tutorial

Colour.hs

module Colour (setColour) where

import Data.Colour
import Data.Colour.RGBSpace
import Data.Colour.SRGB
import Graphics.Rendering.Cairo

class CairoColour d where
  withColour :: d -> (Pattern -> Render ()) -> Render ()

instance CairoColour (Colour Double) where
  withColour col = withRGBPattern channelRed channelGreen channelBlue
    where
      RGB {..} = toSRGB col

setColour :: CairoColour c => c -> Render ()
setColour col = withColour col $ \pattern -> setSource pattern

Compositing.hs

alphaMatte :: Render () -> Render () -> Render ()
alphaMatte matte src = do
  pushGroup
  src
  popGroupToSource
  pushGroup
  matte
  withGroupPattern mask

Main1.hs

module Main where

import Graphics.Rendering.Cairo

bg :: Render ()
bg = do
  setSourceRGBA 0 0 0 1
  rectangle 0 0 500 500
  fill

drawSquare :: Render ()
drawSquare = do
  setSourceRGBA 1 1 0 1
  rectangle 10 10 100 100
  fill

sketch :: Render ()
sketch = bg >> drawSquare

main :: IO ()
main = do
  surface <- createImageSurface FormatARGB32 500 500
  renderWith surface sketch
  surfaceWriteToPNG surface "out.png"

Main2.hs

module Main where

import qualified Data.Vector as V
import Graphics.Rendering.Cairo
import Linear.V2

newtype Contour =
  Contour (V.Vector (V2 Double))

contourPath :: Contour -> Render ()
contourPath (Contour vertices) = foldr1 (>>) $ concat [initCmds, lines, endCmds]
  where
    initCmds = [newPath, moveTo (startX) (startY)]
    lines = V.toList $ V.map (\(V2 x y) -> lineTo x y) $ V.tail vertices
    endCmds = [closePath]
    V2 startX startY = V.head vertices

bg :: Render ()
bg = do
  setSourceRGBA 0 0 0 1
  rectangle 0 0 500 500
  fill

drawTriangle :: Render ()
drawTriangle = do
  setSourceRGBA 1 1 0 1
  contourPath $ Contour $ V.fromList [V2 10 10, V2 100 10, V2 100 100]
  fill

sketch :: Render ()
sketch = bg >> drawTriangle

main :: IO ()
main = do
  surface <- createImageSurface FormatARGB32 500 500
  renderWith surface sketch
  surfaceWriteToPNG surface "out.png"

Main3.hs

module Main where

import Control.Monad.Reader
import Graphics.Rendering.Cairo

data World = World
  { worldWidth :: Double
  , worldHeight :: Double
  , scaleFactor :: Double
  }

type Generate a = Reader World a

bg :: Generate (Render ())
bg = do
  (World w h _) <- ask
  return $ do
    setSourceRGBA 0 0 0 1
    rectangle 0 0 w h
    fill

drawSquare :: Generate (Render ())
drawSquare = do
  (World w h _) <- ask
  return $ do
    setSourceRGBA 1 1 0 1
    rectangle (w / 4) (h / 4) (w / 2) (h / 2)
    fill

sketch :: Generate (Render ())
sketch = do
  rs <- sequence [bg, drawSquare]
  return $ foldr1 (>>) rs

main :: IO ()
main = do
  let world = World 500 200 1
  surface <-
    createImageSurface
      FormatARGB32
      (round $ worldWidth world)
      (round $ worldHeight world)
  renderWith surface $ do
    scale (scaleFactor world) (scaleFactor world)
    runReader sketch world
  surfaceWriteToPNG surface "out.png"

Main4.hs

module Main where

import Control.Monad.Reader
import Control.Monad.State
import Data.RVar
import Data.Random.Distribution.Uniform
import Data.Random.Source.PureMT
import qualified Data.Vector as V
import Graphics.Rendering.Cairo

data World = World
  { worldWidth :: Double
  , worldHeight :: Double
  , scaleFactor :: Double
  }

type Generate a = StateT PureMT (Reader World) a

runGenerate :: World -> PureMT -> Generate a -> a
runGenerate world rng scene =
  (flip runReader world) . (>>= (return . fst)) . (flip runStateT rng) $ scene

bg :: Generate (Render ())
bg = do
  (World w h _) <- ask
  return $ do
    setSourceRGBA 0 0 0 1
    rectangle 0 0 w h
    fill

drawSquare :: Generate (Render ())
drawSquare = do
  (World w h _) <- ask
  red <- sampleRVar $ uniform 0 1
  green <- sampleRVar $ uniform 0 1
  blue <- sampleRVar $ uniform 0 1
  return $ do
    setSourceRGBA red green blue 1
    rectangle (w / 4) (h / 4) (w / 2) (h / 2)
    fill

sketch :: Generate (Render ())
sketch = do
  rs <- sequence [bg, drawSquare]
  return $ foldr1 (>>) rs

main :: IO ()
main = do
  let world = World 500 200 1
  rng <- newPureMT
  surface <-
    createImageSurface
      FormatARGB32
      (round $ worldWidth world)
      (round $ worldHeight world)
  renderWith surface $ do
    scale (scaleFactor world) (scaleFactor world)
    runGenerate world rng sketch
  surfaceWriteToPNG surface "out.png"

Main5.hs

module Main where

import Control.Monad.Reader
import Control.Monad.State
import Data.RVar
import Data.Random.Distribution.Uniform
import Data.Random.Source.PureMT
import qualified Data.Vector as V
import Graphics.Rendering.Cairo

data World = World
  { worldWidth :: Double
  , worldHeight :: Double
  , scaleFactor :: Double
  }

type Generate a = StateT PureMT (Reader World) a

runGenerate :: World -> PureMT -> Generate a -> a
runGenerate world rng scene =
  (flip runReader world) . (>>= (return . fst)) . (flip runStateT rng) $ scene

bg :: Generate (Render ())
bg = do
  (World w h _) <- ask
  return $ do
    setSourceRGBA 0 0 0 1
    rectangle 0 0 w h
    fill

-- The animated state is the red channel, which gradually increases
-- and wraps around after hitting 1.
drawSquare :: State Double (Generate (Render ()))
drawSquare = do
  red <- get
  if red >= 1
    then put 0
    else put $ red + 0.01
  return $ do
    (World w h _) <- ask
    green <- sampleRVar $ uniform 0 1
    blue <- sampleRVar $ uniform 0 1
    return $ do
      setSourceRGBA red green blue 1
      rectangle (w / 4) (h / 4) (w / 2) (h / 2)
      fill

sketch :: State Double (Generate (Render ()))
sketch = do
  drawSquare_ <- drawSquare
  return $ do
    rs <- sequence [bg, drawSquare_]
    return $ foldr1 (>>) rs

animation :: Int -> State Double [Generate (Render ())]
animation frames = sequence $ map (const $ sketch) [1 .. frames]

-- You may or may not want to start with an RNG in the same state for each
-- frame. If you didn't want to, you'd just create a new one in this function
-- and remove the argument.
writeSketch :: World -> PureMT -> String -> Generate (Render ()) -> IO ()
writeSketch world rng path sketch = do
  surface <-
    createImageSurface
      FormatARGB32
      (round $ worldWidth world)
      (round $ worldHeight world)
  renderWith surface $ do
    scale (scaleFactor world) (scaleFactor world)
    runGenerate world rng sketch
  surfaceWriteToPNG surface path

main :: IO ()
main = do
  let world = World 500 200 1
  let frames = 100
  let frameRenders = evalState (animation frames) 1
  rng <- newPureMT
  let filenames = map (\i -> show i ++ ".png") [1 .. frames]
  foldr1 (>>) $
    map (uncurry $ writeSketch world rng) $ zip filenames frameRenders

RadialInstance.hs

data RadialRamp = RadialRamp
  { radialRampStart :: (V2 Double, Double)
  , radialRampEnd :: (V2 Double, Double)
  , radialRampStops :: [(Double, RGB Double, Double)]
  }

instance CairoColour RadialRamp where
  withColour (RadialRamp ((V2 sx sy), sr) ((V2 ex ey), er) stops) f =
    withRadialPattern sx sy sr ex ey er $ \pattern ->
      prepare pattern >> f pattern
    where
      prepare :: Pattern -> Render ()
      prepare pattern = foldr1 (>>) $ map (formatStop pattern) stops
      formatStop :: Pattern -> (Double, RGB Double, Double) -> Render ()
      formatStop pattern (offset, col, alpha) =
        patternAddColorStopRGBA
          pattern
          offset
          channelRed
          channelGreen
          channelBlue
          alpha
        where
          RGB {..} = toSRGB $ uncurryRGB rgb $ col

Shade.hs

module Shade
  ( Shader
  , noOpShader
  , shadeSurface
  ) where

import Control.Monad.Reader
import Data.Array.Accelerate as A
import Data.Array.Accelerate.Data.Bits
import Data.Array.Accelerate.Data.Colour.RGBA
import Data.Array.Accelerate.IO.Data.Array.IArray
import Data.Array.Accelerate.LLVM.PTX as GPU
import qualified Data.Array.IArray as I
import Data.Array.MArray
import Data.Array.Unboxed
import Data.Colour.RGBSpace
import qualified Data.Vector as V
import Data.Word
import Graphics.Rendering.Cairo as C
import Prelude as P

newtype Shader =
  Shader ((Exp DIM2 -> Exp (RGBA Float)) -> Uniforms -> Exp DIM2 -> Exp (RGBA Float))

type Uniforms = ()

noOpShader :: Shader
noOpShader = Shader $ \bufferAccessF _ -> bufferAccessF

shadeSurface :: Shader -> Surface -> IO ()
shadeSurface (Shader f) surface = do
  surfaceFlush surface
  raw <- surfacePixels surface
  stride <- imageSurfaceGetStride surface
  let bufferAccessF = bufferAccess raw stride
  let (shaded :: A.Array DIM1 Word32) =
        GPU.run $
        imap (shaderProxy bufferAccessF stride (f bufferAccessF ())) raw
  let (extracted :: UArray Int Word32) = toIArray Nothing shaded
  (rawData :: SurfaceData Int Word32) <- imageSurfaceGetPixels surface
  (s, e) <- getBounds rawData
  foldr1 (>>) $ P.map (\i -> writeArray rawData i $ extracted I.! i) [s .. e]
  surfaceMarkDirty surface

shaderProxy ::
     (Exp DIM2 -> Exp (RGBA Float))
  -> Int
  -> (Exp DIM2 -> Exp (RGBA Float))
  -> Exp DIM1
  -> Exp Word32
  -> Exp Word32
shaderProxy bufferAccessF stride shaderF rawDims raw =
  ifThenElse
    (x A.>= (constant $ stride `div` 4))
    raw
    (packPixel $ shaderF coord)
  where
    coord@(unlift -> Z :. x :. (_ :: Exp Int)) = unpackIndex stride rawDims

surfacePixels :: Surface -> IO (Acc (A.Array DIM1 Word32))
surfacePixels surface = do
  raw :: SurfaceData Int Word32 <- imageSurfaceGetPixels surface
  iraw :: UArray Int Word32 <- freeze raw
  return $ use $ fromIArray iraw

bufferAccess ::
     Acc (A.Array DIM1 Word32) -> Int -> Exp (V2 Float) -> Exp (RGBA Float)
bufferAccess raw stride (unlift -> V2 x y) =
  unpackPixel $ raw A.! (A.lift $ Z :. y' * (constant (stride `div` 4)) + x')
  where
    x' = A.floor x
    y' = A.floor y

unpackIndex :: Int -> Exp DIM1 -> Exp (V2 Float)
unpackIndex stride (unlift -> Z :. i) =
  A.lift
    (V2
       (A.fromIntegral $ i `mod` (constant $ stride `div` 4))
       (A.fromIntegral $ i `div` (constant $ stride `div` 4)))

packPixel :: Exp (RGBA Float) -> Exp Word32
packPixel = packARGB . multiplyRGBA . RGBA.clamp

unpackPixel :: Exp Word32 -> Exp (RGBA Float)
unpackPixel = unmutliplyRGBA . unpackARGB

multiplyRGBA :: Exp (RGBA Float) -> Exp (RGBA Float)
multiplyRGBA (unlift -> RGBA r g b a) =
  A.lift $ RGBA (r * a) (g * a) (b * a) (a :: Exp Float)

unmutliplyRGBA :: Exp (RGBA Float) -> Exp (RGBA Float)
unmutliplyRGBA (unlift -> RGBA r g b a) =
  A.lift $ RGBA (unmul a) (unmul g) (unmul b) a
  where
    unmul :: Exp Float -> Exp Float
    unmul c = ifThenElse (a A./= constant 0) (c / a) (constant 0)

unpackARGB :: Exp Word32 -> Exp (RGBA Float)
unpackARGB w =
  A.lift $
  (RGBA
     ((/ 255) $ A.fromIntegral (255 .&. w `shiftR` 16))
     ((/ 255) $ A.fromIntegral (255 .&. w `shiftR` 8))
     ((/ 255) $ A.fromIntegral (255 .&. w `shiftR` 0))
     ((/ 255) $ A.fromIntegral (255 .&. w `shiftR` 24)) :: RGBA (Exp Float))

packARGB :: Exp (RGBA Float) -> Exp Word32
packARGB (unlift -> RGBA r g b a) =
  ((A.fromIntegral $ word8ofFloat a) `shiftL` 24) .|.
  ((A.fromIntegral $ word8ofFloat r) `shiftL` 16) .|.
  ((A.fromIntegral $ word8ofFloat g) `shiftL` 8) .|.
  A.fromIntegral (word8ofFloat b)

word8ofFloat :: Exp Float -> Exp Word8
word8ofFloat x = A.truncate (x * 255)