Example simple UI key driven app written in Common Lisp

simple-ui.lisp

(declaim (optimize (speed 1) (safety 2) (debug 3)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload '(:draw-cons-tree :alexandria :serapeum :cl-cffi-gtk :defclass-std)))

(require 'sb-concurrency)

(defpackage :struct-ui-device
  (:use #:cl
        #:cffi
        #:gtk #:gdk #:gdk-pixbuf #:gobject #:glib #:gio #:pango #:cairo))
;; (load  "~/Programming/Lisp/lispy-experiments/struct-ui-device.lisp")
(in-package :struct-ui-device)
;;; *** ===============================================================================

(defstruct ui
  (model)
  (view)
  (canvas))

(defstruct model
  (mode)
  (playing)
  (m-pressed)
  (n-pressed))

(defstruct my-key
  (modifiers)
  (string)
  (name))

;;; *** ===============================================================================
(defun init-model (model)
  (setf (model-mode model) :radio
        (model-playing model) :st1)
  model)

(defun next-model (model)
  (setf (model-n-pressed model) t)
  (case (model-mode model)
    (:radio
     (setf (model-playing model) (case (model-playing model)
                                   (:st1 :st2)
                                   (:st2 :st3)
                                   (:st3 :st1)
                                   (otherwise :error))))
    (:cd
     (setf (model-playing model) (case (model-playing model)
                                   (:tr1 :tr2)
                                   (:tr2 :tr3)
                                   (:tr3 :tr1)
                                   (otherwise :error))))
    (otherwise  (error "mode ~S in not expected"  (model-mode model)))))

(defun mode-model (model)
  (setf (model-m-pressed model) t)
  (case (model-mode model)
    (:radio
     (setf (model-mode model) :cd
           (model-playing model) :tr1))
    (:cd
     (setf (model-mode model) :radio
           (model-playing model) :st1))
    (otherwise (error "mode ~S in not expected"  (model-mode model))))

  (warn "modeing ~S" model))

(defun state-of-model (model)
  (format nil "~a ~a ~a ~a"
          (if (model-m-pressed model) "M" " ")
          (if (eq :radio (model-mode model)) "radio" "cd   ")
          (model-playing model)
          (if (model-n-pressed model) "N" " ")))

(defun status-model (model)
  (warn "status - mode ~s - playing ~S - ~S - ~S"
        (model-mode model)
        (model-playing model)
        (if (model-m-pressed model) "M" "m")
        (if (model-n-pressed model) "N" "n")))

;;; *** ===============================================================================
(defun key-update (model kp type)
  (case type
    (:key-press
     (cond
       ((equalp kp #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n"))
        (next-model model))
       ((equalp kp #S(MY-KEY :MODIFIERS NIL :STRING "m" :NAME "m"))
        (mode-model model))))
    (:key-release
     (cond
       ((equalp kp #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n"))
        (setf (model-n-pressed model) nil))
       ((equalp kp #S(MY-KEY :MODIFIERS NIL :STRING "m" :NAME "m"))
        (setf (model-m-pressed model) nil))))
    (otherwise (error "wrong type ~S" type)))
  (status-model model)
  model)

;;; *** ===============================================================================
(defun build-my-key-modifiers (event)
  (mapcar
   (lambda (y)
     (cond ((eql y :MOD1-MASK)
            :ALT)
           ((eql y :SHIFT-MASK)
            :SHIFT)
           ((eql y :CONTROL-MASK)
            :CONTROL)
           ((eql y :MOD5-MASK)
            :ALTGR)
           ((eql y :SUPER-MASK)
            :SUPER)
           (t y)))
   (remove-if
    (lambda (x)
      (member x '(:MOD2-MASK :MOD4-MASK)))
    (gdk-event-key-state event))))

(defun build-my-key (event)
  (make-my-key
   :modifiers (build-my-key-modifiers event)
   :string (gdk-event-key-string event)
   :name (gdk-keyval-name (gdk-event-key-keyval event))))

;;; *** ===============================================================================

(defun simulated-key-update ()
  (let ((model (init-model (make-model))))
    (loop for kpx in (list
                      (list #S(MY-KEY :MODIFIERS NIL :STRING "a" :NAME "a")
                            :KEY-PRESS)
                      (list #S(MY-KEY :MODIFIERS NIL :STRING "a" :NAME "a")
                            :KEY-RELEASE)

                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-PRESS)
                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-RELEASE)

                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-PRESS)
                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-RELEASE)

                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-PRESS)
                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-RELEASE)

                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-PRESS)
                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-RELEASE)


                      (list #S(MY-KEY :MODIFIERS NIL :STRING "m" :NAME "m")
                            :KEY-PRESS)
                      (list #S(MY-KEY :MODIFIERS NIL :STRING "m" :NAME "m")
                            :KEY-RELEASE)

                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-PRESS)
                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-RELEASE)

                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-PRESS)
                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-RELEASE)

                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-PRESS)
                      (list #S(MY-KEY :MODIFIERS NIL :STRING "n" :NAME "n")
                            :KEY-RELEASE)


                      (list #S(MY-KEY :MODIFIERS NIL :STRING "m" :NAME "m")
                            :KEY-PRESS)
                      (list #S(MY-KEY :MODIFIERS NIL :STRING "m" :NAME "m")
                            :KEY-RELEASE))
          do
             (setf model (key-update model (elt kpx 0) (elt kpx 1))))
    model))

