trivial-gui.lisp

(defpackage #:trivial-gui
  (:use #:cl))

(in-package #:trivial-gui)

(defmethod glop:on-key (window pressed keycode keysym text)
  (format t "Key ~:[released~;pressed~]: ~D (~S ~S)~%" pressed keycode keysym text)
  (format t "Key pressed: ~S~%" (glop:key-pressed keycode))
  (when (and (not pressed) (eq keysym :escape))
    (glop:push-close-event window))
  (case keysym
    (:h (glop:hide-cursor window))
    (:j (glop:show-cursor window))
    (:left (decf (glop:window-x window)))
    (:right (incf (glop:window-x window)))
    (:up (decf (glop:window-y window)))
    (:down (incf (glop:window-y window)))
    (:page-up (progn (incf (glop:window-width window) 10)
                     (incf (glop:window-height window) 10)))
    (:page-down (progn (decf (glop:window-width window) 10)
                       (decf (glop:window-height window) 10))))
  (when (and (not pressed) (eq keysym :f))
    (glop:toggle-fullscreen window))
  (when (and (not pressed) (eq keysym :g))
    (glop:set-fullscreen window)))

(defmethod glop:on-button (window pressed button)
  (declare (ignore window))
  (format t "Button ~:[released~;pressed~]: ~S~%" pressed button))

(defmethod glop:on-mouse-motion (window x y dx dy)
  (declare (ignore window x y dx dy))
  (format t "Mouse motion~%"))

(defmethod glop:on-resize (window w h)
  (declare (ignore window))
  (gl:viewport 0 0 w h)
  (format t "Resize: ~Sx~S~%" w h))

(defmethod glop:on-draw (window)
  (declare (ignore window))
  (format t "Draw~%"))

(defmethod glop:on-close (window)
  (declare (ignore window))
  (format t "Close~%"))

(defclass gui-element ()
  ((origin :accessor origin-of :initarg :origin :initform '(0.0 0.0))
   (size :accessor size-of :initarg :size :initform '(0.0 0.0))))

(defparameter *gui* nil)

(defun make-gui-element (x y w h)
  (let ((element 
		 (make-instance 'gui-element :origin (list x y) :size (list w h))))
  (pushnew element *gui*)))


(defun draw-quad (x y w h color)
  (gl:with-primitives :quads
	(let ((r (car color))
		  (g (cadr color))
		  (b (caddr color)))
	(gl:color r g b)
	(gl:vertex x (+ y h))
	(gl:color r g b)
	(gl:vertex (+ x w) (+ y h))
	(gl:color  r g b)
	(gl:vertex (+ x w) y)
	(gl:color r g b)
	(gl:vertex x y))))


(defgeneric render (element))

(defmethod render ((e gui-element))
  (let ((x (car (origin-of e)))
		(y (cadr (origin-of e)))
		(w (car (size-of e)))
		(z (cadr (size-of e))))
  (draw-quad  x y z w '(1.0 0.0 0.0))))

(defmacro continuable (&body body)
  "Helper macro that we can use to allow us to continue from an
error. Remember to hit C in slime or pick the restart so errors don't kill the app."
  `(restart-case (progn ,@body) (continue () :report "Continue")))

(defun update-swank ()
  "Called from within the main loop, this keep the lisp repl
working while trivial-gui runs"
  (continuable (let ((connection (or swank::*emacs-connection* (swank::default-connection)))) (when connection																							(swank::handle-requests connection t)))))

(defun draw-gui ()
  (when *gui*
	(mapcar #'render *gui*)))

(defun trivial-gui (&key (window-name "Trivial Gui") (window-width 800) (window-height 600))
  (glop:with-window (win window-name window-width window-height)
    (format t "Created window: ~S~%" win)
    (gl:clear-color 0.3 0.3 1.0 0)
    (loop while (glop:dispatch-events win :blocking nil) do
		 (update-swank)
		 (gl:clear :color-buffer)
		 ;; to do -- add an exit loop restart?
		 (with-simple-restart (skip-trivial-gui-loop "Skip Trivial GUI loop body")
		   (draw-gui))
         (gl:flush)
         (glop:swap-buffers win))))