trial/array-container.lisp at master · pull-request-perhaps/trial · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
#|
 This file is a part of trial
 (c) 2017 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(in-package #:org.shirakumo.fraf.trial)

(defclass array-container (container)
  ((objects :initform (make-array 0 :adjustable T :fill-pointer T) :accessor objects)))

(defmethod paint ((container array-container) target)
  (for:for ((item across (objects container)))
    (paint item target)))

(defmethod flare:update ((container array-container))
  (for:for ((item across (objects container)))
    (update item)))

(defmethod enter (thing (container array-container))
  (vector-push-extend thing (objects container))
  thing)

(defmethod leave (thing (container array-container))
  (array-utils:vector-pop-position (objects container)
                                   (position thing (objects container)))
  thing)

(defmethod clear ((container array-container))
  (let ((objects (objects container)))
    (loop for i from 0 below (length objects)
          do (setf (aref objects i) NIL))
    (adjust-array objects 0 :fill-pointer 0))
  container)

(defmethod unit (n (container array-container))
  (aref (objects container) n))

(defmethod (setf unit) (value n (container array-container))
  (setf (aref (objects container) n) value))

(defmethod finalize ((container array-container))
  (for:for ((object across (objects container)))
    (finalize object)))

(defmethod register-object-for-pass (pass (container array-container))
  (for:for ((object across (objects container)))
    (register-object-for-pass pass object)))