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

Contents of /flexichain/tester.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: +0 -0 lines
FILE REMOVED
Removed the CLIM-based tester.

Put the random tester code in the tester package.
1 (in-package :tester)
2
3 (define-application-frame tester ()
4 ((chain :initform (make-instance 'standard-cursorchain
5 :element-type 'character
6 :fill-element #\_)
7 :reader chain)
8 (cursors :initform (make-array 2) :reader cursors))
9 (:panes
10 (app :application :width 800 :height 300 :display-function 'display-app)
11 (int :interactor :width 800 :height 500))
12 (:layouts (default (vertically () app int))))
13
14 (defmethod initialize-instance :after ((frame tester) &rest args)
15 (declare (ignore args))
16 (with-slots (chain cursors) frame
17 (setf (aref cursors 0)
18 (make-instance 'left-sticky-flexicursor :chain chain))
19 (setf (aref cursors 1)
20 (make-instance 'right-sticky-flexicursor :chain chain))))
21
22 (defun run-tester ()
23 (loop for port in climi::*all-ports*
24 do (destroy-port port))
25 (setq climi::*all-ports* nil)
26 (run-frame-top-level (make-application-frame 'tester)))
27
28 (defun display-app (frame pane)
29 (let* ((chain (chain frame))
30 (buffer (slot-value chain 'flexichain::buffer))
31 (length (length buffer))
32 (cursors (cursors frame)))
33 (format pane "nb elments: ~a~%~%" (nb-elements chain))
34 (loop for i from 0 below (nb-elements chain)
35 do (format pane " ~a" (element* chain i)))
36 (format pane "~%")
37 (loop for i from 0 below 2
38 do (format pane (if (minusp (cursor-pos (aref cursors i)))
39 (make-string (* -2 (cursor-pos (aref cursors i)))
40 :initial-element #\?)
41 (make-string (* 2 (cursor-pos (aref cursors i)))
42 :initial-element #\space)))
43 (format pane "~a~%" i))
44 (format pane "~%~%")
45 (format pane (if (minusp (slot-value chain 'flexichain::gap-start))
46 (make-string (* -2 (slot-value chain 'flexichain::gap-start))
47 :initial-element #\?)
48 (make-string (* 2 (slot-value chain 'flexichain::gap-start))
49 :initial-element #\space)))
50 (format pane ">~%")
51 (format pane (if (minusp (slot-value chain 'flexichain::gap-end))
52 (make-string (* -2 (slot-value chain 'flexichain::gap-end))
53 :initial-element #\?)
54 (make-string (* 2 (slot-value chain 'flexichain::gap-end))
55 :initial-element #\space)))
56 (format pane "<~%")
57 (loop for i from 0 below length
58 do (format pane "~a~a"
59 (if (= i (slot-value chain 'flexichain::data-start))
60 #\* #\Space)
61 (aref buffer i)))
62 (format pane "~%")
63 (loop for i from 0 below 2
64 do (format pane (make-string (1+ (* 2 (slot-value (aref cursors i)
65 'flexichain::index)))
66 :initial-element #\space))
67 (format pane "~a~a~%" i (at-end-p (aref cursors i))))
68 (format pane "~%~%")))
69
70 (defmethod execute-frame-command :around ((frame tester) command)
71 (declare (ignore command))
72 (handler-case (call-next-method)
73 (flexi-error (condition) (format (frame-standard-input *application-frame*)
74 "~a~%" condition))))
75
76 (define-tester-command (com-empty :name t) ()
77 (format (frame-standard-input *application-frame*)
78 "~a~%" (flexi-empty-p (chain *application-frame*))))
79
80 (defun to-char (symbol)
81 (char-downcase (aref (symbol-name symbol) 0)))
82
83 (define-tester-command (com-is :name t) ((pos 'integer) (object 'symbol))
84 (insert* (chain *application-frame*) pos (to-char object)))
85
86 (define-tester-command (com-element* :name t) ((pos 'integer))
87 (format (frame-standard-input *application-frame*)
88 "~a~%" (element* (chain *application-frame*) pos)))
89
90 (define-tester-command (com-set-element* :name t) ((pos 'integer) (object 'symbol))
91 (setf (element* (chain *application-frame*) pos) (to-char object)))
92
93 (define-tester-command (com-ds :name t) ((pos 'integer))
94 (delete* (chain *application-frame*) pos))
95
96 (define-tester-command (com-push-start :name t) ((object 'symbol))
97 (push-start (chain *application-frame*) (to-char object)))
98
99 (define-tester-command (com-push-end :name t) ((object 'symbol))
100 (push-end (chain *application-frame*) (to-char object)))
101
102 (define-tester-command (com-pop-start :name t) ()
103 (format (frame-standard-input *application-frame*)
104 "~a~%" (pop-start (chain *application-frame*))))
105
106 (define-tester-command (com-pop-end :name t) ()
107 (format (frame-standard-input *application-frame*)
108 "~a~%" (pop-end (chain *application-frame*))))
109
110 (define-tester-command (com-rotate :name t) ((amount 'integer))
111 (rotate (chain *application-frame*) amount))
112
113 (define-tester-command (com-move> :name t) ((cursor 'integer))
114 (move> (aref (cursors *application-frame*) cursor)))
115
116 (define-tester-command (com-move< :name t) ((cursor 'integer))
117 (move< (aref (cursors *application-frame*) cursor)))
118
119 (define-tester-command (com-ii :name t) ((cursor 'integer) (object 'symbol))
120 (insert (aref (cursors *application-frame*) cursor) (to-char object)))
121
122 (define-tester-command (com-d< :name t) ((cursor 'integer))
123 (delete< (aref (cursors *application-frame*) cursor)))
124
125 (define-tester-command (com-d> :name t) ((cursor 'integer))
126 (delete> (aref (cursors *application-frame*) cursor)))
127
128 (define-tester-command (com-clear :name t) ()
129 (with-slots (chain cursors) *application-frame*
130 (setf chain (make-instance 'standard-cursorchain
131 :element-type 'character :fill-element #\_))
132 (setf (aref cursors 0)
133 (make-instance 'left-sticky-flexicursor :chain chain))
134 (setf (aref cursors 1)
135 (make-instance 'right-sticky-flexicursor :chain chain))))
136
137 (define-tester-command (com-quit :name t) ()
138 (frame-exit *application-frame*))

  ViewVC Help
Powered by ViewVC 1.1.5