beer.lisp

;; beer.lisp
;; simple opengl playground
;; Load this in Lispworks, or Lispworks Personal, and type Ctrl+Shift+B
;; malkia@gmail.com

(eval-when (:compile-toplevel :execute :load-toplevel)
  (let ((lwdir (concatenate 'string (namestring *lispworks-directory*) "lib/6-0-0-0/")))
    (load (concatenate 'string lwdir "examples/opengl/defsys"))
    (load (concatenate 'string lwdir "examples/opengl/examples/defsys"))
    (compile-system 'opengl :load t :force nil)
    (compile-system 'opengl-examples :load t :force nil)))

(capi:define-interface beer ()
  (frame-timer)
  (:panes
   (fps capi:title-pane)
   (view opengl:opengl-pane
         :configuration '(:depth-buffer 32 :rgba t :double-buffer t)
         :display-callback 'display)
   (b1 capi:check-button
       :text "Real-time Update"
       :callback-type :interface
       :selection-callback (lambda (beer)
                             (mp:schedule-timer-relative-milliseconds
                              (slot-value beer 'frame-timer) 0 30))
       :retract-callback (lambda (beer)
                           (mp:unschedule-timer
                            (slot-value beer 'frame-timer))))
   (editor capi:editor-pane :buffer-name "beer.lisp" :echo-area t)
   (listener capi:listener-pane))
  (:layouts
   (main capi:row-layout '(gadgets ide))
   (ide capi:switchable-layout '(editor listener))
   (gadgets capi:column-layout '(fps view b1)))
  (:default-initargs
   :title "OpengGL Beer!"
   :visible-min-width 1024
   :visible-min-height 768))

(defmethod initialize-instance :after ((beer beer) &key &allow-other-keys)
  (setf (slot-value beer 'frame-timer)
        (mp:make-named-timer "Update Frame Timer"
                             'capi:execute-with-interface-if-alive
                             beer (lambda (canvas)
                                    (handler-case
                                        (let ((real-time (get-internal-real-time))
                                              (run-time (get-internal-run-time)))
                                          (display canvas
                                                   (first (slot-value canvas 'gp::origin))
                                                   (second (slot-value canvas 'gp::origin))
                                                   (slot-value canvas 'gp::width)
                                                   (slot-value canvas 'gp::height))
                                          (let ((real-time (- (get-internal-real-time) real-time))
                                                (run-time (- (get-internal-run-time) run-time)))
                                            (setf (capi:title-pane-text (slot-value beer 'fps))
                                                  (format nil "~A ~A" real-time run-time))))
                                      (t (error) (format t "ERROR: ~A~&" error))))
                             (slot-value beer 'view))))

(defmacro with-gl-block (mode &body body)
  `(progn (opengl:gl-begin ,mode)
     ,@body
     (opengl:gl-end)))

(defun display (canvas &rest rest)
  (opengl:rendering-on (canvas)
    (apply 'opengl:gl-viewport rest)
    (opengl:gl-clear-color 1.0 0.5 0.25 0.0)
    (opengl:gl-clear (logior opengl:*gl-color-buffer-bit* opengl:*gl-depth-buffer-bit*))
    (opengl:gl-shade-model opengl:*gl-smooth*)
    (opengl:gl-enable opengl:*gl-depth*)
    (opengl:gl-load-identity)
    (opengl:glu-perspective 90.0d0 1.0d0 0.10d0 20.0d0)
    (with-gl-block opengl:*gl-triangles*
      (let ((x0 (random 2.0))
            (y0 (random 2.0)))
        (dotimes (n 30)
          (let ((x (+ (* x0 0.8) (* 0.1 (random 2.0))))
                (y (+ (* y0 0.9) (* 0.1 (random 2.0)))))
            (opengl:gl-color4-f (random 1.0)
                                (random 1.0)
                                (random 1.0)
                                (random 1.0))
            (opengl:gl-vertex3-f (1- x0)
                                 (1- y0)
                                 -0.0)
            (opengl:gl-color4-f (random 1.0)
                                (random 1.0)
                                (random 1.0)
                                (random 1.0))
            (opengl:gl-vertex3-f (1- x)
                                 (1- y)
                                 -1.0)
            (opengl:gl-color4-f (random 1.0)
                                (random 1.0)
                                (random 1.0)
                                (random 1.0))
            (opengl:gl-vertex3-f 0.0
                                 0.0
                                 -20.0)))))
    (opengl:swap-buffers canvas)))

(when (and (boundp '*beer*)
           (eq (class-of *beer*)
               (find-class 'beer)))
  (capi:destroy *beer*)
  (setf *beer* nil)
  (makunbound '*beer*))

(defparameter *beer* (capi:display (make-instance 'beer)))