Initial commit

.gitignore

@@ -0,0 +1,18 @@
+# lisp junk
+*.FASL
+*.fasl
+*.lisp-temp
+
+# emacs junk
+\#*
+*~
+.\#*
+
+# system dependent junk
+local/
+
+# macOS junk
+**/.DS_Store
+
+# docs
+docs/

LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2016-2018 Pavel Korolev
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

README.md

@@ -0,0 +1,37 @@
+# bodge-appkit
+
+Simple facade over basic `cl-bodge` facilities for quick application bootstrapping.
+
+
+## Requirements
+
+* OpenGL 3.3+
+* 64-bit (x86_64) Windows, GNU/Linux or macOS
+* x86_64 SBCL, CCL or ECL
+
+
+## Installation and loading
+
+```lisp
+;; add cl-bodge distribution into quicklisp
+(ql-dist:install-dist "http://bodge.borodust.org/dist/org.borodust.bodge.txt" :replace t)
+
+;; load the appkit
+(ql:quickload :bodge-appkit)
+```
+
+
+## Example
+
+Copy-paste these into your Common Lisp REPL after loading `bodge-appkit`:
+
+```lisp
+(appkit:defapp example () ())
+
+(appkit:start 'example)
+```
+
+
+## Help
+
+`#lispgames` at `irc://chat.freenode.net`

appkit.lisp

