gegl-0.0.0.1: examples/example02.hs

{-# LANGUAGE RecordWildCards #-}

import GEGL
import qualified BABL as B
import qualified SDL
import qualified SDL.Raw as Raw

import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable

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

import Data.Maybe (fromMaybe)

import Debug.Trace

main :: IO ()
main = do
  SDL.initialize [SDL.InitVideo, SDL.InitTimer]
  traceIO "SDL init"
  window <- SDL.createWindow "GEGL example02: SDL2" SDL.defaultWindow
  surface <- SDL.getWindowSurface window
  gegl_init
  traceIO "GEGL init"
  let sdl_raw_format = B.PixelFormat B.RGBA B.CFu8
  sdl_format <- B.babl_format sdl_raw_format
  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"
  SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions surface
  let (w, h) = (fromIntegral rw, fromIntegral rh)
  _ <- gegl_buffer_set_extent buffer $ GeglRectangle 0 0 w h
  pixels <- SDL.surfacePixels surface
  let SDL.Surface rawSurfacePtr _ = surface
  rawSurface <- peek rawSurfacePtr
  pixelFormat <- peek $ Raw.surfaceFormat rawSurface
  let pitch = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w :: Int
  traceIO $ "pitch is: " ++ show pitch
  ld <- return $ LoopData
    surface
    window
    (w, h)
    pitch
    pixels
    buffer
    over
    root
    sdl_format
    sdl_raw_format
  traceIO "first update"
  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)
  mapM_ gegl_node_drop [root, background, over]
  gegl_exit
  SDL.quit
  traceIO "bye bye"

data LoopData = LoopData
  { ldSurface    :: SDL.Surface
  , ldWindow     :: SDL.Window
  , ldSurfDim    :: (Int, Int)
  , ldPitch      :: Int
  , ldPixels     :: Ptr ()
  , ldBuffer     :: GeglBuffer
  , ldNode       :: GeglNode
  , ldGraph      :: GeglNode
  , ldFormat     :: B.BablFormatPtr
  , ldBablFormat :: B.PixelFormat
  }

type UpdateData = (GeglRectangle, LoopData)

updateSurface :: UpdateData -> IO ()
updateSurface (roi, LoopData{..}) = do
  -- traceIO "locking surface"
  SDL.lockSurface ldSurface
  let surfaceRect = uncurry (GeglRectangle 0 0) ldSurfDim
  sroi@(GeglRectangle ix iy iw ih) <- fromMaybe surfaceRect <$>
    gegl_rectangle_intersect surfaceRect roi
  let origin = ldPixels `plusPtr` (ix * B.babl_components_per_pixel ldBablFormat + iy * ldPitch)
  -- traceIO "blit"
  gegl_node_blit
    ldNode
    1
    sroi
    ldFormat
    origin
    ldPitch
    [GeglBlitDefault]
  -- traceIO "unlocking surface"
  SDL.unlockSurface ldSurface
  -- traceIO "update window"
  SDL.updateWindowSurface ldWindow

-- | Window update loop
loop :: LoopData -> MVar Bool -> MVar Bool -> IO ()
loop ld down go = do
  e <- SDL.waitEvent
  case SDL.eventPayload e of
    SDL.MouseButtonEvent dat ->
      when (SDL.mouseButtonEventButton dat == SDL.ButtonLeft) $
        if (SDL.mouseButtonEventMotion dat == SDL.Pressed)
          then do
            _ <- swapMVar down True
            let (SDL.P (SDL.V2 x y)) = SDL.mouseButtonEventPos dat
            drawCircle ld (fromIntegral x) (fromIntegral y)
          else do
            _ <- swapMVar down False
            return ()
    SDL.MouseMotionEvent dat -> do
      isDown <- readMVar down
      when isDown $ do
        let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat
        drawCircle ld (fromIntegral x) (fromIntegral y)
    SDL.WindowClosedEvent _ -> do
      traceIO "seeya!"
      _ <- swapMVar go False
      return ()
    _ ->
      return ()

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)