gegl-0.0.0.1: examples/example01.hs

{-# LANGUAGE RecordWildCards #-}

import qualified Graphics.UI.SDL as SDL
import qualified Graphics.UI.SDL.Types as SDL
import qualified BABL as B
import GEGL

import Control.Monad
import Control.Monad.Loops
import Control.Concurrent.MVar

import Foreign.C.Types
import Foreign.Ptr

import Data.Maybe (fromMaybe)

import Debug.Trace

main :: IO ()
main = do
  SDL.init [SDL.InitVideo, SDL.InitTimer]
  traceIO "SDL init"
  surface <- SDL.setVideoMode 800 600 24 [SDL.SWSurface]
  SDL.setCaption "GEGL example01: SDL" "example01"
  gegl_init
  traceIO "GEGL init"
  sdl_format <- B.babl_format $ B.PixelFormat B.R'G'B' B.CFu8
  root <- gegl_node_new
  buffer <- gegl_buffer_new (Just $ GeglRectangle 0 0 0 0) =<<
    B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
  background <- gegl_node_new_child root $ checkerboardOperation
    [ Property "color1" $ PropertyColor $ RGBA 0.4 0.4 0.4 1
    , Property "color2" $ PropertyColor $ RGBA 0.6 0.6 0.6 1
    ]
  over <- gegl_node_new_child root defaultOverOperation
  buffer_src <- gegl_node_new_child root $ bufferSourceOperation
    [ Property "buffer" $ PropertyBuffer buffer
    ]
  gegl_node_link background over
  gegl_node_connect_to buffer_src "output" over "aux"
  traceIO "Nodes constructed"
  let w = SDL.surfaceGetWidth surface
      h = SDL.surfaceGetHeight surface
  _ <- gegl_buffer_set_extent buffer $ GeglRectangle 0 0 w h
  pixels <- SDL.surfaceGetPixels surface
  ld <- return $ LoopData
    surface
    (w, h)
    (fromIntegral $ SDL.surfaceGetPitch surface)
    buffer
    over
    sdl_format
  traceIO "initial blit"
  updateSurface (GeglRectangle 0 0 w h, ld)
  go <- newMVar True
  butDown <- newMVar False
  traceIO "begin iteration"
  whileM_ (fromMaybe False <$> tryReadMVar go) (loop ld butDown go)
  gegl_exit
  SDL.quit
  traceIO "bye bye"

data LoopData = LoopData
  { ldSurface :: SDL.Surface
  , ldSurfDim :: (Int, Int)
  , ldPitch   :: Int
  -- , ldPixels  :: SDL.Pixels
  , ldBuffer  :: GeglBuffer
  , ldNode    :: GeglNode
  , ldFormat  :: B.BablFormatPtr
  }

type UpdateData = (GeglRectangle, LoopData)

-- | Window update loop
loop :: LoopData -> MVar Bool -> MVar Bool -> IO ()
loop ld down g = do
  e <- SDL.waitEvent
  case e of
    SDL.MouseButtonDown x y SDL.ButtonLeft -> do
      _ <- swapMVar down True
      drawCircle ld (fromIntegral x) (fromIntegral y)
    SDL.MouseMotion x y _ _ -> do
      isDown <- readMVar down
      when isDown $
        drawCircle ld (fromIntegral x) (fromIntegral y)
    SDL.MouseButtonUp _ _ SDL.ButtonLeft -> do
      _ <- swapMVar down False
      return ()
    SDL.Quit -> do
      putStrLn "seeya!"
      _ <- swapMVar g False
      return ()
    _                        -> return ()

updateSurface :: UpdateData -> IO ()
updateSurface (roi, LoopData{..}) = do
  SDL.lockSurface ldSurface
  pixels <- SDL.surfaceGetPixels ldSurface
  let output = uncurry (GeglRectangle 0 0) ldSurfDim
  sroi@(GeglRectangle ix iy iw ih) <- fromMaybe output <$>
    gegl_rectangle_intersect output roi
  let origin = pixels `plusPtr` (ix * 3 + iy * ldPitch)
  gegl_node_blit
    ldNode
    1
    sroi
    ldFormat
    origin
    ldPitch
    [GeglBlitDefault]
  SDL.unlockSurface ldSurface
  SDL.updateRect ldSurface $ SDL.Rect ix iy iw ih

drawCircle :: LoopData -> Int -> Int -> IO ()
drawCircle ld@LoopData{..} x y = do
  let r = 20
      roi = GeglRectangle (x - r) (y - r) (2 * r) (2 * r)
  pixelMap ldBuffer roi (B.PixelFormat B.RGBA B.CFfloat) GeglAccessReadWrite GeglAbyssNone
      (\(Pixel px py pc) ->
        let dsqr = ((x - px) ^ 2) + ((y - py) ^ 2)
            (CVfloat (CFloat pr), CVfloat (CFloat pg), CVfloat (CFloat pb), CVfloat (CFloat pa)) = pc
            dist = (sqrt (fromIntegral dsqr :: Float))
        in if dsqr < (r ^ 2)
          then
            if dist < fromIntegral (r - 1)
              then
                Pixel px py
                  ( CVfloat $ CFloat 0
                  , CVfloat $ CFloat 0
                  , CVfloat $ CFloat 0
                  , CVfloat $ CFloat $ if pa < 1 then 1 else pa
                  )
              else
                let alpha = (fromIntegral r - dist)
                    dst_a = pa
                    a = alpha + dst_a * (1 - alpha)
                    a_term = dst_a * (1 - alpha)
                    red = 0 * alpha + pr * a_term
                    gre = 0 * alpha + pg * a_term
                    blu = 0 * alpha + pb * a_term
                in Pixel px py
                  ( CVfloat $ CFloat $ red/a
                  , CVfloat $ CFloat $ gre/a
                  , CVfloat $ CFloat $ blu/a
                  , CVfloat $ CFloat $ if pa < alpha then alpha else pa
                  )
          else
            Pixel px py pc
      )
  updateSurface (roi, ld)