GTK 3 Custom Drawing Example

(* Surface to store current scribbles *)
val surface : Cairo.Surface.t option ref = ref NONE

fun clearSurface () =
  case !surface of
    NONE         => ()
  | SOME surface =>
      let
        val cr = Cairo.Context.create surface

        val () = Cairo.Context.setSourceRgb cr (1.0, 1.0, 1.0)
        val () = Cairo.Context.paint cr
      in
        ()
      end

(* Create a new surface of the appropriate size to store our scribbles *)
fun configureEventCb widget _ =
  let
    val () =
      case Gtk.Widget.getWindow widget of
        NONE        => ()  (* `widget` not realized, do nothing *)
      | SOME window => (
          surface :=
            SOME (
              Gdk.Window.createSimilarSurface window
                (
                  Cairo.Content.COLOR,
                  Gtk.Widget.getAllocatedWidth widget,
                  Gtk.Widget.getAllocatedHeight widget
                )
            )

          ; (* Initialize the surface to white *)
            clearSurface ()
        )
  in
    (* We've handled the configure event, no need for further processing. *)
    true
  end

(* Redraw the screen from the surface. Note that the ::draw
 * signal receives a ready-to-be-used cairo_t that is already
 * clipped to only draw the exposed areas of the widget
 *)
fun drawCb cr =
  case !surface of
    NONE         => false
  | SOME surface =>
      let
        val () = Cairo.Context.setSourceSurface cr (surface, 0.0, 0.0)
        val () = Cairo.Context.paint cr
      in
        false
      end

(* Draw a rectangle on the surface at the given position *)
fun drawBrush widget (x, y) =
  case !surface of
    NONE         => ()
  | SOME surface =>
      let
        (* Paint to the surface, where we store our state *)
        val cr = Cairo.Context.create surface

        val () = Cairo.Context.rectangle cr (x - 3.0, y - 3.0, 6.0, 6.0)
        val () = Cairo.Context.fill cr

        val xInt = Real.toLargeInt IEEEReal.TO_ZERO x
        val yInt = Real.toLargeInt IEEEReal.TO_ZERO y

        (* Now invalidate the affected region of the drawing area. *)
        val () = Gtk.Widget.queueDrawArea widget (xInt - 3, yInt - 3, 6, 6)
      in
        ()
      end

(* Handle button press events by either drawing a rectangle
 * or clearing the surface, depending on which button was pressed.
 * The ::button-press signal handler receives a GdkEventButton
 * struct which contains this information.
 *)
fun buttonPressEventCb widget (event : Gdk.EventButtonRecord.t) =
  (* paranoia check, in case we haven't gotten a configure event *)
  case !surface of
    NONE   => false
  | SOME _ =>
      let
        open Gdk

        val () =
          if #get Gdk.EventButton.button event = Gdk.BUTTON_PRIMARY
          then
            drawBrush widget (#get EventButton.x event, #get EventButton.y event)
          else if #get Gdk.EventButton.button event = Gdk.BUTTON_SECONDARY
          then
            (
              clearSurface ()
            ; Gtk.Widget.queueDraw widget
            )
          else
            ()
      in
        (* We've handled the event, stop processing *)
        true
      end

(* Handle motion events by continuing to draw if button 1 is
 * still held down. The ::motion-notify signal handler receives
 * a GdkEventMotion struct which contains this information.
 *)
fun motionNotifyEventCb widget event =
  (* paranoia check, in case we haven't gotten a configure event *)
  case !surface of
    NONE   => false
  | SOME _ =>
      let
        open Gdk

        val () =
          if ModifierType.anySet (#get EventMotion.state event, ModifierType.BUTTON_1_MASK)
          then
            drawBrush widget (#get EventMotion.x event, #get EventMotion.y event)
          else
            ()
      in
        (* We've handled it, stop processing *)
        true
      end

fun closeWindow () =
  case !surface of
    SOME _ => surface := NONE
  | NONE   => ()

fun activate app () =
  let
    open Gtk

    val window = ApplicationWindow.new app
    val () = Window.setTitle window "Window"

    val _ = Signal.connect window (Widget.destroySig, closeWindow)

    val () = Container.setBorderWidth window 8

    val frame = Frame.new NONE
    val () = Frame.setShadowType frame ShadowType.IN
    val () = Container.add window frame

    val drawingArea = DrawingArea.new ()
    (* set a minimum size *)
    val () = Widget.setSizeRequest drawingArea (100, 100)

    val () = Container.add frame drawingArea

    (* Signals used to handle the backing surface *)
    val _ = Signal.connect drawingArea (Widget.drawSig, drawCb)
    val _ = Signal.connect drawingArea (Widget.configureEventSig,
                                                   configureEventCb drawingArea)

    (* Event signals *)
    val _ = Signal.connect drawingArea (Widget.motionNotifyEventSig,
                                                motionNotifyEventCb drawingArea)
    val _ = Signal.connect drawingArea (Widget.buttonPressEventSig,
                                                 buttonPressEventCb drawingArea)

    (* Ask to receive events the drawing area doesn't normally
     * subscribe to. In particular, we need to ask for the
     * button press and motion notify events that want to handle.
     *)
    val () =
      Widget.setEvents drawingArea
        let
          open Gdk.EventMask
        in
          flags [Widget.getEvents drawingArea, BUTTON_PRESS_MASK, POINTER_MOTION_MASK]
        end

    val () = Widget.showAll window
  in
    ()
  end

fun main () =
  let
    val app = Gtk.Application.new (SOME "org.gtk.example", Gio.ApplicationFlags.FLAGS_NONE)
    val id = Signal.connect app (Gio.Application.activateSig, activate app)

    val argv = Utf8CPtrArrayN.fromList (CommandLine.name () :: CommandLine.arguments ())
    val status = Gio.Application.run app argv

    val () = Signal.handlerDisconnect app id
  in
    Giraffe.exit status
  end
    handle e => Giraffe.error 1 ["Uncaught exception\n", exnMessage e, "\n"]

val () = main ()

local
  $(SML_LIB)/basis/basis.mlb
  $(SML_LIB)/basis/mlton.mlb
  $(GIRAFFE_SML_LIB)/general/mlton.mlb
  $(GIRAFFE_SML_LIB)/gobject-2.0/mlton.mlb
  $(GIRAFFE_SML_LIB)/gio-2.0/mlton.mlb
  $(GIRAFFE_SML_LIB)/cairo-1.0/mlton.mlb
  $(GIRAFFE_SML_LIB)/gdk-3.0/mlton.mlb
  $(GIRAFFE_SML_LIB)/gtk-3.0/mlton.mlb
in
  example-4.sml
  mlton-main.sml
end

use "$(GIRAFFE_SML_LIB)/general/polyml.sml";
use "$(GIRAFFE_SML_LIB)/ffi/polyml.sml";
use "$(GIRAFFE_SML_LIB)/gir/polyml.sml";
use "$(GIRAFFE_SML_LIB)/glib-2.0/polyml.sml";
use "$(GIRAFFE_SML_LIB)/gobject-2.0/polyml.sml";
use "$(GIRAFFE_SML_LIB)/gio-2.0/polyml.sml";
use "$(GIRAFFE_SML_LIB)/gmodule-2.0/polyml.sml";
use "$(GIRAFFE_SML_LIB)/cairo-1.0/polyml.sml";
use "$(GIRAFFE_SML_LIB)/pango-1.0/polyml.sml";
use "$(GIRAFFE_SML_LIB)/pangocairo-1.0/polyml.sml";
use "$(GIRAFFE_SML_LIB)/gdkpixbuf-2.0/polyml.sml";
use "$(GIRAFFE_SML_LIB)/atk-1.0/polyml.sml";
use "$(GIRAFFE_SML_LIB)/gdk-3.0/polyml.sml";
use "$(GIRAFFE_SML_LIB)/xlib-2.0/polyml.sml";
use "$(GIRAFFE_SML_LIB)/gtk-3.0/polyml.sml";

(* For each line of the form
 *
 *   use "<file>";
 *
 * <file> is taken as a build dependency.
 *)

use "example-4.sml";

################################################################################
# Application-specific values

NAME := example-4


# MLton target
#
# Define:
#   SRC_MLTON       - the SML source files for MLton
#   TARGET_MLTON    - the binary to be built with MLton

ifdef MLTON_VERSION

SRC_MLTON := $(shell $(MLTON_MLTON) -mlb-path-var 'GIRAFFE_SML_LIB $(GIRAFFE_SML_LIBDIR)' -stop f mlton.mlb)

TARGET_MLTON := $(NAME)-mlton

endif


# Poly/ML target
#
# Define:
#   SRC_POLYML      - the SML source files for Poly/ML
#   TARGET_POLYML   - the binary to be built with Poly/ML

ifdef POLYML_VERSION

SRC_POLYML := $(shell cat polyml-app.sml | sed -n 's|^use "\([^"]*\)";$$|\1|p')

TARGET_POLYML := $(NAME)-polyml

endif


# Library dependencies
#
# Define:
#   LIB_NAMES       - list of the libraries that the application references

LIB_NAMES := \
	gobject-2.0 \
	gio-2.0 \
	cairo-1.0 \
	gdk-3.0 \
	gtk-3.0

# Note that LIB_NAMES does _not_ contain pkg-config names but GIR namespace
# names, which are also the directory names in $(GIRAFFEHOME)/lib/sml.
#
# One method to determine the list is as follows: for each instance of
#
#   $(GIRAFFE_SML_LIB)/$(LIB_NAME)/mlton.mlb
#
# in mlton.mlb, the list should include $(LIB_NAME).