No examples of using DrawingArea and gtk_drawing_area_set_draw_func about cl-gtk4 HOT 10 CLOSED

(ql:quickload :cl-gtk4)
(ql:quickload :cl-gdk4)
(ql:quickload :cl-cairo2)

(cl:defpackage cairo-gobject
  (:use)
  (:export #:*ns*))

(cl:in-package #:cairo-gobject)

(gir-wrapper:define-gir-namespace "cairo")

(cl:defpackage gtk4-cairo.example
  (:use #:cl #:gtk4))

(cl:in-package #:gtk4-cairo.example)

(cffi:defcstruct gdk-rgba
  (red :double)
  (green :double)
  (blue :double)
  (alpha :double))

(defmacro with-gdk-rgba ((pointer color) &body body)
  `(cffi:with-foreign-object (,pointer '(:struct gdk-rgba))
     (let ((,pointer (make-instance 'gir::struct-instance
                                     :class (gir:nget gdk::*ns* "RGBA")
                                     :this ,pointer)))
       (gdk:rgba-parse ,pointer ,color)
       ,@body)))

(defun draw-func (area cr width height)
  (let ((style-context (gtk:widget-style-context area)))
    (cairo:arc (/ (coerce (the (signed-byte 32) width) 'single-float) 2.0)
               (/ (coerce (the (signed-byte 32) height) 'single-float) 2.0)
               (/ (min width height) 2.0) 0.0 (* 2.0 (coerce pi 'single-float)))

    (let ((color (gtk:style-context-color style-context)))
      (gdk:cairo-set-source-rgba cr color)
      (cairo:fill-path))
    (cairo:arc (/ (coerce (the (signed-byte 32) width) 'single-float) 2.0)
               (/ (coerce (the (signed-byte 32) height) 'single-float) 2.0)
               (/ (min width height) 4.0) 0.0 (* 2.0 (coerce pi 'single-float)))
    (with-gdk-rgba (color "#FFFFFFFF")
      (gdk:cairo-set-source-rgba cr color)
      (cairo:fill-path))))

(cffi:defcallback %draw-func :void ((area :pointer)
                                    (cr :pointer)
                                    (width :int)
                                    (height :int)
                                    (data :pointer))
  (declare (ignore data))
  (let ((cairo:*context* (make-instance 'cairo:context
                                        :pointer cr
                                        :width width
                                        :height height
                                        :pixel-based-p nil)))
    (draw-func (make-instance 'gir::object-instance
                              :class (gir:nget gtk:*ns* "DrawingArea")
                              :this area)
               (make-instance 'gir::struct-instance
                              :class (gir:nget cairo-gobject:*ns* "Context")
                              :this cr)
               width height)))

(defun main ()
  (let ((app (make-application :application-id "org.bohonghuang.cl-gtk4-cairo-example"
                               :flags gio:+application-flags-flags-none+)))
    (connect app "activate"
                             (lambda (app)
                               (let ((window (make-application-window :application app)))
                                 (setf (window-title window) "Drawing Area Test")
                                 (let ((area (gtk:make-drawing-area)))
                                   (setf (drawing-area-content-width area) 100
                                         (drawing-area-content-height area) 100
                                         (drawing-area-draw-func area) (list (cffi:callback %draw-func)
                                                                             (cffi:null-pointer)
                                                                             (cffi:null-pointer)))
                                   (setf (window-child window) area))
                                 (window-present window))))
    (gio:application-run app nil)
    (gio:application-quit app)))

(main)