Diagrams is the best library for drawing diagrams in Haskell. But can it be used as part of a user interface so you can interact with parts of a diagram?

The answer is: yes.


In this article we walk through a simple example that combines Diagrams, its Cairo backend and Gtk, to show a diagram and determine which parts of the diagram the mouse is over.

The full source code for this example is at the bottom of this article, but we’ll also look at some excerpts in detail.

Let’s start with the diagram to be shown. It’s a simple picture of a house that a child might draw. The only special thing we do here is tag parts of the diagram with the value function. Each part – the wall, door, handle, roof, chimney and smoke – has a single string attached to it.

-- The diagram to be drawn, with features tagged by strings.
prettyHouse :: QDiagram Cairo R2 [String]
prettyHouse =
    let smoke = mconcat [ circle 0.05 # moveTo (p2(x,y))
                        | (x,y) <- [ (0.75,1.85), (0.8,2) ] ]
                  # stroke # fc grey
        roof = fromVertices [p2(0,1), p2(0.5,1.75), p2(1,1)]
                 # mapLoc closeTrail # pathFromLocTrail # stroke
                 # fc blue
        chimney = fromVertices [p2(0.7,1.45), p2(0.7,1.7),
                                p2(0.8,1.7),  p2(0.8,1.3)]
                 # mapLoc closeTrail # pathFromLocTrail # stroke
                 # fc green
        wall = square 1 # stroke # fc yellow
                 # alignBL # moveTo (p2(0,0))
        door = rect 0.2 0.4 # stroke # fc red
                 # alignBL # moveTo (p2(0.4,0))
        handle = circle 0.02 # stroke # fc black
                 # moveTo (p2(0.55,0.2))
    in mconcat [ smoke   # value ["smoke"]
               , roof    # value ["roof"]
               , chimney # value ["chimney"]
               , handle  # value ["handle"]
               , door    # value ["door"]
               , wall    # value ["wall"]
               ]

Now we can query the points in the diagram to see what’s there.

λ: sample prettyHouse (p2(0,0)) 
["wall"]
λ: sample prettyHouse (p2(0,1)) 
["roof"]
λ: sample prettyHouse (p2(0.55,0.2)) 
["wall","door","handle"]
λ: sample prettyHouse (p2(2,0.2)) 
[]

With this we’re actually most of the way there. However, the coordinate system of the diagram is not the same as the mouse coordinates we’ll get from Gtk. We could take the mouse coordinates and transform them into diagram coordinates, but let’s do it the other way around and make the diagram coordinates as close to the mouse coordinates as possible.

Gtk’s mouse coordinates have the origin (0,0) at the top left of the canvas. So first we move the diagram’s origin to the top left:

alignTL $ prettyHouse

Then we scale the diagram so that it’s the same width as the canvas:

scaleUToX 250 . freeze . alignTL $ prettyHouse

(The freeze makes the line widths scale up too.)

Now we are almost done: our mouse and diagram coordinates are the same size. The last wrinkle is that in diagrams-land positive Y-coordinates go up, but in Gtk-land positive Y-coordinates go down. We could reflect the diagram before we sample from it, but I found it easier just to negate the Y-coordinate.

λ: sample (scaleUToX 250 . freeze . alignTL $ prettyHouse) (p2 (100,-200))
["roof"]
λ: sample (scaleUToX 250 . freeze . alignTL $ prettyHouse) (p2 (100,-300))
["wall"]

And we’re done! The rest of the program is basically just Gtk plumbing.

Here’s the whole program.

import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Data.List (intercalate)
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.Internal
import Diagrams.Prelude
import Graphics.UI.Gtk

main :: IO ()
main = do
  -- Ordinary Gtk setup.
  void initGUI
  w <- windowNew
  da <- drawingAreaNew
  w `containerAdd` da
  void $ w `on` deleteEvent $ liftIO mainQuit >> return True

  -- Take our diagram, move the origin to the top left, and scale it
  -- to the size of the drawing area.
  let scaledHouse = scaleUToX 250 . freeze . alignTL $ prettyHouse

  -- Render the diagram on the drawing area.
  void $ da `on` exposeEvent $ liftIO $ do
    dw <- widgetGetDrawWindow da
    let (_,r) = renderDia Cairo
                          (CairoOptions "" (Width 250) PNG False)
                          scaledHouse
    renderWithDrawable dw r
    return True

  -- When the mouse moves, show the coordinates and the objects under
  -- the pointer.
  void $ da `on` motionNotifyEvent $ do
    (x,y) <- eventCoordinates
    liftIO $ do
      -- We negate the "y" coordinate when sampling because in Gtk the
      -- "down" direction is positive, but in our diagram the "up"
      -- direction is positive.
      putStrLn $ show (x,y) ++ ": "
                   ++ intercalate " " (sample scaledHouse (p2(x,-y)))
      return True

  -- Run the Gtk main loop.
  da `widgetAddEvents` [PointerMotionMask]
  widgetShowAll w
  mainGUI

-- The diagram to be drawn, with features tagged by strings.
prettyHouse :: QDiagram Cairo R2 [String]
prettyHouse =
    let smoke = mconcat [ circle 0.05 # moveTo (p2(x,y))
                        | (x,y) <- [ (0.75,1.85), (0.8,2) ] ]
                  # stroke # fc grey
        roof = fromVertices [p2(0,1), p2(0.5,1.75), p2(1,1)]
                 # mapLoc closeTrail # pathFromLocTrail # stroke
                 # fc blue
        chimney = fromVertices [p2(0.7,1.45), p2(0.7,1.7),
                                p2(0.8,1.7),  p2(0.8,1.3)]
                 # mapLoc closeTrail # pathFromLocTrail # stroke
                 # fc green
        wall = square 1 # stroke # fc yellow
                 # alignBL # moveTo (p2(0,0))
        door = rect 0.2 0.4 # stroke # fc red
                 # alignBL # moveTo (p2(0.4,0))
        handle = circle 0.02 # stroke # fc black
                 # moveTo (p2(0.55,0.2))
    in mconcat [ smoke   # value ["smoke"]
               , roof    # value ["roof"]
               , chimney # value ["chimney"]
               , handle  # value ["handle"]
               , door    # value ["door"]
               , wall    # value ["wall"]
               ]