As part of my further experiments with GTK4 and Haskell, I wanted to vary gtk-picture by creating the Picture programatically. I named the alternative gtk-dynamic-picture.

Diagrams

I created the picture using the Diagrams project. I looked at various backends that support that project:

the diagrams-gtk package, based on the Cairo C library, renders to values provided by the gtk Haskell package, not those provided by the gi-gtk Haskell package;
the diagrams-cairo package, also based on Cairo, can render to a buffer in memory with the pixel format known as CAIRO_FORMAT_ARGB32. That format has alpha in the upper byte, then red, then green, then blue. The pixels are, however, stored native-endian; that is, on little endian x86_64 machine architecture, the order of the bytes is B G R A. Also, pre-multiplied alpha is used. (For example, 50% transparent red is 0x80800000, not 0x80ff0000.); and
the diagrams-rasterific package, based on the Rasterific Haskell package, renders to values of type Image PixelRGBA8 (provided by the JuicyPixels package). Pixels are stored in the order R G B A.

Ultimately, given the pixel format of a Pixbuf value (R G B A), I used diagrams-rasterific as the backend.

The first step was to yield an Image PixelRGBA8 from a Diagram B. That was straightforward, given the renderDia function:

import           Codec.Picture.Types ( Image (..), PixelRGBA8 )
import           Diagrams.Backend.Rasterific
                   ( B, Rasterific (..), Options (..) )
import           Diagrams.Prelude ( Diagram, dims2D, renderDia )

renderDiagramToImage :: Int -> Int -> Diagram B -> Image PixelRGBA8
renderDiagramToImage width height =
  let size = dims2D (fromIntegral width) (fromIntegral height)
      options = RasterificOptions size
  in  renderDia Rasterific options

import Codec.Picture.Types ( Image (..), PixelRGBA8 )

import Diagrams.Backend.Rasterific

( B, Rasterific (..), Options (..) )

import Diagrams.Prelude ( Diagram, dims2D, renderDia )

renderDiagramToImage :: Int -> Int -> Diagram B -> Image PixelRGBA8

renderDiagramToImage width height =

let size = dims2D (fromIntegral width) (fromIntegral height)

options = RasterificOptions size

in renderDia Rasterific options

Picture

The gi-gtk package provides:

pictureNewForPaintable ::
     (HasCallStack, MonadIO m, IsPaintable obj)
  => Maybe obj
  -> m Picture

pictureNewForPaintable ::

(HasCallStack, MonadIO m, IsPaintable obj)

=> Maybe obj

-> m Picture

and the gi-gdk package provides Texture, which satisfies the IsPaintable constraint, and:

textureNewForPixbuf ::
     (HasCallStack, MonadIO m, IsPixbuf a) 
  => a
  -> m Texture

textureNewForPixbuf ::

(HasCallStack, MonadIO m, IsPixbuf a)

=> a

-> m Texture

So, the final step was to yield a Picture value from a Texture value and, in turn, a Texture value from a Pixbuf:

import           Diagrams.Backend.Rasterific ( B )
import           Diagrams.Prelude ( Diagram )
import           GI.Gdk ( textureNewForPixbuf )
import           GI.GdkPixbuf ( Pixbuf )
import qualified GI.Gtk as Gtk
import           Draw ( drawGrid, backgroundWidth, backgroundHeight )

renderDiagramToPixbuf :: Int -> Int -> Diagram B -> IO Pixbuf
renderDiagramToPixbuf width height diagram =
  imagePixelRGBA8ToPixbuf $ renderDiagramToImage width height diagram

activate :: Gtk.Application -> IO ()
activate app = do
...
  texture <- textureNewForPixbuf =<< renderDiagramToPixbuf
    backgroundWidth
    backgroundHeight
    (drawGrid newGrid)
  picture <- Gtk.pictureNewForPaintable (Just texture)

import Diagrams.Backend.Rasterific ( B )

import Diagrams.Prelude ( Diagram )

import GI.Gdk ( textureNewForPixbuf )

import GI.GdkPixbuf ( Pixbuf )

