/[flexichain]/flexichain/rtester.lisp
ViewVC logotype

Contents of /flexichain/rtester.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Mon Oct 4 06:54:30 2010 UTC (3 years, 6 months ago) by rstrandh
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +2 -0 lines
Removed the CLIM-based tester.

Put the random tester code in the tester package.
1 (in-package :tester)
2
3 (defparameter *instructions* '())
4
5 (defparameter *ins-del-state* t)
6
7 (defparameter *cursors-real* '())
8
9 (defparameter *cursors-fake* '())
10
11 (defparameter *fc-real* (make-instance 'flexichain:standard-cursorchain))
12
13 (defparameter *fc-fake* (make-instance 'stupid:standard-cursorchain))
14
15 ;; nb-elements fch
16 ;; element* fch pos
17 ;; cursor-pos fcu
18 ;; element< fcu
19 ;; element> fcu
20
21 ;; insert* fch pos obj
22 ;; delete* fch pos
23 ;; (setf element*)
24 ;; clone-cursor fcu
25 ;; (setf cursor-pos)
26 ;; insert fcu obj
27 ;; delete< fcu
28 ;; delete> fcu
29 ;; (setf element<)
30 ;; (setf element>)
31
32 ;; [flexi-empty-p fch]
33 ;; [push-start fch obj]
34 ;; [push-end fch obj]
35 ;; [pop-start fch obj]
36 ;; [pop-end fch obj]
37 ;; [rotate fch &optional (n 1)]
38 ;; [at-beginning-p fcu]
39 ;; [at-end-p fcu]
40 ;; [insert-sequence fcu sequence]
41
42 (defun compare ()
43 ;; check that they are the same length
44 (assert (= (flexichain:nb-elements *fc-real*)
45 (stupid:nb-elements *fc-fake*)))
46 ;; check that they have the same elements in the same places
47 (loop for pos from 0 below (flexichain:nb-elements *fc-real*)
48 do (assert (= (flexichain:element* *fc-real* pos)
49 (stupid:element* *fc-fake* pos))))
50 ;; check all the cursors
51 (loop for x in *cursors-real*
52 for y in *cursors-fake*
53 do (assert (= (flexichain:cursor-pos x)
54 (stupid:cursor-pos y)))
55 (unless (zerop (flexichain:cursor-pos x))
56 (assert (= (flexichain:element< x)
57 (stupid:element< y))))
58 (unless (= (flexichain:cursor-pos x)
59 (flexichain:nb-elements *fc-real*))
60 (assert (= (flexichain:element> x)
61 (stupid:element> y))))))
62
63 (defun add-inst (inst)
64 (push inst *instructions*))
65
66 (defun i* (&optional
67 (pos (random (1+ (stupid:nb-elements *fc-fake*))))
68 (elem (random 1000000)))
69 (add-inst `(i* ,pos ,elem))
70 (flexichain:insert* *fc-real* pos elem)
71 (stupid:insert* *fc-fake* pos elem))
72
73 (defun d* (&optional pos)
74 (unless (zerop (stupid:nb-elements *fc-fake*))
75 (unless pos
76 (setf pos (random (stupid:nb-elements *fc-fake*))))
77 (add-inst `(d* ,pos))
78 (flexichain:delete* *fc-real* pos)
79 (stupid:delete* *fc-fake* pos)))
80
81 (defun se* (&optional pos elem)
82 (unless (zerop (stupid:nb-elements *fc-fake*))
83 (unless pos
84 (setf pos (random (stupid:nb-elements *fc-fake*))
85 elem (random 1000000)))
86 (add-inst `(se* ,pos ,elem))
87 (setf (flexichain:element* *fc-real* pos) elem)
88 (setf (stupid:element* *fc-fake* pos) elem)))
89
90 (defun mlc ()
91 (add-inst `(mlc))
92 (push (make-instance 'flexichain:left-sticky-flexicursor :chain *fc-real*)
93 *cursors-real*)
94 (push (make-instance 'stupid:left-sticky-flexicursor :chain *fc-fake*)
95 *cursors-fake*))
96
97 (defun mrc ()
98 (add-inst `(mrc))
99 (push (make-instance 'flexichain:right-sticky-flexicursor :chain *fc-real*)
100 *cursors-real*)
101 (push (make-instance 'stupid:right-sticky-flexicursor :chain *fc-fake*)
102 *cursors-fake*))
103
104
105 (defun cc (&optional (elt (random (length *cursors-real*))))
106 (add-inst `(cc ,elt))
107 (push (flexichain:clone-cursor (elt *cursors-real* elt)) *cursors-real*)
108 (push (stupid:clone-cursor (elt *cursors-fake* elt)) *cursors-fake*))
109
110 (defun scp (&optional
111 (elt (random (length *cursors-real*)))
112 (pos (random (1+ (flexichain:nb-elements *fc-real*)))))
113 (add-inst `(scp ,elt ,pos))
114 (setf (flexichain:cursor-pos (elt *cursors-real* elt)) pos)
115 (setf (stupid:cursor-pos (elt *cursors-fake* elt)) pos))
116
117 (defun ii (&optional
118 (elt (random (length *cursors-fake*)))
119 (elem (random 1000000)))
120 (add-inst `(ii ,elt ,elem))
121 (flexichain:insert (elt *cursors-real* elt) elem)
122 (stupid:insert (elt *cursors-fake* elt) elem))
123
124 (defun d< (&optional (elt (random (length *cursors-real*))))
125 (unless (zerop (stupid:cursor-pos (elt *cursors-fake* elt)))
126 (add-inst `(d< ,elt))
127 (flexichain:delete< (elt *cursors-real* elt))
128 (stupid:delete< (elt *cursors-fake* elt))))
129
130 (defun d> (&optional (elt (random (length *cursors-fake*))))
131 (unless (= (stupid:cursor-pos (elt *cursors-fake* elt))
132 (stupid:nb-elements (stupid:chain (elt *cursors-fake* elt))))
133 (add-inst `(d> ,elt))
134 (flexichain:delete> (elt *cursors-real* elt))
135 (stupid:delete> (elt *cursors-fake* elt))))
136
137 (defun s< (&optional
138 (elt (random (length *cursors-real*)))
139 (elem (random 1000000)))
140 (unless (zerop (stupid:cursor-pos (elt *cursors-fake* elt)))
141 (add-inst `(s< ,elt ,elem))
142 (setf (flexichain:element< (elt *cursors-real* elt)) elem)
143 (setf (stupid:element< (elt *cursors-fake* elt)) elem)))
144
145 (defun s> (&optional
146 (elt (random (length *cursors-real*)))
147 (elem (random 1000000)))
148 (unless (= (stupid:cursor-pos (elt *cursors-fake* elt))
149 (stupid:nb-elements (stupid:chain (elt *cursors-fake* elt))))
150 (add-inst `(s> ,elt ,elem))
151 (setf (flexichain:element> (elt *cursors-real* elt)) elem)
152 (setf (stupid:element> (elt *cursors-fake* elt)) elem)))
153
154 (defmacro randomcase (&body clauses)
155 `(ecase (random ,(length clauses))
156 ,@(loop for clause in clauses
157 for i from 0
158 collect `(,i ,clause))))
159
160 (defun i-or-d ()
161 (if *ins-del-state*
162 (randomcase (i*) (ii))
163 (randomcase (d*) (d<) (d>))))
164
165 (defun setel ()
166 (randomcase (se*) (s<) (s>)))
167
168 (defun mc ()
169 (randomcase (mlc) (mrc)))
170
171 (defun test-step ()
172 (when (zerop (random 200))
173 (setf *ins-del-state* (not *ins-del-state*)))
174 (randomcase (i-or-d) (setel) (mc) (cc) (scp))
175 (compare))
176
177 (defun reset-all ()
178 (setf *instructions* '())
179 (setf *ins-del-state* t)
180 (setf *cursors-real* '())
181 (setf *cursors-fake* '())
182 (setf *fc-real* (make-instance 'flexichain:standard-cursorchain))
183 (setf *fc-fake* (make-instance 'stupid:standard-cursorchain)))
184
185 (defun tester (&optional (n 1))
186 (reset-all)
187 (mlc)
188 (mrc)
189 (loop repeat n
190 do (test-step)))
191
192 (defun replay (instructions)
193 (let ((*instructions* '()))
194 (reset-all)
195 (loop for inst in (reverse instructions)
196 do (apply (car inst) (cdr inst))
197 (compare))))

  ViewVC Help
Powered by ViewVC 1.1.5