├── .gitattributes ├── flare-logo.png ├── docs └── flare-logo.png ├── scene.lisp ├── README.md ├── staple.ext.lisp ├── paintable.lisp ├── toolkit.lisp ├── LICENSE ├── flare.asd ├── clock.lisp ├── designdoc ├── indexed-set.lisp ├── forms.lisp ├── package.lisp ├── parser.lisp ├── container.lisp ├── easings.lisp ├── queue.lisp ├── change.lisp ├── animation.lisp └── documentation.lisp /.gitattributes: -------------------------------------------------------------------------------- 1 | *.lisp eof=lf 2 | doc/ linguist-vendored 3 | -------------------------------------------------------------------------------- /flare-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Shinmera/flare/HEAD/flare-logo.png -------------------------------------------------------------------------------- /docs/flare-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Shinmera/flare/HEAD/docs/flare-logo.png -------------------------------------------------------------------------------- /scene.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare) 2 | 3 | (defgeneric location (entity)) 4 | 5 | (defclass scene (scene-graph clock paintable animatable) 6 | ()) 7 | 8 | (defclass entity (container-unit paintable animatable) 9 | ((location :initarg :location :accessor location)) 10 | (:default-initargs 11 | :location (vec 0 0 0))) 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # This repository has [moved](https://shinmera.com/projects/flare)! 2 | Due to Microsoft's continued enshittification of the platform this repository has been moved to [Codeberg](https://shinmera.com/projects/flare) in August of 2025. It will not receive further updates or patches. **Issues and pull requests will not be looked at here either**, please submit your patches and issue tickets on Codeberg, or send them directly via good old email patches to [shirakumo@tymoon.eu](mailto:shirakumo@tymoon.eu). 3 | 4 | Thanks. -------------------------------------------------------------------------------- /staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:flare-staple 2 | (:nicknames #:org.shirakumo.fraf.flare.staple) 3 | (:use #:cl)) 4 | (in-package #:org.shirakumo.fraf.flare.staple) 5 | 6 | (defclass easing (definitions:global-definition) ()) 7 | 8 | (definitions:define-simple-type-map easing flare:easing) 9 | (definitions:define-simple-object-lookup easing flare:easing) 10 | (definitions:define-simple-documentation-lookup easing flare:easing) 11 | (definitions:define-simple-definition-resolver easing flare:easing) 12 | (defmethod staple:definition-order ((_ easing)) 91) 13 | -------------------------------------------------------------------------------- /paintable.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare) 2 | 3 | (defgeneric call-with-translation (func target vec)) 4 | (defgeneric visibility (paintable)) 5 | (defgeneric paint (paintable target)) 6 | 7 | (defmethod paint (paintable target) 8 | paintable) 9 | 10 | (defmacro with-translation ((vec target) &body body) 11 | `(call-with-translation (lambda () ,@body) ,target ,vec)) 12 | 13 | (defclass target () 14 | ()) 15 | 16 | (defclass paintable () 17 | ((visibility :initarg :visibility :accessor visibility)) 18 | (:default-initargs :visibility 1.0)) 19 | -------------------------------------------------------------------------------- /toolkit.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare) 2 | 3 | (defmacro define-self-returning-method (name arglist) 4 | (let ((o (first arglist))) 5 | `(defmethod ,name :around ,arglist 6 | (declare (ignore ,@(lambda-fiddle:extract-lambda-vars (cdr arglist)))) 7 | (call-next-method) 8 | ,(if (listp o) (first o) o)))) 9 | 10 | (defun ensure-sorted (vec sorting &key key) 11 | (let ((sorted (stable-sort vec sorting :key key))) 12 | (unless (eq vec sorted) 13 | (loop for i from 0 to (length vec) 14 | do (setf (aref vec i) (aref sorted i)))) 15 | vec)) 16 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Yukari Hafner 2 | 3 | This software is provided 'as-is', without any express or implied 4 | warranty. In no event will the authors be held liable for any damages 5 | arising from the use of this software. 6 | 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 11 | 1. The origin of this software must not be misrepresented; you must not 12 | claim that you wrote the original software. If you use this software 13 | in a product, an acknowledgment in the product documentation would be 14 | appreciated but is not required. 15 | 2. Altered source versions must be plainly marked as such, and must not be 16 | misrepresented as being the original software. 17 | 3. This notice may not be removed or altered from any source distribution. 18 | -------------------------------------------------------------------------------- /flare.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem flare 2 | :version "1.1.0" 3 | :author "Yukari Hafner " 4 | :license "zlib" 5 | :description "Easy particle systems with fine grained control." 6 | :homepage "https://shinmera.com/docs/flare/" 7 | :bug-tracker "https://shinmera.com/project/flare/issues" 8 | :source-control (:git "https://shinmera.com/project/flare.git") 9 | :serial T 10 | :components ((:file "package") 11 | (:file "toolkit") 12 | (:file "queue") 13 | (:file "indexed-set") 14 | (:file "easings") 15 | (:file "clock") 16 | (:file "container") 17 | (:file "paintable") 18 | (:file "animation") 19 | (:file "change") 20 | (:file "parser") 21 | (:file "scene") 22 | (:file "forms") 23 | (:file "documentation")) 24 | :depends-on (:lambda-fiddle 25 | :array-utils 26 | :trivial-garbage 27 | :3d-vectors 28 | :documentation-utils 29 | :for)) 30 | -------------------------------------------------------------------------------- /clock.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare) 2 | 3 | (defgeneric update (object dt)) 4 | (defgeneric stop (clock)) 5 | (defgeneric start (clock)) 6 | (defgeneric reset (clock)) 7 | (defgeneric running (clock)) 8 | (defgeneric timescale (clock)) 9 | (defgeneric synchronize (clock new)) 10 | (defgeneric clock (clock)) 11 | 12 | (defmethod update (object dt) 13 | object) 14 | 15 | (define-self-returning-method update (object dt)) 16 | 17 | (defclass clock () 18 | ((clock :initarg :clock :accessor clock) 19 | (running :initarg :running :accessor running)) 20 | (:default-initargs 21 | :clock 0.0f0 22 | :running NIL)) 23 | 24 | (define-self-returning-method stop ((clock clock))) 25 | (define-self-returning-method start ((clock clock))) 26 | (define-self-returning-method reset (clock)) 27 | (define-self-returning-method synchronize (clock new)) 28 | 29 | (defmethod describe-object ((clock clock) stream) 30 | (format stream "~&~a 31 | [~a] 32 | 33 | The clock is ~:[STOPPED~;RUNNING~] 34 | Internal clock is at ~a~&" 35 | clock (type-of clock) (running clock) (clock clock))) 36 | 37 | (defmethod print-object ((clock clock) stream) 38 | (print-unreadable-object (clock stream :type T :identity T) 39 | (format stream "~s ~a" (if (running clock) :running :stopped) (clock clock)))) 40 | 41 | (defmethod reset ((clock clock)) 42 | (setf (clock clock) 0.0f0)) 43 | 44 | (defmethod synchronize ((clock clock) (with clock)) 45 | (setf (clock clock) (clock with))) 46 | 47 | (defmethod synchronize ((clock clock) (with real)) 48 | (setf (clock clock) (float with 0.0f0))) 49 | 50 | (defmethod stop ((clock clock)) 51 | (setf (running clock) NIL)) 52 | 53 | (defmethod start ((clock clock)) 54 | (setf (running clock) T)) 55 | 56 | (defmethod update :before ((clock clock) dt) 57 | (incf (clock clock) dt)) 58 | 59 | (defmethod update :around ((clock clock) dt) 60 | (when (running clock) 61 | (call-next-method))) 62 | -------------------------------------------------------------------------------- /designdoc: -------------------------------------------------------------------------------- 1 | ;;;; Flint Design Shizzle 2 | 3 | ;;; Animation 1 4 | 1: EDIT Create a ring of 16 bullets. 5 | 1: TWEEN Expand the radius of the ring, eased. 6 | 1: TWEEN Rotate the ring, eased. 7 | 2: EDIT Split each bullet in the ring by a ring of 3 bullets. 8 | 2: TWEEN Expand the radius of the ring, exponential. 9 | 2: TWEEN Rotate the ring, exponential. 10 | 2: TWEEN Expand each ring.child, exponential. 11 | 2: TWEEN Rotate each ring.child, exponential. 12 | 2: TWEEN Fade out the ring. 13 | 3: EDIT Remove the ring. 14 | 15 | (define-progression 1 16 | 0 17 | (:scene 18 | (enter ring :name :ring :contents ((bullet :size 2) 20))) 19 | (:ring 20 | (scale orientation :to 20 :interpolate ease) 21 | (rotate orientation :to (vec 0 0 360) :interpolate ease)) 22 | 10 23 | ((:ring >) 24 | (split :by ((ring :contents ((bullet :size 1) 3)) 1))) 25 | (:ring 26 | (scale orientation :by 1.1 :exponential) 27 | (rotate orientation :by (vec 0 0 1) :project expt)) 28 | ((:ring >) 29 | (scale orientation :by 1.1 :exponential) 30 | (rotate orientation :by (vec 0 0 1) :project expt)) 31 | (:ring 32 | (set alpha :from 0.0 :to 1.0 :project expt)) 33 | 20 34 | (:ring (leave))) 35 | 36 | 37 | ;;; Animation 2 38 | 1: EDIT Create a bullet with random lifetime in a random direction every 3 steps. 39 | 40 | (animation 2 41 | 0 42 | (:scene (every 3 (enter ring :contents (bullet :size 2) :orientation (random) :life (random))) 43 | (ring (scale orientation :by 1.1 :project expt))) 44 | 45 | 46 | ;;; Animation 3 47 | 1: EDIT Create a burst of random bullets in a random direction 48 | 49 | (animation 3 50 | 0 51 | (:scene (enter ring :contents (cloud :size 0 :contents ((bullet :size 2) (random))) :orientation (random))) 52 | (ring (scale orientation :by 1.1)) 53 | ((ring cloud) (set size :from 0 :to 50 :project expt)) 54 | 50 55 | (ring (leave))) 56 | 57 | ;;; Basic structure 58 | ANIMATION ::= TITLE [TIME INSTRUCTION*]* 59 | TITLE ::= symbol 60 | TIME ::= real 61 | INSTRUCTION ::= (SELECTOR ACTION*) 62 | SELECTOR ::= DESIGNATOR | (DESIGNATOR+) 63 | DESIGNATOR ::= ANY | CLASS | NAME | INDEX | #\# #\' FUNCTION 64 | ANY ::= #\* 65 | CLASS ::= symbol 66 | NAME ::= keyword 67 | INDEX ::= integer 68 | ACTION ::= (FUNCTION ARG*) 69 | FUNCTION ::= symbol 70 | ARG ::= T 71 | 72 | -------------------------------------------------------------------------------- /indexed-set.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare.indexed-set) 2 | 3 | (defclass indexed-set (queue) 4 | ((set :initform (make-hash-table :test 'eql) :accessor set))) 5 | 6 | (defun make-indexed-set () 7 | (make-instance 'indexed-set)) 8 | 9 | (setf (fdefinition 'map-set) (fdefinition 'map-queue)) 10 | (setf (macro-function 'do-set) (macro-function 'do-queue)) 11 | 12 | (defun set-add (value set) 13 | (cond ((gethash value (set set)) 14 | (values set NIL)) 15 | (T 16 | (let ((cell (flare-queue::make-cell value NIL NIL))) 17 | (setf (gethash value (set set)) cell) 18 | (flare-queue::cell-insert-before cell (flare-queue::tail set))) 19 | (flare-queue::set-size (1+ (flare-queue::size set)) set) 20 | (values set T)))) 21 | 22 | (defun set-add-before (after value set) 23 | (cond ((gethash value (set set)) 24 | (values set NIL)) 25 | (T 26 | (let ((pivot (gethash after (set set))) 27 | (cell (flare-queue::make-cell value NIL NIL))) 28 | (setf (gethash value (set set)) cell) 29 | (flare-queue::cell-insert-before cell pivot)) 30 | (flare-queue::set-size (1+ (flare-queue::size set)) set) 31 | (values set T)))) 32 | 33 | (defun set-add-after (before value set) 34 | (cond ((gethash value (set set)) 35 | (values set NIL)) 36 | (T 37 | (let ((pivot (gethash before (set set))) 38 | (cell (flare-queue::make-cell value NIL NIL))) 39 | (setf (gethash value (set set)) cell) 40 | (flare-queue::cell-insert-after cell pivot)) 41 | (flare-queue::set-size (1+ (flare-queue::size set)) set) 42 | (values set T)))) 43 | 44 | (defun set-remove (value set) 45 | (let ((cell (gethash value (set set)))) 46 | (cond (cell 47 | (remhash value (set set)) 48 | (flare-queue::cell-remove cell) 49 | (flare-queue::set-size (1- (flare-queue::size set)) set) 50 | (values set T)) 51 | (T 52 | (values set NIL))))) 53 | 54 | (setf (fdefinition 'set-size) (fdefinition 'queue-size)) 55 | (setf (fdefinition 'set-first) (fdefinition 'queue-first)) 56 | (setf (fdefinition 'set-last) (fdefinition 'queue-last)) 57 | (setf (fdefinition 'set-value-at) (fdefinition 'queue-value-at)) 58 | (setf (fdefinition '(setf set-value-at)) (fdefinition '(setf queue-value-at))) 59 | (setf (fdefinition 'set-index-of) (fdefinition 'queue-index-of)) 60 | (setf (fdefinition 'clear-set) (fdefinition 'clear-queue)) 61 | 62 | (defun in-set-p (value set) 63 | (nth-value 1 (gethash value (set set)))) 64 | 65 | (defun coerce-set (set type) 66 | (case type 67 | (indexed-set 68 | set) 69 | (hash-table 70 | (let ((table (make-hash-table :test 'eql))) 71 | (do-queue (val set table) 72 | (setf (gethash val table) val)))) 73 | (T 74 | (coerce-queue set type)))) 75 | -------------------------------------------------------------------------------- /forms.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare) 2 | 3 | (defgeneric orientation (entity)) 4 | (defgeneric size (entity)) 5 | (defgeneric up (arc)) 6 | (defgeneric angle (arc)) 7 | (defgeneric spacing (arc)) 8 | 9 | (defclass oriented-entity (entity) 10 | ((orientation :initarg :orientation :accessor orientation)) 11 | (:default-initargs 12 | :orientation (vec 1 0 0))) 13 | 14 | (defclass sized-entity (entity) 15 | ((size :initarg :size :accessor size)) 16 | (:default-initargs 17 | :size 1.0)) 18 | 19 | (defclass formation (entity) 20 | ()) 21 | 22 | (defgeneric reposition (formation)) 23 | 24 | (defmethod initialize-instance :after ((formation formation) &key) 25 | (reposition formation)) 26 | 27 | (defmethod insert :after ((formation formation) &rest objs) 28 | (declare (ignore objs)) 29 | (reposition formation)) 30 | 31 | (defmethod withdraw :after ((formation formation) &rest objs) 32 | (declare (ignore objs)) 33 | (reposition formation)) 34 | 35 | (defmethod (setf location) :after (value (formation formation)) 36 | (reposition formation)) 37 | 38 | (defclass particle (entity) 39 | ()) 40 | 41 | (defclass arc (formation oriented-entity sized-entity) 42 | ((up :initarg :up :accessor up) 43 | (tangent :accessor tangent) 44 | (angle :initarg :angle :accessor angle) 45 | (spacing :initarg :spacing :accessor spacing)) 46 | (:default-initargs 47 | :up (vec 0 0 1) 48 | :angle 0 49 | :spacing 10 50 | :size 0)) 51 | 52 | (defmethod print-object ((arc arc) stream) 53 | (print-unreadable-object (arc stream :type T :identity T) 54 | (format stream "~s ~s ~s ~s" :spacing (spacing arc) :angle (angle arc)))) 55 | 56 | (defmethod reposition ((arc arc)) 57 | (with-slots (up tangent angle spacing size orientation location) arc 58 | (setf tangent (vc up orientation)) 59 | (for:for ((child over (objects arc)) 60 | (deg from angle :by spacing) 61 | (phi = (* deg Pi 1/180)) 62 | (u = (* size (cos phi))) 63 | (v = (* size (sin phi))) 64 | (p = (vec (+ (vx location) 65 | (* u (vx orientation)) 66 | (* v (vx tangent))) 67 | (+ (vy location) 68 | (* u (vy orientation)) 69 | (* v (vy tangent))) 70 | (+ (vz location) 71 | (* u (vz orientation)) 72 | (* v (vz tangent)))))) 73 | (setf (location child) p)))) 74 | 75 | (defmethod (setf up) :after (val (arc arc)) 76 | (reposition arc)) 77 | 78 | (defmethod (setf orientation) :after (val (arc arc)) 79 | (reposition arc)) 80 | 81 | (defmethod (setf angle) :after (val (arc arc)) 82 | (reposition arc)) 83 | 84 | (defmethod (setf size) :after (val (arc arc)) 85 | (reposition arc)) 86 | 87 | (defmethod (setf spacing) :after (val (arc arc)) 88 | (reposition arc)) 89 | 90 | (defclass ring (arc) 91 | ()) 92 | 93 | ;; Can't be :AFTER as they would happen after the REPOSITION 94 | ;; call that ARC performs, which is not what we need. 95 | (defmethod reposition :before ((ring ring)) 96 | (let ((size (set-size (objects ring)))) 97 | (setf (slot-value ring 'spacing) 98 | (if (<= size 0) 0 (/ 360 size))))) 99 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | 3 | (defpackage #:flare-queue 4 | (:nicknames #:org.shirakumo.flare.queue) 5 | (:use #:cl #:for) 6 | (:export 7 | #:make-cell 8 | #:cell 9 | #:value 10 | #:left 11 | #:right 12 | #:cell-tie 13 | #:cell-insert-before 14 | #:cell-insert-after 15 | #:cell-remove 16 | #:remove-cells 17 | #:queue 18 | #:make-queue 19 | #:in-queue 20 | #:of-queue 21 | #:map-queue 22 | #:do-queue 23 | #:enqueue 24 | #:dequeue 25 | #:queue-remove 26 | #:queue-size 27 | #:queue-first 28 | #:queue-last 29 | #:queue-index-of 30 | #:queue-value-at 31 | #:clear-queue 32 | #:in-queue-p 33 | #:coerce-queue)) 34 | 35 | (defpackage #:flare-indexed-set 36 | (:nicknames #:org.shirakumo.flare.indexed-set) 37 | (:use #:cl #:org.shirakumo.flare.queue) 38 | (:shadow #:set) 39 | (:export 40 | #:indexed-set 41 | #:make-indexed-set 42 | #:map-set 43 | #:on-set 44 | #:in-set 45 | #:do-set 46 | #:set-add 47 | #:set-add-before 48 | #:set-add-after 49 | #:set-remove 50 | #:set-size 51 | #:set-first 52 | #:set-last 53 | #:set-value-at 54 | #:set-index-of 55 | #:in-set-p 56 | #:clear-set 57 | #:coerce-set)) 58 | 59 | (defpackage #:flare 60 | (:nicknames #:org.shirakumo.flare) 61 | (:use #:cl #:3d-vectors #:flare-queue #:flare-indexed-set) 62 | (:shadow #:leave) 63 | ;; animation.lisp 64 | (:export 65 | #:animatable 66 | #:progression-definition 67 | #:progression 68 | #:animation 69 | #:change 70 | 71 | #:progressions 72 | #:add-progression 73 | #:remove-progression 74 | #:progression-instance 75 | #:animations 76 | #:instances 77 | #:present-animations 78 | #:past-animations 79 | #:future-animations 80 | #:animations 81 | #:beginning 82 | #:duration 83 | #:changes 84 | #:selector 85 | #:tick) 86 | ;; clock.lisp 87 | (:export 88 | #:update 89 | #:stop 90 | #:start 91 | #:reset 92 | #:running 93 | #:timescale 94 | #:synchronize 95 | #:clock 96 | 97 | #:clock) 98 | ;; change.lisp 99 | (:export 100 | #:define-change-parser 101 | #:change 102 | #:print-change 103 | #:print 104 | #:call-change 105 | #:call 106 | #:operation 107 | #:enter-operation 108 | #:objects 109 | #:creator 110 | #:enter 111 | #:create 112 | #:leave-operation 113 | #:leave 114 | #:objects 115 | #:tween 116 | #:slot-tween 117 | #:slot 118 | #:originals 119 | #:original-value 120 | #:range-tween 121 | #:range-slot-tween 122 | #:set 123 | #:constant-tween 124 | #:increase-slot-tween 125 | #:increase 126 | #:call-slot-tween 127 | #:call-accessor-tween 128 | #:calc) 129 | ;; container.lisp 130 | (:export 131 | #:name 132 | #:enter 133 | #:leave 134 | #:clear 135 | #:objects 136 | #:name-map 137 | #:units 138 | #:unit 139 | #:register 140 | #:deregister 141 | #:scene-graph 142 | #:unit 143 | #:container 144 | #:map-container-tree 145 | #:do-container-tree 146 | #:print-container-tree 147 | #:scene-graph 148 | #:container-unit) 149 | ;; easings.lisp 150 | (:export 151 | #:easing 152 | #:remove-easing 153 | #:define-easing 154 | #:ease 155 | #:ease-object 156 | #:linear 157 | #:quad-in 158 | #:quad-out 159 | #:quad-in-out 160 | #:cubic-in 161 | #:cubic-out 162 | #:cubic-in-out 163 | #:quart-in 164 | #:quart-out 165 | #:quart-in-out 166 | #:quint-in 167 | #:quint-out 168 | #:quint-in-out 169 | #:sine-in 170 | #:sine-out 171 | #:sine-in-out 172 | #:expo-in 173 | #:expo-out 174 | #:expo-in-out 175 | #:circ-in 176 | #:circ-out 177 | #:circ-in-out 178 | #:back-in 179 | #:back-out 180 | #:back-in-out 181 | #:elastic-in 182 | #:elastic-out 183 | #:elastic-in-out 184 | #:bounce-in 185 | #:bounce-out 186 | #:bounce-in-out) 187 | ;; forms.lisp 188 | (:export 189 | #:oriented-entity 190 | #:sized-entity 191 | #:formation 192 | #:particle 193 | #:arc 194 | #:orientation 195 | #:size 196 | #:up 197 | #:angle 198 | #:spacing 199 | #:ring) 200 | ;; parser.lisp 201 | (:export 202 | #:make-progression 203 | #:progression-definition 204 | #:remove-progression-definition 205 | #:define-progression) 206 | ;; paintable.lisp 207 | (:export 208 | #:call-with-translation 209 | #:visibility 210 | #:paint 211 | #:with-translation 212 | 213 | #:target 214 | #:paintable) 215 | ;; scene.lisp 216 | (:export 217 | #:scene 218 | #:location 219 | #:entity)) 220 | -------------------------------------------------------------------------------- /parser.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare) 2 | 3 | (deftype interval-designator () 4 | `(or real (eql T) (eql NIL))) 5 | 6 | (defun designator-p (thing) 7 | (typep thing 'interval-designator)) 8 | 9 | (defun parse-intervals (forms) 10 | (unless (designator-p (first forms)) 11 | (error "~a expected, but ~s found." 'interval-designator (first forms))) 12 | (dolist (item forms) 13 | (unless (typep item '(or cons interval-designator)) 14 | (error "~a or ~a expected, but ~s found." 'interval-designator 'cons item))) 15 | ;; Push boundary to round it off 16 | (setf (cdr (last forms)) (cons T NIL)) 17 | ;; Normalise 18 | (let ((normalized ())) 19 | (loop with start = '? 20 | with end = '? 21 | with anims = () 22 | for sub = (cdr forms) then (cdr sub) 23 | for cur = (first forms) then next 24 | for next = (car sub) 25 | while (or sub cur) 26 | do (cond ((and (listp cur) (listp next)) 27 | (push cur anims)) 28 | ((listp cur) 29 | (push cur anims) 30 | (push (list start end (reverse anims)) normalized) 31 | (setf start '? end '? anims ())) 32 | ((and (designator-p cur) (designator-p next)) 33 | (setf start cur)) 34 | ((and (designator-p cur) (not (eql start '?))) 35 | (setf end cur)) 36 | ((and (designator-p cur) (eql start '?)) 37 | (setf start cur) 38 | (setf end (loop for item in (cdr sub) 39 | when (designator-p item) 40 | return item))))) 41 | (setf normalized (reverse normalized)) 42 | (let ((animations ())) 43 | (loop for (start end anims) in normalized 44 | do (dolist (anim anims) 45 | (push (list start 46 | (if (and (realp start) (realp end)) (- end start) end) 47 | anim) 48 | animations))) 49 | (reverse animations)))) 50 | 51 | (defvar *mapper*) 52 | (defvar *i* 0) 53 | 54 | (defun compile-constraint (constraint next) 55 | (cond ((integerp constraint) 56 | (lambda (object) 57 | (when (= constraint *i*) 58 | (funcall next object)))) 59 | ((eql constraint T) 60 | (lambda (object) 61 | (funcall next object))) 62 | ((symbolp constraint) 63 | (cond ((string= constraint ">") 64 | (lambda (container) 65 | (let ((*i* 0)) 66 | (for:for ((unit over container)) 67 | (funcall next unit) 68 | (incf *i*))))) 69 | ((string= constraint "*") 70 | (lambda (container) 71 | (let ((*i* 0)) 72 | (do-container-tree (unit container) 73 | (funcall next unit) 74 | (incf *i*))))) 75 | (T (lambda (object) 76 | (let ((unit (unit constraint object))) 77 | (when unit 78 | (funcall next unit))))))) 79 | ((functionp constraint) 80 | (lambda (object) 81 | (when (funcall constraint object) 82 | (funcall next object)))) 83 | ((listp constraint) 84 | (ecase (first constraint) 85 | (quote (second constraint)) 86 | (function (fdefinition (second constraint))) 87 | (lambda (compile NIL constraint)))) 88 | (T (error "Unknown constraint ~s" constraint)))) 89 | 90 | (defun compile-selector (selector) 91 | (unless (listp selector) 92 | (setf selector (list selector))) 93 | (loop with func = (lambda (set) 94 | (funcall *mapper* set)) 95 | for constraint in (reverse selector) 96 | do (setf func (compile-constraint constraint func)) 97 | finally (return (lambda (scene-graph function) 98 | (let ((*mapper* function)) 99 | (funcall func scene-graph)))))) 100 | 101 | (defmacro compile-change (type &rest args) 102 | (parse-change type args)) 103 | 104 | (defvar *animation-defindex* 0) 105 | 106 | (defun parse-animation (beginning duration expression) 107 | (destructuring-bind (selector &rest changes) expression 108 | (let ((animation (gensym "ANIMATION"))) 109 | `(let ((,animation (make-instance 'animation :beginning ,beginning 110 | :duration ,duration 111 | :selector ',selector 112 | :defindex (incf *animation-defindex*)))) 113 | ,@(loop for change in changes 114 | collect `(push (compile-change ,@change) (changes ,animation))) 115 | (setf (changes ,animation) (nreverse (changes ,animation))) 116 | ,animation)))) 117 | 118 | (defmacro compile-animations (&body intervals) 119 | (let ((animations (when intervals (parse-intervals intervals)))) 120 | `(list 121 | ,@(loop for (start duration expression) in animations 122 | collect (parse-animation start duration expression))))) 123 | 124 | (defvar *progressions* (make-hash-table :test 'eql)) 125 | 126 | (defun progression-definition (name) 127 | (gethash name *progressions*)) 128 | 129 | (defun (setf progression-definition) (progression name) 130 | (setf (gethash name *progressions*) progression)) 131 | 132 | (defun remove-progression-definition (name) 133 | (remhash name *progressions*)) 134 | 135 | (defmacro define-progression (name &body intervals) 136 | `(progn 137 | (setf (animations (or (progression-definition ',name) 138 | (setf (progression-definition ',name) 139 | (make-instance 'progression-definition)))) 140 | (compile-animations ,@intervals)) 141 | ',name)) 142 | 143 | (defmethod progression-instance ((name symbol)) 144 | (progression-instance (progression-definition name))) 145 | -------------------------------------------------------------------------------- /container.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare) 2 | 3 | (defgeneric name (unit)) 4 | (defgeneric enter (unit scene-graph)) 5 | (defgeneric leave (unit scene-graph)) 6 | (defgeneric clear (container)) 7 | (defgeneric objects (container)) 8 | (defgeneric name-map (scene-graph)) 9 | (defgeneric units (scene-graph)) 10 | (defgeneric unit (name scene-graph)) 11 | (defgeneric register (unit scene-graph)) 12 | (defgeneric deregister (unit scene-graph)) 13 | (defgeneric scene-graph (container-unit)) 14 | 15 | (defclass unit () 16 | ((name :initform NIL :initarg :name :reader name))) 17 | 18 | (defmethod initialize-instance :before ((unit unit) &key name) 19 | (check-type name symbol)) 20 | 21 | (defmethod print-object ((unit unit) stream) 22 | (print-unreadable-object (unit stream :type T :identity T) 23 | (format stream "~@[~a~]" (name unit)))) 24 | 25 | (defclass container () 26 | ((objects :initform (make-indexed-set) :accessor objects))) 27 | 28 | (defmethod paint ((container container) target) 29 | (for:for ((item over container)) 30 | (paint item target))) 31 | 32 | (defmethod update ((container container) dt) 33 | (for:for ((item over container)) 34 | (update item dt))) 35 | 36 | (defmethod enter (thing (container container)) 37 | (set-add thing (objects container)) 38 | thing) 39 | 40 | (defmethod leave (thing (container container)) 41 | (set-remove thing (objects container)) 42 | thing) 43 | 44 | (defmethod clear ((container container)) 45 | (for:for ((item over container)) 46 | (leave item container)) 47 | container) 48 | 49 | (defmethod unit (n (container container)) 50 | (set-value-at n (objects container))) 51 | 52 | (defmethod (setf unit) (value n (container container)) 53 | (setf (set-value-at n (objects container)) value)) 54 | 55 | (defmethod for:make-iterator ((container container) &rest args) 56 | (apply #'for:make-iterator (objects container) args)) 57 | 58 | (defun map-container-tree (function container) 59 | (for:for ((item over container)) 60 | (funcall function item) 61 | (when (typep item 'container) 62 | (map-container-tree function item)))) 63 | 64 | (defmacro do-container-tree ((item container &optional return) &body body) 65 | `(block NIL 66 | (map-container-tree (lambda (,item) ,@body) ,container) 67 | ,return)) 68 | 69 | (defun print-container-tree (container &optional (depth 0)) 70 | (format T "~&~v@{ ~}+ ~a~%" depth container) 71 | (for:for ((item over container)) 72 | (if (typep item 'container) 73 | (print-container-tree item (+ depth 2)) 74 | (format T "~&~v@{ ~}| ~a~%" (+ depth 2) item)))) 75 | 76 | (defmethod describe-object ((container container) stream) 77 | (format stream "~a 78 | [~a] 79 | 80 | Tree:" 81 | container (type-of container)) 82 | (print-container-tree container stream) 83 | (format stream "~&")) 84 | 85 | (defclass scene-graph (container) 86 | ((name-map :initform (make-hash-table :test 'eq) :accessor name-map))) 87 | 88 | (defmethod print-object ((scene-graph scene-graph) stream) 89 | (print-unreadable-object (scene-graph stream :type T :identity T) 90 | (format stream "~a units" (hash-table-count (name-map scene-graph))))) 91 | 92 | (defmethod register :around ((unit unit) (scene-graph scene-graph)) 93 | (when (or (null (name unit)) 94 | (not (eql unit (gethash (name unit) (name-map scene-graph))))) 95 | (call-next-method))) 96 | 97 | (defmethod register ((unit unit) (scene-graph scene-graph)) 98 | (when (name unit) 99 | (setf (gethash (name unit) (name-map scene-graph)) unit))) 100 | 101 | (defmethod deregister ((unit unit) (scene-graph scene-graph)) 102 | (when (eql unit (gethash (name unit) (name-map scene-graph))) 103 | (remhash (name unit) (name-map scene-graph))) 104 | unit) 105 | 106 | (defmethod enter :after ((unit unit) (scene-graph scene-graph)) 107 | (register unit scene-graph)) 108 | 109 | (defmethod leave :after ((unit unit) (scene-graph scene-graph)) 110 | (deregister unit scene-graph)) 111 | 112 | (defmethod units ((scene-graph scene-graph)) 113 | (let ((units ())) 114 | (do-container-tree (item scene-graph units) 115 | (push item units)))) 116 | 117 | (defmethod unit ((name symbol) (scene-graph scene-graph)) 118 | (gethash name (name-map scene-graph))) 119 | 120 | (defclass container-unit (container unit) 121 | ((scene-graph :initform NIL :accessor scene-graph))) 122 | 123 | (defmethod print-object ((unit container-unit) stream) 124 | (print-unreadable-object (unit stream :type T) 125 | (format stream "~a => ~a" (name unit) (scene-graph unit)))) 126 | 127 | (defmethod initialize-instance :after ((unit container-unit) &key scene-graph) 128 | (setf (scene-graph unit) scene-graph)) 129 | 130 | (defmethod (setf scene-graph) :before (scene-graph (unit container-unit)) 131 | (let ((scene-graph (scene-graph unit))) 132 | (when scene-graph 133 | (do-container-tree (item unit) 134 | (deregister item scene-graph))))) 135 | 136 | (defmethod (setf scene-graph) :after ((scene-graph scene-graph) (unit container-unit)) 137 | (when scene-graph 138 | (do-container-tree (item unit) 139 | (register item scene-graph)))) 140 | 141 | (defmethod enter :before ((unit container-unit) (scene-graph scene-graph)) 142 | (when (scene-graph unit) 143 | (error "~a is already contained in ~a, cannot enter it into ~a." 144 | unit (scene-graph unit) scene-graph))) 145 | 146 | (defmethod leave :before ((unit container-unit) (scene-graph scene-graph)) 147 | (unless (eql (scene-graph unit) scene-graph) 148 | (error "~a is contained in ~a, cannot leave it from ~a." 149 | unit (scene-graph unit) scene-graph))) 150 | 151 | (defmethod enter :after ((unit unit) (container container-unit)) 152 | (when (scene-graph container) 153 | (register unit (scene-graph container)))) 154 | 155 | (defmethod leave :after ((unit unit) (container container-unit)) 156 | (when (scene-graph container) 157 | (deregister unit (scene-graph container)))) 158 | 159 | (defmethod register :after ((unit container-unit) (scene-graph scene-graph)) 160 | (setf (scene-graph unit) scene-graph)) 161 | 162 | (defmethod deregister :after ((unit container-unit) (scene-graph scene-graph)) 163 | (setf (scene-graph unit) NIL)) 164 | -------------------------------------------------------------------------------- /easings.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare) 2 | 3 | (defvar *easings* (make-hash-table :test 'eql)) 4 | (defvar *ease-docs* (make-hash-table :test 'eql)) 5 | 6 | (defun easing (name) 7 | (gethash name *easings*)) 8 | 9 | (defun (setf easing) (func name) 10 | (setf (gethash name *easings*) func) 11 | (setf (gethash name *ease-docs*) (documentation func t))) 12 | 13 | (defun remove-easing (name) 14 | (remhash name *easings*) 15 | (remhash name *ease-docs*)) 16 | 17 | (defmethod documentation ((name symbol) (type (eql 'easing))) 18 | (gethash name *ease-docs*)) 19 | 20 | (defmethod (setf documentation) (doc (name symbol) (type (eql 'easing))) 21 | (setf (gethash name *ease-docs*) doc)) 22 | 23 | (defmacro define-easing (name (x) &body body) 24 | `(setf (easing ',name) 25 | (lambda (,x) 26 | ,@body))) 27 | 28 | (defun ease (x by &optional (from 0) (to 1)) 29 | (let ((easing (or (easing by) 30 | (error "No such easing ~s found." by)))) 31 | (+ from (* (funcall easing x) (- to from))))) 32 | 33 | (define-compiler-macro ease (&whole whole &environment env x by &optional (from 0) (to 1)) 34 | (if (constantp by env) 35 | (let ((fromg (gensym "FROM"))) 36 | `(let ((,fromg ,from)) 37 | (+ ,fromg (* (funcall (load-time-value 38 | (or (easing ,by) 39 | (error "No such easing ~s found." ,by))) 40 | ,x) 41 | (- ,to ,fromg))))) 42 | whole)) 43 | 44 | (defgeneric ease-object (from to x by)) 45 | 46 | (defmethod ease-object ((from real) (to real) x by) 47 | (ease x by from to)) 48 | 49 | (defmethod ease-object ((from vec2) (to vec2) x by) 50 | (vec2 (ease x by (vx2 from) (vx2 to)) 51 | (ease x by (vy2 from) (vy2 to)))) 52 | 53 | (defmethod ease-object ((from vec3) (to vec3) x by) 54 | (vec3 (ease x by (vx3 from) (vx3 to)) 55 | (ease x by (vy3 from) (vy3 to)) 56 | (ease x by (vz3 from) (vz3 to)))) 57 | 58 | (defmethod ease-object ((from vec4) (to vec4) x by) 59 | (vec4 (ease x by (vx4 from) (vx4 to)) 60 | (ease x by (vy4 from) (vy4 to)) 61 | (ease x by (vz4 from) (vz4 to)) 62 | (ease x by (vw4 from) (vw4 to)))) 63 | 64 | (define-easing linear (x) 65 | x) 66 | 67 | (define-easing quad-in (x) 68 | (expt x 2)) 69 | 70 | (define-easing quad-out (x) 71 | (- (* x (- x 2)))) 72 | 73 | (define-easing quad-in-out (x) 74 | (let ((x (* x 2))) 75 | (if (< x 1) 76 | (/ (expt x 2) 2) 77 | (- (/ (1- (* (decf x) (- x 2))) 2))))) 78 | 79 | (define-easing cubic-in (x) 80 | (expt x 3)) 81 | 82 | (define-easing cubic-out (x) 83 | (1+ (expt (1- x) 3))) 84 | 85 | (define-easing cubic-in-out (x) 86 | (let ((x (* x 2))) 87 | (if (< x 1) 88 | (/ (expt x 3) 2) 89 | (/ (+ (expt (- x 2) 3) 2) 2)))) 90 | 91 | (define-easing quart-in (x) 92 | (expt x 4)) 93 | 94 | (define-easing quart-out (x) 95 | (- (1- (expt (1- x) 4)))) 96 | 97 | (define-easing quart-in-out (x) 98 | (let ((x (* x 2))) 99 | (if (< x 1) 100 | (/ (expt x 4) 2) 101 | (- (/ (- (expt (- x 2) 4) 2) 2))))) 102 | 103 | (define-easing quint-in (x) 104 | (expt x 5)) 105 | 106 | (define-easing quint-out (x) 107 | (1+ (expt (1- x) 5))) 108 | 109 | (define-easing quint-in-out (x) 110 | (let ((x (* x 2))) 111 | (if (< x 1) 112 | (/ (expt x 5) 2) 113 | (/ (+ (expt (- x 2) 5) 2) 2)))) 114 | 115 | (define-easing sine-in (x) 116 | (1+ (- (cos (* x (/ PI 2)))))) 117 | 118 | (define-easing sine-out (x) 119 | (sin (* x (/ PI 2)))) 120 | 121 | (define-easing sine-in-out (x) 122 | (- (/ (1- (cos (* PI x))) 2))) 123 | 124 | (define-easing expo-in (x) 125 | (if (= 0 x) 126 | 0 127 | (expt 2 (* 10 (1- x))))) 128 | 129 | (define-easing expo-out (x) 130 | (if (= 1 x) 131 | 1 132 | (1+ (- (expt 2 (* x -10)))))) 133 | 134 | (define-easing expo-in-out (x) 135 | (case x 136 | ((1 0) x) 137 | (T (let ((x (* x 2))) 138 | (if (< x 1) 139 | (/ (expt 2 (* 10 (1- x))) 2) 140 | (/ (+ (- (expt 2 (* x -10))) 2) 2)))))) 141 | 142 | (define-easing circ-in (x) 143 | (- (1- (sqrt (- 1 (expt x 2)))))) 144 | 145 | (define-easing circ-out (x) 146 | (sqrt (- 1 (expt (1- x) 2)))) 147 | 148 | (define-easing circ-in-out (x) 149 | (let ((x (* x 2))) 150 | (if (< x 1) 151 | (- (/ (1- (sqrt (- 1 (expt x 2)))) 2)) 152 | (/ (1+ (sqrt (- 1 (expt x 2)))) 2)))) 153 | 154 | (define-easing back-in (x) 155 | (let ((s 1.70158)) 156 | (* (expt x 2) (- (* (1+ s) x) s)))) 157 | 158 | (define-easing back-out (x) 159 | (let ((s 1.70158)) 160 | (1+ (* (expt x 2) (+ (* (1+ s) x) s))))) 161 | 162 | (define-easing back-in-out (x) 163 | (let ((s (* 1.70158 1.525)) 164 | (x (* x 2))) 165 | (if (< x 1) 166 | (/ (* (expt x 2) (- (* (1+ s) x) s)) 2) 167 | (/ (+ (* (expt x 2) (+ (* (1+ s) x) s)) 2) 2)))) 168 | 169 | (define-easing elastic-in (x) 170 | (case x 171 | ((0 1) x) 172 | (T (let* ((p 0.3) 173 | (s (/ p 4))) 174 | (- (* (expt 2 (* x 10)) (sin (/ (* (- x s) 2 PI) p)))))))) 175 | 176 | (define-easing elastic-out (x) 177 | (case x 178 | ((0 1) x) 179 | (T (let* ((p 0.3) 180 | (s (/ p 4))) 181 | (1+ (* (expt 2 (* x -10)) (sin (/ (* (- x s) 2 PI) p)))))))) 182 | 183 | (define-easing elastic-in-out (x) 184 | (case x 185 | ((0 1) x) 186 | (T (let* ((x (* x 2)) 187 | (p (* 0.3 1.5)) 188 | (s (/ p 4))) 189 | (if (< x 1) 190 | (- (/ (* (expt 2 (* (1- x) 10)) (sin (/ (* (- (1- x) s) 2 PI) p))) 2)) 191 | (1+ (/ (* (expt 2 (* x -10)) (sin (/ (* (- (1- x) s) 2 PI) p))) 2))))))) 192 | 193 | (define-easing bounce-out (x) 194 | (let ((s 7.5625) 195 | (p 2.75)) 196 | (cond ((< x (/ 1 p)) 197 | (* s (expt x 2))) 198 | ((< x (/ 2 p)) 199 | (+ (* s (expt (- x (/ 1.5 p)) 2)) 0.75)) 200 | ((< x (/ 2.5 p)) 201 | (+ (* s (expt (- x (/ 2.25 p)) 2)) 0.9375)) 202 | (T 203 | (+ (* s (expt (- x (/ 2.625 p)) 2)) 0.984375))))) 204 | 205 | (define-easing bounce-in (x) 206 | (- 1 (ease (- 1 x) 'bounce-out))) 207 | 208 | (define-easing bounce-in-out (x) 209 | (if (< x 0.5) 210 | (/ (ease (* x 2) 'bounce-in) 2) 211 | (/ (1+ (ease (1- (* x 2)) 'bounce-out)) 2))) 212 | -------------------------------------------------------------------------------- /queue.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare.queue) 2 | 3 | (defstruct (cell (:conc-name NIL) 4 | (:constructor make-cell (value left right)) 5 | (:copier NIL) 6 | (:predicate NIL)) 7 | value left right) 8 | 9 | (declaim (inline cell-tie)) 10 | (defun cell-tie (left right) 11 | (setf (right left) right) 12 | (setf (left right) left)) 13 | 14 | (defun cell-insert-before (cell neighbor) 15 | (let ((left (left neighbor))) 16 | (cell-tie left cell) 17 | (cell-tie cell neighbor)) 18 | cell) 19 | 20 | (defun cell-insert-after (cell neighbor) 21 | (let ((right (right neighbor))) 22 | (cell-tie neighbor cell) 23 | (cell-tie cell right)) 24 | cell) 25 | 26 | (defun cell-remove (cell) 27 | (cell-tie (left cell) (right cell)) 28 | cell) 29 | 30 | (defun remove-cells (left right) 31 | (cell-tie (left left) (right right))) 32 | 33 | (defmethod print-object ((cell cell) stream) 34 | (if *print-readably* 35 | (call-next-method) 36 | (print-unreadable-object (cell stream :type T) 37 | (format stream "~s" (value cell))))) 38 | 39 | (defclass queue () 40 | ((head :initform (make-cell NIL NIL NIL) :accessor head) 41 | (tail :initform (make-cell NIL NIL NIL) :accessor tail) 42 | (size :initform 0 :reader size :writer set-size))) 43 | 44 | (defmethod initialize-instance :after ((queue queue) &key) 45 | (setf (right (head queue)) (tail queue) 46 | (left (head queue)) (head queue)) 47 | (setf (left (tail queue)) (head queue) 48 | (right (tail queue)) (tail queue)) 49 | queue) 50 | 51 | (defmethod print-object ((queue queue) stream) 52 | (print-unreadable-object (queue stream :type T) 53 | (format stream "~s ~s" :size (size queue)))) 54 | 55 | (defun make-queue (&rest items) 56 | (let ((queue (make-instance 'queue))) 57 | (dolist (item items queue) 58 | (enqueue item queue)))) 59 | 60 | ;; Iteration 61 | 62 | (defclass queue-iterator (iterator) 63 | ((tail :initarg :tail :accessor tail))) 64 | 65 | (defmethod has-more ((iterator queue-iterator)) 66 | (not (eql (right (object iterator)) (tail iterator)))) 67 | 68 | (defmethod (setf current) (value (iterator queue-iterator)) 69 | (setf (value (object iterator)) value)) 70 | 71 | (defmethod next ((iterator queue-iterator)) 72 | (value (setf (object iterator) (right (object iterator))))) 73 | 74 | (defmethod step-functions ((iterator queue-iterator)) 75 | (let ((object (object iterator)) 76 | (tail (tail iterator))) 77 | (values 78 | (lambda () 79 | (value (setf object (right object)))) 80 | (lambda () 81 | (not (eql (right object) tail))) 82 | (lambda (value) 83 | (setf (value object) value)) 84 | (lambda ())))) 85 | 86 | (defmethod make-iterator ((queue queue) &key) 87 | (make-instance 'queue-iterator :object (head queue) :tail (tail queue))) 88 | 89 | (eval-when (:compile-toplevel :load-toplevel :execute) 90 | (define-value-binding in-queue (var queue &aux (current (head queue)) (tail (tail queue))) 91 | (let ((next (gensym "NEXT"))) 92 | `(let ((,next (right ,current))) 93 | (if (eql ,next ,tail) 94 | (end-for) 95 | (update ,var (value (setf ,current ,next))))))) 96 | 97 | (define-value-binding of-queue (var queue &aux (current (head queue)) (tail (tail queue))) 98 | (let ((next (gensym "NEXT"))) 99 | `(let ((,next (right ,current))) 100 | (if (eql ,next ,tail) 101 | (end-for) 102 | (setf ,var (setf ,current ,next))))))) 103 | 104 | (eval-when (:compile-toplevel :load-toplevel :execute) 105 | (defun map-queue (function queue) 106 | (for ((var in-queue queue)) 107 | (funcall function var)))) 108 | 109 | (eval-when (:compile-toplevel :load-toplevel :execute) 110 | (defmacro do-queue ((value queue &optional result) &body body) 111 | `(block NIL 112 | (for ((,value in-queue ,queue)) 113 | ,@body) 114 | ,result))) 115 | 116 | (defun enqueue (value queue) 117 | (cell-insert-before (make-cell value NIL NIL) (tail queue)) 118 | (set-size (1+ (size queue)) queue) 119 | queue) 120 | 121 | (defun dequeue (queue) 122 | ;; The sentinel would avoid this check usually 123 | ;; but we need to keep the counter intact, and 124 | ;; having a secondary value to tell us whether 125 | ;; it is empty is also useful, so we need to test. 126 | (if (eql (right (head queue)) (tail queue)) 127 | (values NIL NIL) 128 | (let ((cell (right (head queue)))) 129 | (cell-remove cell) 130 | (set-size (1- (size queue)) queue) 131 | (values (value cell) T)))) 132 | 133 | (defun queue-remove (value queue) 134 | (for ((cell of-queue queue)) 135 | (when (eql (value cell) value) 136 | (cell-remove cell) 137 | (return T)))) 138 | 139 | (defun queue-size (queue) 140 | (size queue)) 141 | 142 | (defun queue-first (queue) 143 | (values (value (right (head queue))) 144 | (not (eql (right (head queue)) (tail queue))))) 145 | 146 | (defun queue-last (queue) 147 | (values (left (tail queue)) 148 | (not (eql (left (tail queue)) (head queue))))) 149 | 150 | (defun queue-value-at (n queue) 151 | (for ((current of-queue queue) 152 | (i from 0)) 153 | (when (= i n) 154 | (return (values (value current) T))))) 155 | 156 | (defun (setf queue-value-at) (value n queue) 157 | (for ((current in-queue queue) 158 | (i from 0)) 159 | (when (= i n) 160 | (setf (value current) value) 161 | (return (values value T))))) 162 | 163 | (defun queue-index-of (value queue) 164 | (for ((current in-queue queue) 165 | (i from 0)) 166 | (when (eql current value) 167 | (return i)))) 168 | 169 | (defun clear-queue (queue) 170 | (setf (left (tail queue)) (head queue) 171 | (right (head queue)) (tail queue)) 172 | (set-size 0 queue) 173 | queue) 174 | 175 | (defun in-queue-p (value queue) 176 | (do-queue (val queue) 177 | (when (eql val value) 178 | (return T)))) 179 | 180 | (defun coerce-queue (queue type) 181 | (ecase type 182 | (queue 183 | queue) 184 | (list 185 | (for ((val in-queue queue) 186 | (list collecting val)))) 187 | (vector 188 | (let ((vec (make-array (size queue)))) 189 | (for ((val in-queue queue) 190 | (i from 0)) 191 | (setf (aref vec i) val)) 192 | vec)) 193 | (sequence 194 | (coerce-queue queue 'list)))) 195 | -------------------------------------------------------------------------------- /change.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare) 2 | 3 | (defgeneric parse-change (type args)) 4 | 5 | (defmacro define-change-parser (type args &body body) 6 | (let ((form (gensym "FORM"))) 7 | `(defmethod parse-change ((,(gensym) (eql ',type)) ,form) 8 | (destructuring-bind ,args ,form 9 | ,@body)))) 10 | 11 | (defclass change () 12 | ()) 13 | 14 | (defmethod copy ((change change)) 15 | (make-instance (class-name (class-of change)))) 16 | 17 | (defmethod reset ((change change)) 18 | change) 19 | 20 | (defclass print-change (change) 21 | ()) 22 | 23 | (defmethod tick ((change print-change) object clock step) 24 | (format T "~a ~a ~a" object clock step)) 25 | 26 | (define-change-parser print () 27 | `(make-instance 'print-change)) 28 | 29 | (defclass call-change (change) 30 | ((func :initarg :func :accessor func))) 31 | 32 | (defmethod tick ((change call-change) object clock step) 33 | (funcall (func change) object clock step)) 34 | 35 | (defmethod copy :around ((change call-change)) 36 | (let ((c (call-next-method))) 37 | (setf (func c) (func change)) 38 | c)) 39 | 40 | (define-change-parser call (function) 41 | `(make-instance 'call-change :func ,function)) 42 | 43 | (defclass operation (change) 44 | ()) 45 | 46 | (defclass enter-operation (operation) 47 | ((objects :initform (make-hash-table :test 'eq) :accessor objects) 48 | (creator :initarg :creator :accessor creator))) 49 | 50 | (defmethod reset ((op enter-operation)) 51 | (loop for object being the hash-keys of (objects op) 52 | for container being the hash-values of (objects op) 53 | do (leave object container) 54 | (remhash object (objects op)))) 55 | 56 | (defmethod tick ((op enter-operation) target clock step) 57 | (flet ((register (object) 58 | (setf (gethash object (objects op)) target) 59 | (enter object target))) 60 | (let ((obj (funcall (creator op)))) 61 | (if (listp obj) 62 | (mapc #'register obj) 63 | (register obj))))) 64 | 65 | (defmethod copy ((op enter-operation)) 66 | (let ((c (call-next-method))) 67 | (setf (creator c) (creator op)) 68 | c)) 69 | 70 | (define-change-parser create (class &rest initargs &key n children parent &allow-other-keys) 71 | (let ((initargs (copy-list initargs))) 72 | (remf initargs :n) 73 | (remf initargs :children) 74 | (remf initargs :parent) 75 | (let* ((instance (gensym "INSTANCE")) 76 | (inner `(let ((,instance (make-instance ',class ,@initargs))) 77 | ,@(when children (list (parse-change 'create `(,@children :parent ,instance)))) 78 | ,@(when parent (list `(enter ,instance ,parent))) 79 | ,instance))) 80 | (if n 81 | `(loop repeat ,n 82 | collect ,inner) 83 | inner)))) 84 | 85 | (define-change-parser enter (&rest args) 86 | `(make-instance 87 | 'enter-operation 88 | :creator (lambda () ,(parse-change 'create args)))) 89 | 90 | (defclass leave-operation (operation) 91 | ((objects :initform (make-hash-table :test 'eq) :accessor objects))) 92 | 93 | (defmethod reset ((op leave-operation)) 94 | (loop for object being the hash-keys of (objects op) 95 | for container being the hash-values of (objects op) 96 | do (enter object container) 97 | (remhash object (objects op)))) 98 | 99 | (defmethod tick ((op leave-operation) object clock step) 100 | (when (scene-graph object) 101 | (setf (gethash object (objects op)) (scene-graph object)) 102 | (leave object (scene-graph object)))) 103 | 104 | (define-change-parser leave () 105 | `(make-instance 'leave-operation)) 106 | 107 | (defclass tween (change) 108 | ()) 109 | 110 | (defgeneric tween-value (tween object clock step)) 111 | (defgeneric original-value (object tween)) 112 | 113 | (defclass slot-tween (tween) 114 | ((slot :initarg :slot :accessor slot) 115 | (originals :initform (make-hash-table :test 'eq) :accessor originals))) 116 | 117 | (defmethod original-value (object (tween slot-tween)) 118 | (or (gethash object (originals tween)) 119 | (setf (gethash object (originals tween)) 120 | (slot-value object (slot tween))))) 121 | 122 | (defmethod reset ((tween slot-tween)) 123 | (loop for object being the hash-keys of (originals tween) 124 | for value being the hash-values of (originals tween) 125 | do (setf (slot-value object (slot tween)) value) 126 | (remhash object (originals tween)))) 127 | 128 | (defmethod copy ((tween slot-tween)) 129 | (let ((c (call-next-method))) 130 | (setf (slot c) (slot tween)) 131 | c)) 132 | 133 | (defmethod tick ((tween slot-tween) object clock step) 134 | (setf (slot-value object (slot tween)) 135 | (tween-value tween object clock step))) 136 | 137 | (defclass accessor-tween (tween) 138 | ((accessor :initarg :accessor :accessor accessor) 139 | (originals :initform (make-hash-table :test 'eq) :accessor originals))) 140 | 141 | (defmethod original-value (object (tween accessor-tween)) 142 | (or (gethash object (originals tween)) 143 | (setf (gethash object (originals tween)) 144 | (funcall (fdefinition (accessor tween)) object)))) 145 | 146 | (defmethod reset ((tween accessor-tween)) 147 | (loop for object being the hash-keys of (originals tween) 148 | for value being the hash-values of (originals tween) 149 | do (funcall (fdefinition `(setf ,(accessor tween))) value object) 150 | (remhash object (originals tween)))) 151 | 152 | (defmethod copy ((tween accessor-tween)) 153 | (let ((c (call-next-method))) 154 | (setf (accessor c) (accessor tween)) 155 | c)) 156 | 157 | (defmethod tick ((tween accessor-tween) object clock step) 158 | (funcall (fdefinition `(setf ,(accessor tween))) 159 | (tween-value tween object clock step) object)) 160 | 161 | (defclass range-tween (tween) 162 | ((from :initarg :from :accessor from) 163 | (to :initarg :to :accessor to) 164 | (ease-func :initarg :ease :accessor ease-func)) 165 | (:default-initargs 166 | :from NIL 167 | :to 1 168 | :ease 'linear)) 169 | 170 | (defmethod copy ((tween range-tween)) 171 | (let ((c (call-next-method))) 172 | (setf (from c) (from tween)) 173 | (setf (to c) (to tween)) 174 | (setf (ease-func c) (ease-func tween)) 175 | c)) 176 | 177 | (defmethod tween-value ((tween range-tween) object clock step) 178 | (ease-object (or (from tween) 179 | (original-value object tween)) 180 | (to tween) step (ease-func tween))) 181 | 182 | (defclass constant-tween (tween) 183 | ((by :initarg :by :accessor by) 184 | (for :initarg :for :accessor for) 185 | (start :initform NIL :accessor start)) 186 | (:default-initargs 187 | :by 1 188 | :for 1)) 189 | 190 | (defmethod copy ((tween constant-tween)) 191 | (let ((c (call-next-method))) 192 | (setf (by c) (by tween)) 193 | (setf (for c) (for tween)) 194 | c)) 195 | 196 | (defmethod reset :after ((tween constant-tween)) 197 | (setf (start tween) NIL)) 198 | 199 | (defmethod tween-value ((tween constant-tween) object clock step) 200 | (let ((rlclock (- clock (or (start tween) (setf (start tween) clock))))) 201 | (+ (original-value object tween) (* (by tween) (/ rlclock (for tween)))))) 202 | 203 | (defclass range-slot-tween (range-tween slot-tween) 204 | ()) 205 | 206 | (defclass increase-slot-tween (constant-tween slot-tween) 207 | ()) 208 | 209 | (defclass range-accessor-tween (range-tween accessor-tween) 210 | ()) 211 | 212 | (defclass increase-accessor-tween (constant-tween accessor-tween) 213 | ()) 214 | 215 | (define-change-parser set (accessor &key from (to 1) (ease 'linear)) 216 | `(make-instance 'range-accessor-tween :ease ',ease :from ,from :to ,to :accessor ',accessor)) 217 | 218 | (define-change-parser increase (accessor &key (by 1) (for 1)) 219 | `(make-instance 'increase-accessor-tween :by ,by :for ,for :accessor ',accessor)) 220 | 221 | (defclass call-slot-tween (slot-tween call-change) 222 | ()) 223 | 224 | (defmethod tween-value ((tween call-slot-tween) object clock step) 225 | (funcall (func tween) object clock step)) 226 | 227 | (defclass call-accessor-tween (accessor-tween call-change) 228 | ()) 229 | 230 | (defmethod tween-value ((tween call-accessor-tween) object clock step) 231 | (funcall (func tween) object clock step)) 232 | 233 | (define-change-parser calc (accessor &key to) 234 | `(make-instance 'call-accessor-tween 235 | :func (lambda (object clock step) 236 | (declare (ignorable object clock step)) 237 | ,to) 238 | :accessor ',accessor)) 239 | -------------------------------------------------------------------------------- /animation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare) 2 | 3 | (defclass animatable () ()) 4 | (defclass progression-definition () ()) 5 | (defclass progression () ()) 6 | (defclass animation () ()) 7 | (defclass change () ()) 8 | 9 | (defgeneric progressions (animatable)) 10 | (defgeneric add-progression (progression animatable)) 11 | (defgeneric remove-progression (progression animatable)) 12 | (defgeneric progression (denominator animatable)) 13 | 14 | (defgeneric animations (progression-definition)) 15 | (defgeneric instances (progression-definition)) 16 | (defgeneric progression-instance (progression-definition)) 17 | 18 | (defgeneric present-animations (progression)) 19 | (defgeneric past-animations (progression)) 20 | (defgeneric future-animations (progression)) 21 | 22 | (defgeneric copy (animation)) 23 | (defgeneric beginning (animation)) 24 | (defgeneric duration (animation)) 25 | (defgeneric changes (animation)) 26 | (defgeneric selector (animation)) 27 | (defgeneric tick (animation animatable clock step)) 28 | 29 | (defclass animatable () 30 | ((progressions :initform () :accessor progressions))) 31 | 32 | (defmethod update :after ((animatable animatable) dt) 33 | (dolist (progression (progressions animatable)) 34 | (update progression dt))) 35 | 36 | (defmethod reset :before ((animatable animatable)) 37 | (dolist (progression (progressions animatable)) 38 | (reset progression))) 39 | 40 | (defmethod add-progression ((progression progression) (animatable animatable)) 41 | (when (and (animatable progression) 42 | (not (eql (animatable progression) animatable))) 43 | (error "")) 44 | (setf (animatable progression) animatable) 45 | (push progression (progressions animatable)) 46 | progression) 47 | 48 | (defmethod enter ((progression progression) (animatable animatable)) 49 | (add-progression progression animatable) 50 | progression) 51 | 52 | (defmethod remove-progression ((progression progression) (animatable animatable)) 53 | (unless (eql (animatable progression) animatable) 54 | (error "")) 55 | (setf (animatable progression) NIL) 56 | (setf (progressions animatable) 57 | (delete progression (progressions animatable))) 58 | progression) 59 | 60 | (defmethod leave ((progression progression) (animatable animatable)) 61 | (remove-progression progression animatable) 62 | progression) 63 | 64 | (defmethod progression ((definition progression-definition) (animatable animatable)) 65 | (loop for progression in (progressions animatable) 66 | when (eql (definition progression) definition) 67 | return progression)) 68 | 69 | (defmethod progression ((definition symbol) animatable) 70 | (progression (progression-definition definition) animatable)) 71 | 72 | (defclass progression-definition () 73 | ((animations :initform (make-array 0) :accessor animations) 74 | (instances :initform () :accessor instances))) 75 | 76 | (defmethod progression-instance ((definition progression-definition)) 77 | (let ((instance (make-instance 'progression :definition definition))) 78 | (push (tg:make-weak-pointer instance) (instances definition)) 79 | instance)) 80 | 81 | (defmethod add-progression ((definition progression-definition) (animatable animatable)) 82 | (add-progression (progression-instance definition) animatable)) 83 | 84 | (defmethod enter ((definition progression-definition) (animatable animatable)) 85 | (add-progression definition animatable) 86 | definition) 87 | 88 | (defmethod (setf animations) (animations (definition progression-definition)) 89 | (setf (slot-value definition 'animations) 90 | (ensure-sorted animations #'animation<))) 91 | 92 | (defmethod (setf animations) :after (val (definition progression-definition)) 93 | ;; Take the chance to clear out empty references. 94 | ;; FIXME: This system sucks. Maybe something more indirect where the progression instance checks for changes on its own would be better 95 | (setf (instances definition) (delete-if-not #'tg:weak-pointer-value (instances definition))) 96 | #++ 97 | (loop for pointer in (instances definition) 98 | do (setf (animations (tg:weak-pointer-value pointer)) (animations definition)))) 99 | 100 | (defclass progression (clock) 101 | ((definition :initarg :definition :accessor definition) 102 | (animatable :initarg :animatable :accessor animatable) 103 | (active :initform #() :accessor present-animations) 104 | (ended :initform #() :accessor past-animations) 105 | (future :initform #() :accessor future-animations)) 106 | (:default-initargs 107 | :animatable NIL 108 | :definition (error "DEFINITION required."))) 109 | 110 | (defmethod initialize-instance :after ((progression progression) &key) 111 | (setf (animations progression) (animations (definition progression)))) 112 | 113 | (defmethod print-object ((progression progression) stream) 114 | (print-unreadable-object (progression stream :type T :identity T) 115 | (format stream "~s ~s ~s ~s" 116 | (if (running progression) :started :stopped) (clock progression) 117 | :animatable (animatable progression)))) 118 | 119 | (defun copy-animations (thing) 120 | (let ((new (make-array (length thing) :fill-pointer (length thing)))) 121 | (etypecase thing 122 | (vector (loop for i from 0 below (length thing) 123 | do (setf (aref new i) (copy (aref thing i))))) 124 | (list (loop for i from 0 125 | for el in thing 126 | do (setf (aref new i) (copy el))))) 127 | new)) 128 | 129 | (defmethod (setf animations) (animations (progression progression)) 130 | (let ((clock (clock progression))) 131 | ;; Rewind 132 | (reset progression) 133 | ;; Unload new changes 134 | (setf (future-animations progression) 135 | (ensure-sorted (copy-animations animations) #'animation<)) 136 | (setf (present-animations progression) 137 | (make-array (length (future-animations progression)) :fill-pointer 0)) 138 | (setf (past-animations progression) 139 | (make-array (length (future-animations progression)) :fill-pointer 0)) 140 | ;; Fast-forward 141 | (setf (clock progression) clock) 142 | (cond ((running progression) 143 | (update progression 0.0)) 144 | (T 145 | (setf (running progression) T) 146 | (update progression 0.0) 147 | (setf (running progression) NIL)))) 148 | animations) 149 | 150 | (defvar *resetting* NIL) ; oh dear. 151 | 152 | (defmethod reset ((progression progression)) 153 | (let ((*resetting* T)) 154 | ;; Rewind done changes to active set 155 | (loop repeat (length (past-animations progression)) 156 | do (vector-push (vector-pop (past-animations progression)) 157 | (present-animations progression))) 158 | ;; Resort to ascertain order of activation 159 | (setf (present-animations progression) 160 | (ensure-sorted (present-animations progression) #'animation>)) 161 | ;; Reset in order. 162 | (loop for animation across (present-animations progression) 163 | do (reset animation)) 164 | (loop repeat (length (present-animations progression)) 165 | for animation = (vector-pop (present-animations progression)) 166 | do (vector-push animation (future-animations progression))) 167 | ;; Fix clock. 168 | (call-next-method)) 169 | progression) 170 | 171 | (defun shift-array-elements (from to test) 172 | (loop with i = 0 173 | while (< i (length from)) 174 | do (cond ((funcall test (aref from i)) 175 | (vector-push (array-utils:vector-pop-position from i) to)) 176 | (T 177 | (incf i))))) 178 | 179 | ;; Trix! This is called automatically on an UPDATE due to the 180 | ;; inheritance from the CLOCK calling it. 181 | (defmethod (setf clock) :before (new (progression progression)) 182 | ;; If we're travelling backwards we first need to reset completely. 183 | (let ((old (clock progression))) 184 | (when (and (< new old) (not *resetting*)) 185 | (reset progression)))) 186 | 187 | (defmethod update ((progression progression) dt) 188 | ;; Start new ones 189 | (shift-array-elements 190 | (future-animations progression) 191 | (present-animations progression) 192 | (lambda (animation) 193 | (<= (beginning animation) (clock progression)))) 194 | ;; Animate 195 | (when (animatable progression) 196 | (loop for animation across (present-animations progression) 197 | for step = (cond ((eql T (duration animation)) 198 | T) 199 | ((<= (duration animation) 0) 200 | 1.0) 201 | (T 202 | (min (/ (- (clock progression) (beginning animation)) 203 | (duration animation)) 204 | 1.0))) 205 | do (tick animation (animatable progression) (clock progression) step))) 206 | ;; End expired 207 | (shift-array-elements 208 | (present-animations progression) 209 | (past-animations progression) 210 | (lambda (animation) 211 | (and (not (eql (duration animation) T)) 212 | (<= (+ (beginning animation) (duration animation)) (clock progression))))) 213 | ;; Stop altogether if finished 214 | (when (= 0 215 | (length (present-animations progression)) 216 | (length (future-animations progression))) 217 | (stop progression))) 218 | 219 | (defclass animation () 220 | ((defindex :initarg :defindex :accessor defindex) 221 | (beginning :initarg :beginning :accessor beginning) 222 | (duration :initarg :duration :accessor duration) 223 | (selector :initarg :selector :accessor selector) 224 | (changes :initarg :changes :accessor changes)) 225 | (:default-initargs 226 | :defindex 0 227 | :beginning (error "BEGINNING needed.") 228 | :duration (error "DURATION needed.") 229 | :selector T 230 | :changes ())) 231 | 232 | (defmethod initialize-instance :after ((animation animation) &key) 233 | (setf (selector animation) (selector animation))) 234 | 235 | (defmethod print-object ((animation animation) stream) 236 | (print-unreadable-object (animation stream :type T :identity T) 237 | (format stream "~s ~s ~s ~s" :start (beginning animation) :duration (duration animation)))) 238 | 239 | (defun animation< (a b) 240 | (and (< (beginning a) (beginning b)) 241 | (< (defindex a) (defindex b)))) 242 | 243 | (defun animation> (a b) 244 | (and (> (beginning a) (beginning b)) 245 | (> (defindex a) (defindex b)))) 246 | 247 | (defmethod (setf selector) (value (animation animation)) 248 | (setf (slot-value animation 'selector) 249 | (typecase value 250 | (function value) 251 | (T (compile-selector value))))) 252 | 253 | (defmethod copy ((animation animation)) 254 | (make-instance 'animation 255 | :defindex (defindex animation) 256 | :beginning (beginning animation) 257 | :duration (duration animation) 258 | :selector (selector animation) 259 | :changes (mapcar #'copy (changes animation)))) 260 | 261 | (defmethod tick ((animation animation) (animatable animatable) clock step) 262 | (funcall (selector animation) 263 | animatable 264 | (lambda (object) 265 | (dolist (change (changes animation)) 266 | (tick change object clock step))))) 267 | 268 | (defmethod reset ((animation animation)) 269 | (dolist (change (changes animation)) 270 | (reset change))) 271 | 272 | (defun format-progression (progr) 273 | (format T "~&Clock: ~a~%~%Progression:~% Future:~{~% ~a~}~% Present:~{~~% ~a~}~~% Past: ~{~~% ~a~}~~%~%Scene:" 274 | (clock (animatable progr)) 275 | (coerce (future-animations progr) 'list) 276 | (coerce (present-animations progr) 'list) 277 | (coerce (past-animations progr) 'list)) 278 | (print-container-tree (animatable progr))) 279 | 280 | 281 | (defun simulate-progression (def) 282 | (let ((scene (make-instance 'scene)) 283 | (progr (progression-instance def))) 284 | (enter progr scene) 285 | (start scene) 286 | (start progr) 287 | (loop (update scene 0.7) 288 | (format-progression progr) 289 | (sleep 0.7)))) 290 | -------------------------------------------------------------------------------- /documentation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flare) 2 | 3 | ;; animation.lisp 4 | (docs:define-docs 5 | (type animatable 6 | "Superclass container for anything that is animatable through progressions. 7 | 8 | See PROGRESSIONS") 9 | 10 | (type progression-definition 11 | "Container class to instantiate a progression from. 12 | 13 | The definition should at all time keep track of the existing instances 14 | and update them in case the definition gets updated with new animations. 15 | When the animations of the definition are set, the animations are also 16 | set for each of the known instances of the definition. 17 | 18 | See ANIMATIONS 19 | See INSTANCES") 20 | 21 | (type progression 22 | "The controller to animate an animatable with. 23 | 24 | Contains an entire sequence of animations and controls their behaviour 25 | and effects on the animatable. 26 | 27 | When animations on the progression are set, the following happens: 28 | 1. The current clock is saved. 29 | 2. The progression is reset. 30 | 3. The new animations are set to the future set and sorted, the other 31 | sets are cleared and reinitialised to match the appropriate length. 32 | 4. The clock is set to the previously saved time. 33 | 5. All applicable animations are put into effect in fast-forwarding by 34 | calling UPDATE on the progression. 35 | 36 | When a progression is reset, the following happens: 37 | 1. All past animations are pushed onto the present set. 38 | 2. The active animations are re-sorted to ensure consistency. 39 | 3. All the animations in the present set are reset in order. 40 | 4. All animations are pushed onto the future set. 41 | 5. The clock is fixed. 42 | 43 | When a progression is updated, the following happens: 44 | 1. New animations that are now active during the current clock are 45 | shifted from the future set to the present set. 46 | 2. When the progression has an animatable, each animation is ticked. 47 | For this, the tick step must be calculated. If the duration of the 48 | animation is infinite, the tick is T. If the animation exceeded its 49 | duration, it is 1.0. Otherwise it is the linear interpolation 50 | between the current clock time, the beginning of the animation, and 51 | its duration. 52 | 3. Animations that have exceeded their duration are shifted from the 53 | present set onto the past set. 54 | 4. If no present or future animations remain, the progression stops 55 | itself. 56 | 57 | See CLOCK 58 | See DEFINITION 59 | See ANIMATABLE 60 | See ACTIVE 61 | See ENDED 62 | See FUTURE") 63 | 64 | (type animation 65 | "A representation for a single set of changes in a progression. 66 | 67 | When an animation is ticked, the following happens: 68 | 1. The selector is called with the given animatable and a function 69 | 2. Once the selector calls its function with a matching object, 70 | each change in the animation is ticked with the matching object 71 | as argument. 72 | 73 | When an animation is reset, each change in the animation is also 74 | reset. This should cause whatever effect it might have had to be 75 | restored on the scene. This is particularly tricky for operations 76 | as they need to ensure the scene stays consistent. 77 | 78 | See START 79 | See DURATION 80 | See SELECTOR 81 | See CHANGES") 82 | 83 | (type change 84 | "Container for a single change or tween within an animation.") 85 | 86 | (variable *resetting* 87 | "A kludge variable used to prevent recursion upon a progression reset.") 88 | 89 | (function progressions 90 | "Accessor to the list of progressions that act upon this. 91 | 92 | See ANIMATABLE") 93 | 94 | (function add-progression 95 | "Attach a new progression onto the animatable. 96 | 97 | See PROGRESSION 98 | See ANIMATABLE") 99 | 100 | (function remove-progression 101 | "Remove an existing progression from animatable. 102 | 103 | See PROGRESSION 104 | See ANIMATABLE") 105 | 106 | (function progression 107 | "Return the first progression instance that matches the denominator within the container.") 108 | 109 | (function animations 110 | "Accessor to the vector of animations that the progression holds.") 111 | 112 | (function instances 113 | "Accessor to all progression instances that were created from this definition. 114 | 115 | See PROGRESSION-DEFINITION") 116 | 117 | (function progression-instance 118 | "Constructs a new progression instance using the given definition. 119 | 120 | See PROGRESSION 121 | See PROGRESSION-DEFINITION") 122 | 123 | (function definition 124 | "Accessor to the progression's progression-definition 125 | 126 | See PROGRESSION") 127 | 128 | (function animatable 129 | "Accessor to the animatable the progression is acting upon. 130 | 131 | See PROGRESSION") 132 | 133 | (function present-animations 134 | "Accessor to the vector of currently active animations within the clock time. 135 | 136 | See PROGRESSION") 137 | 138 | (function past-animations 139 | "Accessor to the vector of animations that have ended before the current clock time. 140 | 141 | See PROGRESSION") 142 | 143 | (function future-animations 144 | "Accessor to the vector of animations that have yet to become activated after the current clock time. 145 | 146 | See PROGRESSION") 147 | 148 | (function copy-animations 149 | "Create a copy of the given sequence of animations. 150 | 151 | Calls COPY on each animation.") 152 | 153 | (function shift-array-elements 154 | "Moves elements from FROM to TO if they pass TEST. 155 | 156 | Elements are actively removed from FROM and inserted into TO 157 | 158 | See ARRAY-UTILS:VECTOR-POP-POSITION 159 | See CL:VECTOR-PUSH") 160 | 161 | (function copy 162 | "Copy the given object as appropriate for its type. 163 | Only useful for copying ANIMATIONs and CHANGEs 164 | 165 | See ANIMATION 166 | See CHAGNE") 167 | 168 | (function beginning 169 | "Accessor to the beginning (in seconds) at which the animation should start. 170 | 171 | See ANIMATION") 172 | 173 | (function duration 174 | "Accessor to the duration (in seconds) that the animation should be active for. 175 | Can also be T, in which case the animation should go on forever. 176 | 177 | See ANIMATION") 178 | 179 | (function changes 180 | "Accessor to the list of changes that the animation executes. 181 | 182 | See ANIMATION") 183 | 184 | (function selector 185 | "Accessor to the selector that describes which elements to affect. 186 | 187 | See ANIMATION 188 | See COMPILE-SELECTOR") 189 | 190 | (function tick 191 | "Performs a single update tick, moving along the animation on the animatable at the given clock for the given step amount of time. 192 | 193 | See ANIMATION 194 | See ANIMATABLE 195 | See CLOCK") 196 | 197 | (function format-progression 198 | "Print the progression in a usable manner to inspect its current state. 199 | Useful for debugging 200 | 201 | See PROGRESSION") 202 | 203 | (function simulate-progression 204 | "Simulates running the progression-definition. 205 | 206 | Creates a new scene instance and progression instance, 207 | starts both of those and then updates the scene, printing 208 | the progression each 0.7 seconds. 209 | 210 | See SCENE 211 | See PROGRESSION-INSTANCE 212 | See UPDATE 213 | See FORMAT-PROGRESSION")) 214 | 215 | ;; change.lisp 216 | (docs:define-docs 217 | (function parse-change 218 | "Parse a change definition form that gives the TYPE and ARGS into an evaluatable form.") 219 | 220 | (function define-change-parser 221 | "Define a parser for the given type of change.") 222 | 223 | (function copy 224 | "Create a copy of the given item in a way that is deemed appropriate for it. 225 | Mostly used for copying changes.") 226 | 227 | (type print-change 228 | "A NO-OP change that simply prints its TICK arguments when called. 229 | Useful for debugging. 230 | 231 | Creation: (print) 232 | 233 | See CHANGE 234 | See TICK") 235 | 236 | (type call-change 237 | "A change that calls a specified function on every tick. 238 | The function is called with the OBJECT, CLOCK, and STEP received from TICK. 239 | 240 | Creation: (call :func tick-function) 241 | 242 | See CHANGE 243 | See FUNC 244 | See TICK") 245 | 246 | (function func 247 | "Accessor to the function container slot.") 248 | 249 | (type operation 250 | "Superclass for changes that modify the scene graph by adding, removing, or moving elements within it. 251 | 252 | See CHANGE") 253 | 254 | (type enter-operation 255 | "Represents an operation that introduces new objects into the scene graph. 256 | 257 | Creation: (enter class :n number-of-copies :children child-forms :parent parent init-args..) 258 | Child-forms being a list of enter forms, excluding the ENTER symbol at the start. 259 | init-args being further initialisation arguments to be passed to the class that's being instantiated. 260 | 261 | Upon TICK, the CREATOR function is executed and each resulting object is ENTERed into the 262 | given target animatable. 263 | 264 | See OPERATION 265 | See OBJECTS 266 | See CREATOR") 267 | 268 | (function objects 269 | "Accessor to a value that stores which objects are being managed.") 270 | 271 | (function creator 272 | "Accessor to the function that upon calling instantiates one or more objects. 273 | 274 | See ENTER-OPERATION") 275 | 276 | (type leave-operation 277 | "Represents an operation that removes objects from the scene graph. 278 | 279 | Creation: (leave) 280 | 281 | Upon TICK, the given animatable is removed from its parents by LEAVE. 282 | 283 | See OPERATION 284 | See OBJECTS") 285 | 286 | (type tween 287 | "Superclass for changes that modify the given animatable, but do not change the scene graph. 288 | 289 | See CHANGE") 290 | 291 | (function tween-value 292 | "Computes the currently applicable value for the given tween, object, clock, and stepping time. 293 | 294 | See TWEEN") 295 | 296 | (function original-value 297 | "Returns the original value this object might have had before the given tween changed anything. 298 | 299 | See TWEEN") 300 | 301 | (type slot-tween 302 | "A tween mixin that modifies a slot on the object. 303 | 304 | Upon TICK the slot-value is set with the result of TWEEN-VALUE. 305 | 306 | See TWEEN 307 | See SLOT 308 | See ORIGINALS 309 | See TWEEN-VALUE") 310 | 311 | (function slot 312 | "Accessor to the slot that should be modified.") 313 | 314 | (function originals 315 | "A hash table to store the original values of objects before they were changed.") 316 | 317 | (type accessor-tween 318 | "A tween mixin that modifies an object through an accessor. 319 | 320 | Upon TICK the corresponding setf function is called with the result of TWEEN-VALUE. 321 | 322 | See TWEEN 323 | See ACCESSOR 324 | See ORIGINALS 325 | See TWEEN-VALUE") 326 | 327 | (function accessor 328 | "Accessor to the accessor that should be used to modify an object.") 329 | 330 | (type range-tween 331 | "A tween mixin that interpolates a given range of values using an easing function. 332 | 333 | Implements TWEEN-VALUE 334 | Default FROM is 0, TO is 1, and EASE is LINEAR. 335 | 336 | See TWEEN 337 | See FROM 338 | See TO 339 | See EASE-FUNC 340 | See *EASINGS*") 341 | 342 | (function from 343 | "Accessor to the beginning value. 344 | 345 | See RANGE-TWEEN") 346 | 347 | (function to 348 | "Accessor to the ending value. 349 | 350 | See RANGE-TWEEN") 351 | 352 | (function ease-func 353 | "Accessor to the easing function to be used to interpolate the value range. 354 | 355 | See RANGE-TWEEN") 356 | 357 | (type constant-tween 358 | "A tween mixin that simply increases a value every tick. 359 | 360 | Implements TWEEN-VALUE 361 | Default BY and FOR are 1. 362 | 363 | See TWEEN 364 | See BY 365 | See FOR 366 | See START") 367 | 368 | (function by 369 | "The step by which to increase each unit. 370 | 371 | See CONSTANT-TWEEN") 372 | 373 | (function for 374 | "The time step (in seconds) in which the value is increased by a single BY unit. 375 | 376 | See CONSTANT-TWEEN") 377 | 378 | (function start 379 | "Stores the starting clock time at which the tween was started. 380 | 381 | See CONSTANT-TWEEN") 382 | 383 | (type range-slot-tween 384 | "Combination of a range-tween and a slot-tween. 385 | 386 | See RANGE-TWEEN 387 | See SLOT-TWEEN") 388 | 389 | (type increase-slot-tween 390 | "Combination of a constant-tween and a slot-tween. 391 | 392 | See CONSTANT-TWEEN 393 | See SLOT-TWEEN") 394 | 395 | (type range-accessor-tween 396 | "Combination of a range-tween and an accessor-tween. 397 | 398 | Creation: (set accessor :ease easing-func :from from :to to) 399 | 400 | See RANGE-TWEEN 401 | See ACCESSOR-TWEEN") 402 | 403 | (type increase-accessor-tween 404 | "Combination of a constant-tween and an accessor-tween. 405 | 406 | Creation: (increase accessor :by by :for for) 407 | 408 | See CONSTANT-TWEEN 409 | See ACCESSOR-TWEEN") 410 | 411 | (type call-slot-tween 412 | "Combination of a call-change and a slot-tween. 413 | 414 | Implements TWEEN-VALUE. 415 | 416 | See CALL-CHANGE 417 | See SLOT-TWEEN 418 | See TWEEN-VALUE") 419 | 420 | (type call-accessor-tween 421 | "Combination of a call-change and an accessor-tween. 422 | 423 | Creation: (calc accessor :to form) 424 | The FORM may use the implicit variables OBJECT, CLOCK, and STEP. 425 | 426 | Implements TWEEN-VALUE. 427 | 428 | See CALL-CHANGE 429 | See SLOT-TWEEN 430 | See TWEEN-VALUE")) 431 | 432 | ;; clock.lisp 433 | (docs:define-docs 434 | (function update 435 | "Updates the given object, causing its internal representation to be adapted for the current time. 436 | 437 | Returns the object given.") 438 | 439 | (function stop 440 | "Stops the given clock. 441 | 442 | Returns the object given. 443 | 444 | See CLOCK") 445 | 446 | (function start 447 | "Starts the given clock. 448 | 449 | Returns the object given. 450 | 451 | See CLOCK") 452 | 453 | (function reset 454 | "Resets the given clock to its initial state. 455 | 456 | Returns the object given. 457 | 458 | See CLOCK") 459 | 460 | (function running 461 | "Accessor to whether the clock is currently running or not. 462 | 463 | See CLOCK") 464 | 465 | (function timescale 466 | "Accessor to the timescale of the clock to allow slowing or speeding up the progression of time. 467 | 468 | See CLOCK") 469 | 470 | (function synchronize 471 | "Synchronize the clock to the new time. 472 | 473 | Time should be another clock or seconds. 474 | 475 | Returns the object given. 476 | 477 | See CLOCK") 478 | 479 | (function clock 480 | "Accessor to the current time in the clock. 481 | 482 | Note that the current time in the clock must not necessarily be 100% accurate. 483 | In order to get perfectly accurate current time of the clock, you must call UPDATE 484 | on it before retrieving its current time value with CLOCK. 485 | 486 | See CLOCK") 487 | 488 | (type clock 489 | "A representation for an item that changes its state over time. 490 | 491 | Keeps its own time information in seconds. 492 | 493 | See START 494 | See STOP 495 | See RESET 496 | See RUNNING 497 | See UPDATE 498 | See SNYCHRONIZE 499 | See CLOCK 500 | See PREVIOUS-TIME") 501 | 502 | (function previous-time 503 | "Accessor to the previous internal-real-time when the clock was updated. 504 | 505 | See CLOCK")) 506 | 507 | ;; container.lisp 508 | (docs:define-docs 509 | (function name 510 | "Reader to the name of the unit. 511 | 512 | The name may be NIL. 513 | 514 | See UNIT") 515 | 516 | (function enter 517 | "Adds the given UNIT into the CONTAINER. 518 | 519 | Returns the unit given. 520 | 521 | See UNIT 522 | See CONTAINER") 523 | 524 | (function leave 525 | "Removes the given UNIT from the CONTAINER. 526 | 527 | Returns the unit given. 528 | 529 | See UNIT 530 | See CONTAINER") 531 | 532 | (function clear 533 | "Removes all objects from the CONTAINER. 534 | 535 | Returns the object given. 536 | 537 | See CONTAINER") 538 | 539 | (function name-map 540 | "Accessor to the name table of the scene-graph. 541 | 542 | See SCENE-GRAPH") 543 | 544 | (function units 545 | "Returns a fresh list of all units in the scene-graph tree. 546 | 547 | See UNIT 548 | See SCENE-GRAPH") 549 | 550 | (function unit 551 | "Accessor to a given, named unit in the scene-graph. 552 | 553 | See UNIT 554 | See SCENE-GRAPH") 555 | 556 | (function register 557 | "Registers the unit with the scene-graph, making it accessible by its name. 558 | Any unit that is entered into any part of the scene-graph must be registered by this 559 | function. This should happen automatically provided you use the CONTAINER-UNIT class 560 | for containers inside the scene-graph. Thus you need not call this function unless 561 | you implement your own container. 562 | 563 | See UNIT 564 | See SCENE-GRAPH") 565 | 566 | (function deregister 567 | "Deregisters the unit with the scene-graph, making it accessible by its name. 568 | Any unit that leaves from any part of the scene-graph must be deregistered by this 569 | function. This should happen automatically provided you use the CONTAINER-UNIT class 570 | for containers inside the scene-graph. Thus you need not call this function unless 571 | you implement your own container. 572 | 573 | See UNIT 574 | See SCENE-GRAPH") 575 | 576 | (function scene-graph 577 | "Accessor to the scene-graph the container-unit is in. 578 | 579 | See CONTAINER-UNIT") 580 | 581 | (type container 582 | "A simple class that can hold a set of objects. 583 | 584 | See CLEAR 585 | See OBJECTS 586 | See ENTER 587 | See LEAVE 588 | See MAP-CONTAINER-TREE 589 | See DO-CONTAINER-TREE 590 | See PRINT-CONTAINER-TREE") 591 | 592 | (function map-container-tree 593 | "Recursively maps FUNCTION over all descendants of CONTAINER. 594 | 595 | See CONTAINER") 596 | 597 | (function do-container-tree 598 | "Iterates over all descendants of CONTAINER 599 | 600 | See MAP-CONTAINER-TREE") 601 | 602 | (function print-container-tree 603 | "Prints the entire CONTAINER tree hierarchy nicely to the given STREAM. 604 | 605 | See CONTAINER") 606 | 607 | (type scene-graph 608 | "A scene-graph is a container that also has a name-map to easily reach objects. 609 | 610 | This includes all objects in the container tree that have a non-NIL name. 611 | 612 | See CONTAINER") 613 | 614 | (type container-unit 615 | "A container unit is a unit that can contain further objects. 616 | 617 | See CONTAINER 618 | See UNIT") 619 | 620 | (type unit 621 | "A unit is an object with a name.")) 622 | 623 | ;; easings.lisp 624 | (docs:define-documentation-test easing (symb) 625 | (easing symb)) 626 | 627 | (docs:define-docs 628 | (variable *easings* 629 | "A hash table associating names to easing functions. 630 | 631 | Each easing function takes a single float value between 0 and 1 that should be eased according to a curve.") 632 | 633 | (variable *ease-docs* 634 | "A hash table associating names to easing function docstrings.") 635 | 636 | (function easing 637 | "Accessor to the easing function associated with the given name, if any. 638 | 639 | See *EASINGS*") 640 | 641 | (function remove-easing 642 | "Removes the easing function associated with the given name. 643 | 644 | See *EASINGS*") 645 | 646 | (function define-easing 647 | "Shorthand macro to define an easing function. 648 | 649 | See EASING") 650 | 651 | (function ease 652 | "Shorthand function to perform an easing interpolation. 653 | 654 | X must be a float between 0 and 1 655 | BY must name an easing function 656 | FROM and TO must be REALs specifying the boundaries of the easing.") 657 | 658 | (function ease-object 659 | "Shorthand function to ease a range. 660 | 661 | FROM and TO must be matching objects 662 | 663 | By default works on REALs and VECs. 664 | 665 | See EASE") 666 | 667 | (easing linear 668 | "Interpolates by a linear curve. 669 | 670 | See http://easings.net/") 671 | 672 | (easing quad-in 673 | "Interpolates by a quad-in curve. 674 | 675 | See http://easings.net/") 676 | 677 | (easing quad-out 678 | "Interpolates by a quad-out curve. 679 | 680 | See http://easings.net/") 681 | 682 | (easing quad-in-out 683 | "Interpolates by a quad-in-out curve. 684 | 685 | See http://easings.net/") 686 | 687 | (easing cubic-in 688 | "Interpolates by a cubic-in curve. 689 | 690 | See http://easings.net/") 691 | 692 | (easing cubic-out 693 | "Interpolates by a cubic-out curve. 694 | 695 | See http://easings.net/") 696 | 697 | (easing cubic-in-out 698 | "Interpolates by a cubic-in-out curve. 699 | 700 | See http://easings.net/") 701 | 702 | (easing quart-in 703 | "Interpolates by a quart-in curve. 704 | 705 | See http://easings.net/") 706 | 707 | (easing quart-out 708 | "Interpolates by a quart-out curve. 709 | 710 | See http://easings.net/") 711 | 712 | (easing quart-in-out 713 | "Interpolates by a quart-in-out curve. 714 | 715 | See http://easings.net/") 716 | 717 | (easing quint-in 718 | "Interpolates by a quint-in curve. 719 | 720 | See http://easings.net/") 721 | 722 | (easing quint-out 723 | "Interpolates by a quint-out curve. 724 | 725 | See http://easings.net/") 726 | 727 | (easing quint-in-out 728 | "Interpolates by a quint-in-out curve. 729 | 730 | See http://easings.net/") 731 | 732 | (easing sine-in 733 | "Interpolates by a sine-in curve. 734 | 735 | See http://easings.net/") 736 | 737 | (easing sine-out 738 | "Interpolates by a sine-out curve. 739 | 740 | See http://easings.net/") 741 | 742 | (easing sine-in-out 743 | "Interpolates by a sine-in-out curve. 744 | 745 | See http://easings.net/") 746 | 747 | (easing expo-in 748 | "Interpolates by a expo-in curve. 749 | 750 | See http://easings.net/") 751 | 752 | (easing expo-out 753 | "Interpolates by a expo-out curve. 754 | 755 | See http://easings.net/") 756 | 757 | (easing expo-in-out 758 | "Interpolates by a expo-in-out curve. 759 | 760 | See http://easings.net/") 761 | 762 | (easing circ-in 763 | "Interpolates by a circ-in curve. 764 | 765 | See http://easings.net/") 766 | 767 | (easing circ-out 768 | "Interpolates by a circ-out curve. 769 | 770 | See http://easings.net/") 771 | 772 | (easing circ-in-out 773 | "Interpolates by a circ-in-out curve. 774 | 775 | See http://easings.net/") 776 | 777 | (easing back-in 778 | "Interpolates by a back-in curve. 779 | 780 | See http://easings.net/") 781 | 782 | (easing back-out 783 | "Interpolates by a back-out curve. 784 | 785 | See http://easings.net/") 786 | 787 | (easing back-in-out 788 | "Interpolates by a back-in-out curve. 789 | 790 | See http://easings.net/") 791 | 792 | (easing elastic-in 793 | "Interpolates by a elastic-in curve. 794 | 795 | See http://easings.net/") 796 | 797 | (easing elastic-out 798 | "Interpolates by a elastic-out curve. 799 | 800 | See http://easings.net/") 801 | 802 | (easing elastic-in-out 803 | "Interpolates by a elastic-in-out curve. 804 | 805 | See http://easings.net/") 806 | 807 | (easing bounce-in 808 | "Interpolates by a bounce-in curve. 809 | 810 | See http://easings.net/") 811 | 812 | (easing bounce-out 813 | "Interpolates by a bounce-out curve. 814 | 815 | See http://easings.net/") 816 | 817 | (easing bounce-in-out 818 | "Interpolates by a bounce-in-out curve. 819 | 820 | See http://easings.net/")) 821 | 822 | ;; forms.lisp 823 | (docs:define-docs 824 | (function orientation 825 | "Accessor to the vector that defines the orientation of the entity. 826 | 827 | See ORIENTED-ENTITY") 828 | 829 | (function size 830 | "Accessor to the size of the entity. 831 | 832 | See SIZED-ENTITY") 833 | 834 | (function up 835 | "Accessor to the UP vector. 836 | 837 | See ARC") 838 | 839 | (function angle 840 | "Accessor to the angle. 841 | 842 | See ARC") 843 | 844 | (function spacing 845 | "Accessor to the spacing between items. 846 | 847 | See ARC") 848 | 849 | (type oriented-entity 850 | "An entity that can be oriented by a vector. 851 | 852 | See ENTITY 853 | See ORIENTATION") 854 | 855 | (type sized-entity 856 | "An entity that has a given size or extent. 857 | 858 | See ENTITY 859 | See SIZE") 860 | 861 | (type formation 862 | "Entity superclass for all formations. 863 | 864 | Formations only handle the positioning of child entities, but do not display by themselves. 865 | 866 | See ENTITY") 867 | 868 | (function reposition 869 | "Recalculate the positioning of child entities.") 870 | 871 | (type particle 872 | "Entity superclass for all particles. 873 | 874 | Particles should not move by themselves and only handle the displaying. 875 | 876 | See ENTITY") 877 | 878 | (type arc 879 | "Formation to represent an equidistant distribution of entities along an arc. 880 | 881 | See FORMATION 882 | See ORIENTED-ENTITY 883 | See SIZED-ENTITY 884 | See UP 885 | See TANGENT 886 | See ANGLE 887 | See SPACING") 888 | 889 | (function tangent 890 | "The tangent vector between the UP and ORIENTATION. 891 | 892 | See ARC") 893 | 894 | (type ring 895 | "Formation to represent an equidistant distribution of entities along a ring. 896 | 897 | See ARC")) 898 | 899 | ;; paintable.lisp 900 | (docs:define-docs 901 | (function call-with-translation 902 | "Call FUNC after having performed a translation on TARGET by VEC.") 903 | 904 | (function visibility 905 | "Accessor to how opaque the paintable is. 906 | Has to be a float between 0 and 1. 907 | 908 | See PAINTABLE") 909 | 910 | (function paint 911 | "Performs the necessary painting operations to draw PAINTABLE onto TARGET. 912 | 913 | See TARGET 914 | See PAINTABLE") 915 | 916 | (function with-translation 917 | "Shorthand macro for translation. 918 | 919 | See CALL-WITH-TRANSLATION") 920 | 921 | (type target 922 | "Superclass for a painting device onto which things can be drawn. 923 | 924 | See PAINT 925 | See CALL-WITH-TRANSLATION") 926 | 927 | (type paintable 928 | "Superclass for anything that may be painted onto a target. 929 | 930 | See PAINT 931 | See TARGET")) 932 | 933 | ;; parser.lisp 934 | (docs:define-docs 935 | (type interval-designator 936 | "An interval-designator can be either a real, T, or NIL.") 937 | 938 | (function designator-p 939 | "Returns T if the given THING is an interval-designator. 940 | 941 | See INTERVAL-DESIGNATOR") 942 | 943 | (function parse-intervals 944 | "Normalises the lenient interval FORMS into strict expressions. 945 | 946 | result ::= (expression*) 947 | expression ::= (start duration animation-expression) 948 | 949 | See DEFINE-PROGRESSION") 950 | 951 | (variable *mapper* 952 | "A placeholder variable used to hold the final mapping function upon selector evaluation.") 953 | 954 | (variable *i* 955 | "A counter variable used to determine the current index in constraints.") 956 | 957 | (function compile-constraint 958 | "Compile a selector constraint into a function. 959 | 960 | constraint ::= name | nth | this | children | everything | function | list 961 | name --- A symbol naming a unit in the scene-graph 962 | nth --- An integer specifying the nth unit in the scene-graph 963 | this --- The symbol T meaning the current object 964 | children --- A symbol with name \">\" specifying all children of the current object 965 | everything --- A symbol with name \"*\" specifying all descendants as per DO-CONTAINER-TREE 966 | function --- A predicate function that is passed the current object 967 | list --- A quoted literal, function reference, or function form to use 968 | 969 | Resulting from a compile-constraint call should be a function 970 | that takes a single argument, the current object to constrain on. 971 | The NEXT argument is the function to call next if the constraint 972 | passes its test. A single constraint may call this next function 973 | as many times as it wants.") 974 | 975 | (function compile-selector 976 | "Compiles a selector into a function. 977 | 978 | selector ::= constraint | (constraint*) 979 | 980 | Returned is a function of two arguments, a scene-graph and a function. 981 | The scene-graph is the root of the scene graph that is selected on and 982 | each unit within it that the selector is matching on results in a call 983 | to function with that unit as its argument. 984 | 985 | See COMPILE-CONSTRAINT") 986 | 987 | (function compile-change 988 | "Simply calls PARSE-CHANGE") 989 | 990 | (function parse-animation 991 | "Compiles BEGINNING, DURATION, and the definition EXPRESSION into an actual FORM. 992 | 993 | expression ::= (selector change*) 994 | 995 | See COMPILE-CHANGE 996 | See DEFINE-PROGRESSION") 997 | 998 | (function compile-animations 999 | "Compiles INTERVAL definition expressions into a list of animation definition forms. 1000 | 1001 | First normalises the intervals per PARSE-INTERVALS then creates a form for each 1002 | per PARSE-ANIMATION and outputs each into a LIST form. 1003 | 1004 | See DEFINE-PROGRESSION") 1005 | 1006 | (variable *progressions* 1007 | "Hash table to contain global progression definitions.") 1008 | 1009 | (function progression-definition 1010 | "Accessor to the global progression definition by name. 1011 | 1012 | See *PROGRESSIONS*") 1013 | 1014 | (function remove-progression-definition 1015 | "Remove the global progression definition by name 1016 | 1017 | See *PROGRESSIONS*") 1018 | 1019 | (function define-progression 1020 | "Convenience macro to define a global progression. 1021 | Returns the progression name. 1022 | 1023 | The formal specification of the body intervals is as follows: 1024 | body ::= interval* 1025 | interval ::= start [end] animation* 1026 | animation ::= (selector change*) 1027 | change ::= (change-type argument*) 1028 | start --- A real (in seconds) that represents the starting time 1029 | of the animations 1030 | end --- A leal (or T, indicating infinity) that represents the 1031 | ending time of the animations 1032 | selector --- A valid selector as per COMPILE-SELECTOR 1033 | change --- A valid change as per COMPILE-CHANGE 1034 | 1035 | If the END is not specified for a given interval, then the next START 1036 | is taken as the end. If no next start exists, then the end is T. In order 1037 | to allow brevity, multiple animations can be specified between two time 1038 | codes. This is then normalised into the strict form of 1039 | (START DURATION ANIMATION) as per PARSE-INTERVALS. 1040 | 1041 | An example definition follows: 1042 | 1043 | (define-progression foo 1044 | 0 (T (enter ring :name :ring :contents (bullet :size 2 :count 20))) 1045 | 0 8 (:ring (increase size :by 2)) 1046 | 0 20 (:ring (set angle :to 1000 :ease 'quad-in-out)) 1047 | ((:ring >) (set size :to 50)) 1048 | 20 (:ring (leave))) 1049 | 1050 | At time 0, a ring is created with name :ring and 20 bullets of size 2 as 1051 | its children. It is entered into the scene-graph. Then from time 0 to 8, 1052 | the ring's size is increased by 2 every second. Simultaneously from time 1053 | 0 to 20 the ring's angle is increased to 1000, eased by the quad-in-out 1054 | interpolation and the ring's children (the 20 bullets) increase in size 1055 | to 50. At time 20, the ring is removed from the scene-graph again. 1056 | 1057 | See PROGRESSION-DEFINITION 1058 | See COMPILE-ANIMATIONS")) 1059 | 1060 | ;; scene.lisp 1061 | (docs:define-docs 1062 | (function scene 1063 | "Accessor to the scene the scene-unit is contained in. 1064 | 1065 | See SCENE 1066 | See SCENE-UNIT") 1067 | 1068 | (function location 1069 | "Accessor to the location of the entity. 1070 | 1071 | See ENTITY") 1072 | 1073 | (type scene 1074 | "Container class to represent the top-level scene that should be drawn and managed. 1075 | 1076 | See SCENE-GRAPH 1077 | See CLOCK 1078 | See PAINTABLE 1079 | See ANIMATABLE") 1080 | 1081 | (type entity 1082 | "A paintable and animatable entity within a scene. 1083 | 1084 | See CONTAINER-UNIT 1085 | See PAINTABLE 1086 | See ANIMATABLE 1087 | See LOCATION")) 1088 | 1089 | ;; toolkit.lisp 1090 | (docs:define-docs 1091 | (function define-self-returning-method 1092 | "Shorthand to define an :around method that will ensure the first argument is always returned.") 1093 | 1094 | (function ensure-sorted 1095 | "Ensures that the VEC is sorted stably in-place. 1096 | 1097 | This means that if STABLE-SORT returns a new vector instead of re-using the given one, 1098 | the elements from the new vector are copied back into the old one so that it appears 1099 | as if it had been modified in-place. Always returns VEC. 1100 | 1101 | See STBLE-SORT")) 1102 | 1103 | (in-package #:org.shirakumo.flare.indexed-set) 1104 | ;; indexed-set.lisp 1105 | (docs:define-docs 1106 | (type indexed-set 1107 | "A set in which each element also has an index. 1108 | 1109 | Aside from MAP-SET and DO-SET you can also use ITERATE 1110 | to go through the set by FOR .. ON-SET or FOR .. IN-SET. 1111 | 1112 | See QUEUE 1113 | See SET 1114 | See MAKE-INDEXED-SET 1115 | See MAP-SET 1116 | See DO-SET 1117 | See SET-ADD 1118 | See SET-REMOVE 1119 | See SET-SIZE 1120 | See SET-FIRST 1121 | See SET-LAST 1122 | See SET-VALUE-AT 1123 | See SET-INDEX-OF 1124 | See CLEAR-SET 1125 | See IN-SET-P 1126 | See COERCE-SET") 1127 | 1128 | (function set 1129 | "Accessor to the set table of the indexed-set. 1130 | 1131 | See INDEXED-SET") 1132 | 1133 | (function make-indexed-set 1134 | "Creates a new indexed set. 1135 | 1136 | See INDEXED-SET") 1137 | 1138 | (function map-set 1139 | "Maps the function over all elements of the set in order. 1140 | 1141 | See INDEXED-SET") 1142 | 1143 | (function do-set 1144 | "Iterates over all elements of the set in order. 1145 | 1146 | See INDEXED-SET") 1147 | 1148 | (function set-add 1149 | "Add a new value to the set. 1150 | 1151 | Returns two values, the value that was added, and whether it was added 1152 | as a new element to the set. If it already existed, the second value is 1153 | NIL. 1154 | 1155 | See INDEXED-SET") 1156 | 1157 | (function set-remove 1158 | "Remove a value from the set. 1159 | 1160 | Returns two values, the set that was modified, and whether the value 1161 | existed in the set to begin with. If it did not, the second value is 1162 | NIL. 1163 | 1164 | See INDEXED-SET") 1165 | 1166 | (function set-size 1167 | "Returns the number of items in the set. 1168 | 1169 | See INDEXED-SET") 1170 | 1171 | (function set-first 1172 | "Returns the first item in the set. 1173 | 1174 | See INDEXED-SET") 1175 | 1176 | (function set-last 1177 | "Returns the last item in the set. 1178 | 1179 | See INDEXED-SET") 1180 | 1181 | (function set-value-at 1182 | "Returns the value at the given index in the set. 1183 | 1184 | See INDEXED-SET") 1185 | 1186 | (function set-index-of 1187 | "Returns the index of the value in the set. 1188 | 1189 | See INDEXED-SET") 1190 | 1191 | (function clear-set 1192 | "Removes all values from the set. 1193 | 1194 | See INDEXED-SET") 1195 | 1196 | (function in-set-p 1197 | "Returns T if the value is contained in the set. 1198 | 1199 | See INDEXED-SET") 1200 | 1201 | (function coerce-set 1202 | "Allows coercing the set to: 1203 | 1204 | indexed-set, hash-table, queue, list, vector, or sequence. 1205 | 1206 | See INDEXED-SET 1207 | See COERCE-QUEUE")) 1208 | 1209 | (in-package #:org.shirakumo.flare.queue) 1210 | ;; queue.lisp 1211 | (docs:define-docs 1212 | (type cell 1213 | "Struct to contain a queue cell with VALUE, LEFT, and RIGHT slots. 1214 | 1215 | See VALUE 1216 | See LEFT 1217 | See RIGHT") 1218 | 1219 | (function make-cell 1220 | "Constructs a new queue cell. 1221 | 1222 | See CELL") 1223 | 1224 | (function value 1225 | "Accesses the value contained in a queue cell. 1226 | 1227 | See CELL") 1228 | 1229 | (function left 1230 | "Accesses the cell left to the current cell. 1231 | 1232 | See CELL") 1233 | 1234 | (function right 1235 | "Accesses the cell right to the current cell. 1236 | 1237 | See CELL") 1238 | 1239 | (function cell-tie 1240 | "Tie the two cells together so that they become adjacent. 1241 | 1242 | See CELL") 1243 | 1244 | (function cell-insert-before 1245 | "Inserts the cell before its neighbour, making sure to keep all links updated. 1246 | 1247 | See CELL") 1248 | 1249 | (function cell-insert-after 1250 | "Inserts the cell after its neighbour, making sure to keep all links updated. 1251 | 1252 | See CELL") 1253 | 1254 | (function cell-remove 1255 | "Removes the cell out of the link chain, making sure to keep all links updated. 1256 | Unless the cell is the only item in the link chain, its left/right slots are not 1257 | modified. 1258 | 1259 | See CELL") 1260 | 1261 | (function remove-cells 1262 | "Removes all cells between and including the given left and right cells. 1263 | 1264 | Note that the consequences are undefined if the given left cell is actually to the 1265 | right of the right cell, or if they are from different queues entirely. 1266 | 1267 | See CELL") 1268 | 1269 | (type queue 1270 | "Implements an ordered queue. 1271 | 1272 | Aside from MAP-QUEUE and DO-QUEUE you can also use ITERATE 1273 | to go through the set by FOR .. ON-QUEUE or FOR .. IN-QUEUE. 1274 | 1275 | See HEAD 1276 | See TAIL 1277 | See SIZE 1278 | See MAP-QUEUE 1279 | See DO-QUEUE 1280 | See ENQUEUE 1281 | See DEQUEUE 1282 | See QUEUE-REMOVE 1283 | See QUEUE-SIZE 1284 | See QUEUE-FIRST 1285 | See QUEUE-LAST 1286 | See QUEUE-VALUE-AT 1287 | See QUEUE-INDEX-OF 1288 | See CLEAR-QUEUE 1289 | See IN-QUEUE-P 1290 | See COERCE-QUEUE") 1291 | 1292 | (function head 1293 | "Accesses the head cell of the queue 1294 | 1295 | See CELL 1296 | See QUEUE") 1297 | 1298 | (function tail 1299 | "Accesses the tail cell of the queue 1300 | 1301 | See CELL 1302 | See QUEUE") 1303 | 1304 | (function size 1305 | "Accesses the size counter of the queue. 1306 | 1307 | See QUEUE") 1308 | 1309 | (function make-queue 1310 | "Creates a new queue instance. 1311 | 1312 | See QUEUE") 1313 | 1314 | (function map-queue 1315 | "Maps the function over all values in the queue in order. 1316 | 1317 | See QUEUE") 1318 | 1319 | (function do-queue 1320 | "Iterates over each value in the queue in order. 1321 | 1322 | See QUEUE") 1323 | 1324 | (function enqueue 1325 | "Inserts the given value at the end of the queue. 1326 | 1327 | See QUEUE") 1328 | 1329 | (function dequeue 1330 | "Pops the next value off the front of the queue. 1331 | The second value indicates whether there was any element in the queue at all. 1332 | 1333 | See QUEUE") 1334 | 1335 | (function queue-remove 1336 | "Removes the given value from the queue. 1337 | 1338 | This is potentially very costly as it might have to scan the entire queue. 1339 | 1340 | See QUEUE") 1341 | 1342 | (function queue-size 1343 | "Returns the number of elements in the queue. 1344 | 1345 | See QUEUE") 1346 | 1347 | (function queue-first 1348 | "Returns the first (front) value in the queue if there is any. 1349 | The second value indicates whether there was any element in the queue at all. 1350 | 1351 | See QUEUE") 1352 | 1353 | (function queue-last 1354 | "Returns the last (end) value in the queue if there is any. 1355 | The second value indicates whether there was any element in the queue at all. 1356 | 1357 | See QUEUE") 1358 | 1359 | (function queue-value-at 1360 | "Returns the value at the given position in the queue. 1361 | The second value is NIL if the position is out of range. 1362 | 1363 | This is potentially very costly as it might have to scan the entire queue. 1364 | 1365 | See QUEUE") 1366 | 1367 | (function queue-index-of 1368 | "Returns the index of the value in the queue. 1369 | If the value could not be found, NIL is returned instead. 1370 | 1371 | This is potentially very costly as it might have to scan the entire queue. 1372 | 1373 | See QUEUE") 1374 | 1375 | (function clear-queue 1376 | "Removes all elements from the queue. 1377 | 1378 | See QUEUE") 1379 | 1380 | (function in-queue-p 1381 | "Returns T if the given value is found in the queue. 1382 | 1383 | See QUEUE") 1384 | 1385 | (function coerce-queue 1386 | "Allows coercing the queue to: 1387 | 1388 | queue, list, vector, or sequence. 1389 | 1390 | See QUEUE")) 1391 | --------------------------------------------------------------------------------