import qualified GI.Gtk as Gtk

import Draw ( drawGrid, backgroundWidth, backgroundHeight )

renderDiagramToPixbuf :: Int -> Int -> Diagram B -> IO Pixbuf

renderDiagramToPixbuf width height diagram =

imagePixelRGBA8ToPixbuf $ renderDiagramToImage width height diagram

activate :: Gtk.Application -> IO ()

activate app = do

...

texture <- textureNewForPixbuf =<< renderDiagramToPixbuf

backgroundWidth

backgroundHeight

(drawGrid newGrid)

picture <- Gtk.pictureNewForPaintable (Just texture)

imagePixelRGBA8ToPixbuf

The missing link was a function that would yield a Pixbuf value given an Image PixelRGBA8 value. I bridged that link with:

import           Codec.Picture.Types ( Image (..), PixelRGBA8 )
import qualified Data.Vector.Storable as SV
import           Foreign.Marshal.Alloc ( free, mallocBytes )
import           Foreign.Marshal.Utils ( copyBytes )
import           GI.GdkPixbuf ( Colorspace (..), Pixbuf, pixbufNewFromData )

imagePixelRGBA8ToPixbuf :: Image PixelRGBA8 -> IO Pixbuf
imagePixelRGBA8ToPixbuf image = do
  let w = imageWidth image
      h = imageHeight image
      rowStride = w * 4 -- 4 bytes per PixelRGBA8
      n = h * rowStride
  SV.unsafeWith (imageData image) $ \ptr -> do
     pixbufPtr <- mallocBytes n
     copyBytes pixbufPtr ptr n
     pixbufNewFromData
       pixbufPtr
       ColorspaceRgb
       True -- hasAlpha
       8 -- bitsPerSample
       (fromIntegral w) -- width
       (fromIntegral h) -- height
       (fromIntegral rowStride) -- rowStride
       (Just free) -- destroyFn

import Codec.Picture.Types ( Image (..), PixelRGBA8 )

import qualified Data.Vector.Storable as SV

import Foreign.Marshal.Alloc ( free, mallocBytes )

import Foreign.Marshal.Utils ( copyBytes )

import GI.GdkPixbuf ( Colorspace (..), Pixbuf, pixbufNewFromData )

imagePixelRGBA8ToPixbuf :: Image PixelRGBA8 -> IO Pixbuf

imagePixelRGBA8ToPixbuf image = do

let w = imageWidth image

h = imageHeight image

rowStride = w * 4 -- 4 bytes per PixelRGBA8

n = h * rowStride

SV.unsafeWith (imageData image) $ \ptr -> do

pixbufPtr <- mallocBytes n

copyBytes pixbufPtr ptr n

pixbufNewFromData

pixbufPtr

ColorspaceRgb

True -- hasAlpha

8 -- bitsPerSample

(fromIntegral w) -- width

(fromIntegral h) -- height

(fromIntegral rowStride) -- rowStride

(Just free) -- destroyFn

imageData image has type Data.Vector.Storable.Vector Word8. A buffer is allocated (mallocBytes n) and the bytes copied into it (copyBytes pixbufPtr ptr n). free is specified as the destroy function.

Mutable application state

Following an example presented by Mark Karpov and Jorge Galarze, I realised I would need a mutable state of the application. I used an IORef, as follows:

import           Data.IORef ( IORef, newIORef )

activate :: Gtk.Application -> IORef Grid -> IO ()
activate app appState = do
  ...
  gameGrid <- readIORef appState

  texture <- textureNewForPixbuf =<< renderDiagramToPixbuf
    backgroundWidth
    backgroundHeight
    (drawGrid gameGrid)
  ...

main :: IO ()
main = do
  appState <- newIORef emptyGrid
  app <- new Gtk.Application
    [ #applicationId := "com.pilgrem.gtk-picture"
    , On #activate (activate ?self appState)
    ]
  void $ app.run Nothing

import Data.IORef ( IORef, newIORef )

activate :: Gtk.Application -> IORef Grid -> IO ()

activate app appState = do

...