;;; *** ===============================================================================

;;; view

(defun draw-view (ui cr)
  (let ((model (ui-model ui)))
    (cond
      ((and (model-m-pressed model)
            (model-n-pressed model))
       (cairo-set-source-rgb cr 1.0 0.0 0.0))
      ((model-m-pressed model)
       (cairo-set-source-rgb cr 0.0 1.0 0.0))
      ((model-n-pressed model)
       (cairo-set-source-rgb cr 0.0 0.0 1.0))
      (t
       (cairo-set-source-rgb cr 1.0 1.0 1.0)))
    (cairo-paint cr)

    (let ((the-text (state-of-model model)))
      (cairo-set-source-rgb cr 0.0 0.0 0.0)
      ;; test works best with mono fonts
      (cairo-select-font-face cr "Ubuntu Mono" :normal :bold)
      (cairo-set-font-size cr 40)
      (cairo-move-to cr 20 80)
      (cairo-show-text cr the-text))))

;;; *** ===============================================================================

(defun draw-canvas (ui widget context)
  (declare (ignore widget)) ; we may need widget for the canvas dimensions
  (let ((cr (pointer context)))
    (cairo-reference cr)
    (draw-view ui cr)
    (cairo-destroy cr)))

(defun widget-event (ui widget event)
  (case (type-of event)
    (gdk-event-motion
     nil)
    (gdk-event-key
     (key-update (ui-model ui) (build-my-key event) (gdk-event-key-type event))
     (gtk-widget-queue-draw (ui-canvas ui)))
    (otherwise
     (warn "not handled ~a"
           (if (member (type-of event) '(gdk-event-key))
               (format nil "~&~S widget event ~S ~S" (type-of widget) (type-of event) event)
               (format nil "~&~S widget event ~S ~S" (type-of widget) (type-of event) (gdk-event-type event)))))))

;;; * basic events ******************************************
(defun win-delete-event (ui widget  event)
  (declare (ignore ui widget))
  "Event for graceful closing of the window."
  (format t "Delete Event occurred.~A~%" event)
  (if (progn
        (warn "finish win-delete-event-fun condition")
        T)
      (progn
        (format t "~&QUITTING~%")
        (leave-gtk-main)
        +gdk-event-propagate+)

      (progn
        (format t "the window was not permitted to close~A~% ")
        +gdk-event-stop+)))

(defun add-new-window (ui app)
  (let ((window (make-instance 'gtk-application-window
                               :application app
                               :title "SVG window"
                               :default-width 500
                               :default-height 300))
        (box (make-instance 'gtk-box
                            :border-width 1
                            :orientation :vertical
                            :spacing 1))
        (canvas (make-instance 'gtk-drawing-area
                               :width-request 500
                               :height-request 270)))

    ;; packing widgets
    (gtk-container-add window box)
    (gtk-box-pack-start box canvas)

    ;; signals

    ;; canvas events inherited from the widget
    (loop for ev in (list "configure-event"
                          "motion-notify-event"
                          "scroll-event"
                          "button-press-event"
                          "button-release-event")
          do (g-signal-connect canvas ev (lambda (widget event)
                                           (widget-event ui widget event))))

    ;; canvas events
    ;; this does the VIEW part of out architecture
    (g-signal-connect canvas "draw" (lambda (widget context)
                                      (draw-canvas ui widget context)))

    (gtk-widget-add-events canvas '(:all-events-mask))

    ;; add canvas to our grand structure
    (setf (ui-canvas ui) canvas)

    ;; window events inherited form the widget
    (loop for ev in (list "key-press-event"
                          "key-release-event"
                          "enter-notify-event"
                          "leave-notify-event")
          do (g-signal-connect window ev (lambda (widget event)
                                           (widget-event ui widget event))))

    ;; Signal handler for closing the window and to handle the signal "delete-event".
    (g-signal-connect window "delete-event" (lambda (widget event)
                                              (win-delete-event ui widget event)))

    ;; finally show all widgets
    (gtk-widget-show-all window)))

(defun main ()
  (let ((app (gtk-application-new "struct.window" :none))
        (ui (make-ui))
        (model (make-model)))

    (setf (ui-model ui) (init-model model)
          (ui-view ui) nil)

    (g-signal-connect app "activate" (lambda (a)
                                       (add-new-window ui a)))
    (let ((status (g-application-run app 0 (null-pointer))))
      (g-object-unref (pointer app))
      status)))