@@ -0,0 +1,260 @@
+(cl:in-package :bodge-appkit)
+
+
+(declaim (special *font*))
+
+(defvar +origin+ (vec2 0.0 0.0))
+(defvar *black* (vec4 0 0 0 1))
+(defvar *window-class-list* (mt:make-guarded-reference nil))
+(defvar *appkit-instance-class* nil)
+
+(defvar *default-viewport-width* 640)
+(defvar *default-viewport-height* 480)
+(defvar *default-viewport-title* "Bodge Appkit")
+
+
+
+(defclass appkit-system (enableable generic-system)
+  ((framebuffer-size :initform (vec2 640 480) :accessor %framebuffer-size-of)
+   (viewport-width :initform *default-viewport-width*)
+   (viewport-height :initform *default-viewport-height*)
+   (updated-p :initform nil)
+   (canvas :initform nil :reader canvas-of)
+   (font :initform nil :reader font-of)
+   (ui :initform nil :reader ui-of)
+   (input-source :initform nil)
+   (action-queue :initform (make-task-queue))
+   (injected-flows :initform nil))
+  (:default-initargs :depends-on '(ge.host:host-system ge.gx:graphics-system)))
+
+
+(defgeneric app-configuration-flow (appkit)
+  (:method ((this appkit-system)) (declare (ignore this))))
+
+
+(defmethod update-instance-for-redefined-class :after ((this appkit-system)
+                                                       added-slots
+                                                       discarded-slots
+                                                       property-list
+                                                       &rest initargs)
+  (declare (ignore added-slots discarded-slots property-list initargs))
+  (with-slots (updated-p) this
+    (setf updated-p t)))
+
+
+(defun split-opts (opts)
+  (loop for opt in opts
+        if (member (first opt) '(:viewport-width
+                                 :viewport-height
+                                 :viewport-title
+                                 :fullscreen-p
+                                 :windows))
+          collect opt into extended
+        else
+          collect opt into std
+        finally (return (values std extended))))
+
+
+(defun viewport-pixel-ratio ()
+  (let* ((vp-size (ge.host:viewport-size))
+         (fb-size (ge.host:framebuffer-size)))
+    (/ (x fb-size) (x vp-size))))
+
+
+(defun update-viewport (app viewport-title viewport-width viewport-height fullscreen-p)
+  (with-slots (framebuffer-size) app
+      (setf (ge.host:viewport-title) viewport-title
+            (ge.host:fullscreen-viewport-p) fullscreen-p
+            (ge.host:viewport-title) viewport-title
+            (ge.host:viewport-size) (vec2 viewport-width viewport-height))
+    (let ((pixel-ratio (viewport-pixel-ratio)))
+      (setf framebuffer-size (vec2 (* viewport-width pixel-ratio)
+                                   (* viewport-height pixel-ratio))))))
+
+
+(defun update-graphics (this viewport-width viewport-height window-classes)
+  (with-slots (canvas ui) this
+    (ge.vg:update-canvas-size canvas viewport-width viewport-height)
+    (ge.ui:update-ui-size ui viewport-width viewport-height)
+    (ge.ui:with-ui-access (ui)
+      (ge.ui:remove-all-windows)
+      (dolist (window-class window-classes)
+        (ge.ui:add-window window-class)))
+      (initialize-user-interface this)
+    (ge.ui:compose-ui ui)))
+
+
+(defun %app-update-flow (app viewport-title viewport-width viewport-height
+                         fullscreen-p window-classes)
+  (let ((width (or viewport-width *default-viewport-width*))
+        (height (or viewport-height *default-viewport-height*)))
+    (>> (ge.host:for-host ()
+          (update-viewport app
+                           (or viewport-title *default-viewport-title*)
+                           width height fullscreen-p))
+        (ge.gx:for-graphics ()
+          (update-graphics app width height window-classes)))))
+
+
+(defmacro defapp (name (&rest classes) &body ((&rest slots) &rest opts))
+  (multiple-value-bind (std-opts extended) (split-opts opts)
+    `(progn
+       (defclass ,name (appkit-system ,@classes)
+         ,slots
+         ,@std-opts)
+       ,(with-hash-entries ((viewport-width :viewport-width)
+                            (viewport-height :viewport-height)
+                            (viewport-title :viewport-title)
+                            (fullscreen-p :fullscreen-p)
+                            (windows :windows))
+            (alist-hash-table extended)
+          `(defmethod app-configuration-flow ((this ,name))
+             (%app-update-flow this
+                               ,(first viewport-title)
+                               ,(first viewport-width)
+                               ,(first viewport-height)
+                               ,(first fullscreen-p)
+                               (list ,@windows))))
+       (make-instances-obsolete ',name))))
+
+
+(defmethod initialize-instance :around ((this appkit-system) &key)
+  (when (null *appkit-instance-class*)
+    (error "Manual appkit instance creation forbidden. Use #'appkit:start"))
+  (call-next-method))
+
+
+(defun app ()
+  (when *appkit-instance-class*
+    (ge.ng:engine-system *appkit-instance-class*)))
+
+
+(defgeneric act (system)
+  (:method ((system appkit-system)) (declare (ignore system))))
+
+
+(defgeneric draw (system)
+  (:method ((system appkit-system)) (declare (ignore system))))
+
+
+(defgeneric initialize-user-interface (system)
+  (:method ((system appkit-system)) (declare (ignore system))))
+
+
+(defgeneric post-initialize (system)
+  (:method ((system appkit-system)) (declare (ignore system))))
+
+
+(defgeneric pre-destroy (system)
+  (:method ((system appkit-system)) (declare (ignore system))))
+
+
+(defmacro when-app ((appkit-var) &body body)
+  `(when-let ((,appkit-var (app)))
+     ,@body))
+
+
+(defun push-action (app action)
+  (with-slots (action-queue) app
+    (push-task action action-queue)))
+
+
+(defmethod dispatch ((this appkit-system) (task function) invariant &key)
+  (declare (ignore invariant))
+  (push-action this task))
+
+
+(defun inject-flow (flow)
+  (when-let ((app-instance (app)))
+    (flet ((%inject-flow ()
+             (with-slots (injected-flows) app-instance
+               (push flow injected-flows))))
+      (push-action app-instance #'%inject-flow))))
+
+
+(define-event-handler on-framebuffer-change ((ev ge.host:framebuffer-size-change-event) width height)
+  (when-let ((appkit (app)))
+    (flet ((update-framebuffer ()
+             (setf (%framebuffer-size-of appkit) (vec2 width height))))
+      (push-action appkit #'update-framebuffer))))
+
+
+(defun %initialize-graphics (this pixel-ratio)
+  (with-slots (viewport-width viewport-height canvas font ui input-source) this
+    (setf canvas (ge.vg:make-canvas viewport-width
+                                    viewport-height
+                                    :pixel-ratio pixel-ratio
+                                    :antialiased nil)
+          font (ge.vg:make-default-font)
+          input-source (ge.ui:make-host-input-source)
+          ui (ge.ui:make-ui viewport-width viewport-height :pixel-ratio pixel-ratio
+                                                           :input-source input-source
+                                                           :antialiased nil)
+          (ge.host:swap-interval) 1)
+    (ge.ui:attach-host-input-source input-source)))
+
+
+(defun draw-app (this)
+  (with-slots (ui canvas font framebuffer-size) this
+    (gl:viewport 0 0 (x framebuffer-size) (y framebuffer-size))
+    (gl:clear :color-buffer :depth-buffer :stencil-buffer)
+    (let ((*font* font))
+      (ge.vg:with-canvas (canvas)
+        (draw this))
+      (ge.ui:compose-ui ui))
+    (ge.host:swap-buffers)))
+
+
+(defun %app-loop (this)
+  (with-slots (action-queue ui canvas font updated-p injected-flows) this
+    (labels ((%act ()
+               (drain action-queue)
+               (act this)))
+      (loop-flow (>> (->> ()
+                       (when updated-p
+                         (setf updated-p nil)
+                         (app-configuration-flow this)))
+                     (->> ()
+                       (when injected-flows
+                         (prog1 (nreverse injected-flows)
+                           (setf injected-flows nil))))
+                     (instantly () (%act))
+                     (ge.gx:for-graphics () (draw-app this)))
+                 (lambda () (enabledp this))))))
+
+
+(defmethod enabling-flow ((this appkit-system))
+  (>> (call-next-method)
+      (ge.host:for-host ()
+        (viewport-pixel-ratio))
+      (ge.gx:for-graphics (pixel-ratio)
+        (%initialize-graphics this pixel-ratio))
+      (app-configuration-flow this)
+      (instantly ()
+        (post-initialize this)
+        (run (>> (%app-loop this)
+                 (instantly ()
+                   (pre-destroy this)))))))
+
+
+;;;
+;;; Startup routines
+;;;
+(defun start (classname &key (log-level :info) (opengl-version '(3 3)) blocking)
+  (when *appkit-instance-class*
+    (error "Only one active system of type 'appkit-system is allowed"))
+  (setf *appkit-instance-class* classname)
+  (startup `(:engine (:systems (,classname) :log-level ,log-level)
+             :host (:opengl-version ,opengl-version))
+           :blocking blocking))
+
+
+(defun stop ()
+  (unwind-protect
+       (shutdown)
+    (setf *appkit-instance-class* nil)))
+
+
+(define-event-handler on-exit ((ev ge.host:viewport-hiding-event))
+  (in-new-thread "exit-thread"
+    (stop)))

bodge-appkit.asd

@@ -0,0 +1,12 @@
+(asdf:defsystem bodge-appkit
+  :description "Simple facade for cl-bodge facilities"
+  :version "1.0.0"
+  :author "Pavel Korolev"
+  :mailto "dev@borodust.org"
+  :license "MIT"
+  :depends-on (log4cl cl-bodge/graphics cl-bodge/audio cl-bodge/host
+                      cl-bodge/resources cl-bodge/canvas cl-bodge/ui
+                      uiop cl-muth cl-fad cl-muth)
+  :serial t
+  :components ((:file "packages")
+               (:file "appkit")))

packages.lisp

@@ -0,0 +1,15 @@
+(cl:defpackage :bodge-appkit
+  (:nicknames :appkit)
+  (:use :cl :cl-bodge.engine :cl-bodge.utils :cl-bodge.resources)
+  (:export start
+           stop
+
+           defapp
+           appkit
+           act
+           draw
+           inject-flow
+
+           initialize-user-interface
+           post-initialize
+           pre-destroy))