gameGrid <- readIORef appState

texture <- textureNewForPixbuf =<< renderDiagramToPixbuf

backgroundWidth

backgroundHeight

(drawGrid gameGrid)

...

main :: IO ()

main = do

appState <- newIORef emptyGrid

app <- new Gtk.Application

[ #applicationId := "com.pilgrem.gtk-picture"

, On #activate (activate ?self appState)

]

void $ app.run Nothing

onMouseClick

The onMouseClick action needed to update the application state and the paintable attribute of the Picture value. In that regard, I had a couple of false starts.

First, I thought I needed to use getEventControllerWidget. The auto-generated Haddock documentation for package gi-gtk-4.0.9 has:

getEventControllerWidget :: (MonadIO m, IsEventController o) => o -> m Widget

1	getEventControllerWidget :: (MonadIO m, IsEventController o) => o -> m Widget

However, the Haddock documentation for module Data.GI.Base.Attributes has:

Whenever the attribute is represented as a pointer in the C side, it is often the case that the underlying C representation admits or returns NULL as a valid value for the property. In these cases the get operation may return Maybe value, with Nothing representing the NULL pointer value (notable exceptions are GList and GSList, for which NULL is represented simply as the empty list). This can be overridden in the introspection data, since sometimes attributes are non-nullable, even if the type would allow for NULL.

and the GTK4 documentation for gtk_event_controller_get_widget states that the return value can be NULL.

I found on one machine that get gestureClick #widget was an action yielding a Maybe Widget and on another machine, with the same dependencies on Haskell packages, that get gestureClick #widget was an action yielding a Widget. I concluded that something had been corrupted on the former machine. I solved the problem by starting from scratch on that machine: I deleted the Stack-supplied MSYS2 and the snapshot directory in the Stack root. I had Stack re-install the Stack-supplied MSYS2, updated it, and installed the necessary MSYS2 packages. I then re-built the Haskell package dependencies that depended on the C libraries provided by those MSYS2 packages.

Then, I realised that I could could sequence actions so that the Picture value had been specified before the onMouseClick action needed to refer to it:

activate :: Gtk.Application -> IORef Grid -> IO ()
activate app appState = do
  ...
  picture <- Gtk.pictureNew
  ...
  let onMouseClick :: Gtk.GestureClickPressedCallback
      onMouseClick _nPress x y = do
        labelCoords `set` [ #label := coordsIntro <> showCoords x y ]
        whenJust (coordsToIsland x y) $ \(row, col) -> do
          oldGrid <- readIORef appState
          let gameGrid = updateGrid col row oldGrid
          writeIORef appState gameGrid
          texture <- textureNewForPixbuf =<< renderDiagramToPixbuf
            backgroundWidth
            backgroundHeight
            (drawGrid gameGrid)
          picture `set` [ #paintable := texture ]

  gestureClick <- new Gtk.GestureClick
    [ On #pressed onMouseClick ]
  ...
  #addController picture gestureClick

activate :: Gtk.Application -> IORef Grid -> IO ()

activate app appState = do

...

picture <- Gtk.pictureNew

...

let onMouseClick :: Gtk.GestureClickPressedCallback

onMouseClick _nPress x y = do

labelCoords `set` [ #label := coordsIntro <> showCoords x y ]

whenJust (coordsToIsland x y) $ \(row, col) -> do

oldGrid <- readIORef appState

let gameGrid = updateGrid col row oldGrid

writeIORef appState gameGrid

texture <- textureNewForPixbuf =<< renderDiagramToPixbuf

backgroundWidth

backgroundHeight

(drawGrid gameGrid)

picture `set` [ #paintable := texture ]

gestureClick <- new Gtk.GestureClick

[ On #pressed onMouseClick ]

...

#addController picture gestureClick

gtk-dynamic-picture.exe

The resulting executable behaved as expected:

Haskell, GTK4 and pictures on the fly

Diagrams

Picture

imagePixelRGBA8ToPixbuf

Mutable application state

onMouseClick

gtk-dynamic-picture.exe

Haskell, GTK4 and application icons