From 1bb4217f677a7eafdd9859a0afe61544e17b98a9 Mon Sep 17 00:00:00 2001 From: Pavel Korolev Date: Sun, 13 May 2018 18:13:56 +0300 Subject: [PATCH] Initial commit --- .gitignore | 18 ++++ LICENSE | 21 ++++ README.md | 37 +++++++ appkit.lisp | 260 +++++++++++++++++++++++++++++++++++++++++++++++ bodge-appkit.asd | 12 +++ packages.lisp | 15 +++ 6 files changed, 363 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 README.md create mode 100644 appkit.lisp create mode 100644 bodge-appkit.asd create mode 100644 packages.lisp diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..19955a6 --- /dev/null +++ b/.gitignore @@ -0,0 +1,18 @@ +# lisp junk +*.FASL +*.fasl +*.lisp-temp + +# emacs junk +\#* +*~ +.\#* + +# system dependent junk +local/ + +# macOS junk +**/.DS_Store + +# docs +docs/ \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..d96ecd4 --- /dev/null +++ b/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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..2102b7a --- /dev/null +++ b/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` diff --git a/appkit.lisp b/appkit.lisp new file mode 100644 index 0000000..02afea2 --- /dev/null +++ b/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))) diff --git a/bodge-appkit.asd b/bodge-appkit.asd new file mode 100644 index 0000000..e28d79e --- /dev/null +++ b/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"))) diff --git a/packages.lisp b/packages.lisp new file mode 100644 index 0000000..005882a --- /dev/null +++ b/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))