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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
(in-package :contextl-user)
(define-layered-class figure-element-2 ()
())
(define-layered-function move-2 (figure-element dx dy))
(define-layered-class point-2 (figure-element-2)
((x :initarg :x :initform 0 :layered t :accessor point-x-2)
(y :initarg :y :initform 0 :layered t :accessor point-y-2)))
(define-layered-method move-2 ((elm point-2) (dx integer) (dy integer))
(incf (point-x-2 elm) dx)
(incf (point-y-2 elm) dy))
(define-layered-class line-2 (figure-element-2)
((p1 :initarg :p1 :initform (make-instance 'point-2) :layered t :accessor line-p1-2)
(p2 :initarg :p2 :initform (make-instance 'point-2) :layered t :accessor line-p2-2)))
(define-layered-method move-2 ((elm line-2) (dx integer) (dy integer))
(move-2 (line-p1-2 elm) dx dy)
(move-2 (line-p2-2 elm) dx dy))
(deflayer display-layer-2)
(declaim (type integer *update-count-2*))
(defparameter *update-count-2* 0)
(defun call-and-update-2 (thunk)
(let ((result (with-inactive-layers (display-layer-2)
(funcall thunk))))
(incf *update-count-2*)
result))
(define-layered-method (setf slot-value-using-layer)
:in display-layer-2 :around
(new-value class (object figure-element-2) slot writer)
(call-and-update-2 (lambda () (funcall writer new-value))))
(define-layered-method move-2
:in display-layer-2 :around
((elm figure-element-2) dx dy)
(call-and-update-2 #'call-next-method))
(defconstant +lines-2+ 100)
(defparameter *lines-2*
(loop repeat +lines-2+
collect (make-instance
'line-2
:p1 (make-instance
'point-2
:x (random 100)
:y (random 100))
:p2 (make-instance
'point-2
:x (random 100)
:y (random 100)))))
(defun move-lines/non-layered-2 ()
(loop for line in *lines-2*
do (move-2 line 5 -5))
(loop for line in *lines-2*
do (move-2 line -5 5)))
(defun move-lines/layered-2 ()
(loop for line in *lines-2*
do (with-active-layers (display-layer-2)
(move-2 line 5 -5)))
(loop for line in *lines-2*
do (with-active-layers (display-layer-2)
(move-2 line -5 5))))
(defconstant +runs-2+ 1000)
(defun run-test-2 ()
(setf *update-count-2* 0)
(time (loop repeat +runs-2+ do (move-lines/non-layered-2)))
(assert (eql *update-count-2* 0))
(time (loop repeat +runs-2+ do (move-lines/layered-2)))
(assert (eql *update-count-2* (* +lines-2+ +runs-2+ 2))))
|
