more random testing
svn: r14971
This commit is contained in:
Matthew Flatt
parent
60baa972f5
commit
2b80e7d68d
|
|
@ -3,111 +3,196 @@
|
|||
(define seed (abs (current-milliseconds)))
|
||||
(random-seed seed)
|
||||
|
||||
(define use-nested? #t)
|
||||
|
||||
(error-print-context-length 100)
|
||||
|
||||
(define orig-t (new text%))
|
||||
|
||||
(define frame
|
||||
(new (class frame%
|
||||
(define/augment (on-close) (exit))
|
||||
(super-new))
|
||||
[label "Test"]
|
||||
[width 300]
|
||||
[height 400]))
|
||||
(define canvas
|
||||
(new editor-canvas% [parent frame] [editor orig-t]))
|
||||
|
||||
(send frame show #t)
|
||||
|
||||
(define (init t)
|
||||
(send t set-max-undo-history 100))
|
||||
(init orig-t)
|
||||
|
||||
(define (random-elem v)
|
||||
(vector-ref v (random (vector-length v))))
|
||||
|
||||
(define (random-string)
|
||||
(random-elem '#("a" "x\ny\nz\n" "(define (f x)\n (+ x x))\n" "hello there")))
|
||||
|
||||
(define seqs (make-hasheq))
|
||||
|
||||
(define ts-length 64)
|
||||
(define ts-pos 0)
|
||||
(define ts (make-vector ts-length orig-t))
|
||||
(define (add-t! t2)
|
||||
(if (= ts-pos ts-length)
|
||||
(let ([v ts])
|
||||
(set! ts (make-vector ts-length orig-t))
|
||||
(set! ts-pos 0)
|
||||
(for ([t3 (in-vector v)])
|
||||
(when (zero? (random 2))
|
||||
(add-t! t3)))
|
||||
(add-t! t2))
|
||||
(begin
|
||||
(vector-set! ts ts-pos t2)
|
||||
(set! ts-pos (add1 ts-pos)))))
|
||||
|
||||
;; Don't paste before copying, because that interferes with replay
|
||||
(define copied? #f)
|
||||
(define (set-copied?! t)
|
||||
(unless (= (send t get-start-position)
|
||||
(send t get-end-position))
|
||||
(set! copied? #t)))
|
||||
(define copy-len 0)
|
||||
|
||||
(define actions
|
||||
(vector
|
||||
(lambda (t) (send t undo))
|
||||
(lambda (t) (send t redo))
|
||||
(lambda (t) (send t insert (random-string) (random (add1 (send t last-position)))))
|
||||
(lambda (t) (send t insert "\t" (random (add1 (send t last-position)))))
|
||||
(lambda (t)
|
||||
(let ([pos (random (add1 (send t last-position)))])
|
||||
(send t delete pos (random (max 1 (- (send t last-position) pos))))))
|
||||
(lambda (t)
|
||||
(send t begin-edit-sequence)
|
||||
(hash-update! seqs t add1 0))
|
||||
(lambda (t)
|
||||
(let loop ()
|
||||
(when (positive? (hash-ref seqs t 0))
|
||||
(send t end-edit-sequence)
|
||||
(hash-update! seqs t sub1)
|
||||
(when (zero? (random 2))
|
||||
(loop)))))
|
||||
(lambda (t)
|
||||
(let ([pos (random (add1 (send t last-position)))])
|
||||
(send t set-position pos (random (max 1 (- (send t last-position) pos))))))
|
||||
(lambda (t) (set-copied?! t) (send t copy))
|
||||
(lambda (t) (set-copied?! t) (send t cut))
|
||||
(lambda (t) (set-copied?! t) (send t kill))
|
||||
(lambda (t) (when copied?
|
||||
(send t paste)
|
||||
(when (zero? (random 4))
|
||||
(send t paste-next))))
|
||||
(lambda (t) (send t change-style (make-object style-delta% 'change-size (add1 (random 42)))))
|
||||
(lambda (t) (send t change-style
|
||||
(send (make-object style-delta%) set-delta-foreground (make-object color%
|
||||
(random 256)
|
||||
(random 256)
|
||||
(random 256)))))
|
||||
(lambda (t)
|
||||
(let ([t2 (new text%)])
|
||||
(add-t! t2)
|
||||
(init t2)
|
||||
(send t insert (make-object editor-snip% t2))))
|
||||
(lambda (t)
|
||||
(send t set-max-width (if (zero? (random 2))
|
||||
(+ 50.0 (/ (random 500) 10.0))
|
||||
'none)))
|
||||
(lambda (t) (yield (system-idle-evt)))
|
||||
))
|
||||
(define (go pause x-pos)
|
||||
(define orig-t (new text%))
|
||||
|
||||
(define frame
|
||||
(new (class frame%
|
||||
(define/augment (on-close) (exit))
|
||||
(super-new))
|
||||
[label "Test"]
|
||||
[width 300]
|
||||
[height 400]
|
||||
[x x-pos]))
|
||||
|
||||
(define canvas
|
||||
(new editor-canvas% [parent frame] [editor orig-t]))
|
||||
|
||||
(define _1 (send frame show #t))
|
||||
|
||||
(define (init t)
|
||||
(send t set-max-undo-history 100))
|
||||
(define _2 (init orig-t))
|
||||
|
||||
(define (random-elem v)
|
||||
(vector-ref v (random (vector-length v))))
|
||||
|
||||
(define (random-string)
|
||||
(random-elem '#("a" "x\ny\nz\n" "(define (f x)\n (+ x x))\n" "hello there")))
|
||||
|
||||
(define seqs (make-hasheq))
|
||||
|
||||
(define ts-length 64)
|
||||
(define ts-pos 0)
|
||||
(define ts (make-vector ts-length orig-t))
|
||||
(define (add-t! t2)
|
||||
(if (= ts-pos ts-length)
|
||||
(let ([v ts])
|
||||
(set! ts (make-vector ts-length orig-t))
|
||||
(set! ts-pos 0)
|
||||
(for ([t3 (in-vector v)])
|
||||
(when (zero? (random 2))
|
||||
(add-t! t3)))
|
||||
(add-t! t2))
|
||||
(begin
|
||||
(vector-set! ts ts-pos t2)
|
||||
(set! ts-pos (add1 ts-pos)))))
|
||||
|
||||
(define (set-copied?! t)
|
||||
(let ([len (- (send t get-end-position)
|
||||
(send t get-start-position))])
|
||||
(if (zero? len)
|
||||
#f
|
||||
(begin
|
||||
(set! copy-len len)
|
||||
(set! copied? #t)
|
||||
#t))))
|
||||
|
||||
(define (maybe-convert)
|
||||
(when (zero? (random 4))
|
||||
(let ([data (send the-clipboard get-clipboard-data "WXME" 0)])
|
||||
(send the-clipboard set-clipboard-client
|
||||
(new (class clipboard-client%
|
||||
(inherit add-type)
|
||||
(super-new)
|
||||
(add-type "WXME")
|
||||
(define/override (get-data format) data)))
|
||||
0))))
|
||||
|
||||
(define actions
|
||||
(vector
|
||||
(lambda (t) (send t undo))
|
||||
(lambda (t) (send t redo))
|
||||
(lambda (t) (send t insert (random-string) (random (add1 (send t last-position)))))
|
||||
(lambda (t) (send t insert "\t" (random (add1 (send t last-position)))))
|
||||
(lambda (t)
|
||||
(let ([pos (random (add1 (send t last-position)))])
|
||||
(send t delete pos (random (max 1 (- (send t last-position) pos))))))
|
||||
(lambda (t)
|
||||
(send t begin-edit-sequence)
|
||||
(hash-update! seqs t add1 0))
|
||||
(lambda (t)
|
||||
(let loop ()
|
||||
(when (positive? (hash-ref seqs t 0))
|
||||
(send t end-edit-sequence)
|
||||
(hash-update! seqs t sub1)
|
||||
(when (zero? (random 2))
|
||||
(loop)))))
|
||||
(lambda (t)
|
||||
(let ([pos (random (add1 (send t last-position)))])
|
||||
(send t set-position pos (random (max 1 (- (send t last-position) pos))))))
|
||||
(lambda (t) (when (set-copied?! t) (send t copy) (maybe-convert)))
|
||||
(lambda (t) (when (set-copied?! t) (send t cut) (maybe-convert)))
|
||||
(lambda (t) (when copied?
|
||||
(let ([s (send t get-start-position)]
|
||||
[e (send t get-end-position)]
|
||||
[l (send t last-position)])
|
||||
(send t paste)
|
||||
(when copy-len
|
||||
(unless (= (send t last-position)
|
||||
(+ (- l (- e s)) copy-len))
|
||||
(error 'paste "length mismatch: [~s, ~s) in ~s + ~s ~s -> ~s"
|
||||
s e l copy-len
|
||||
(send the-clipboard get-clipboard-data "TEXT" 0)
|
||||
(send t last-position)))))
|
||||
(when (zero? (random 4))
|
||||
(set! copy-len #f)
|
||||
(send t paste-next))))
|
||||
(lambda (t) (send t change-style (make-object style-delta% 'change-size (add1 (random 42)))))
|
||||
(lambda (t) (send t change-style
|
||||
(send (make-object style-delta%) set-delta-foreground (make-object color%
|
||||
(random 256)
|
||||
(random 256)
|
||||
(random 256)))))
|
||||
(lambda (t)
|
||||
(when use-nested?
|
||||
(let ([t2 (new text%)])
|
||||
(add-t! t2)
|
||||
(init t2)
|
||||
(send t insert (make-object editor-snip% t2)))))
|
||||
(lambda (t)
|
||||
(send t set-max-width (if (zero? (random 2))
|
||||
(+ 50.0 (/ (random 500) 10.0))
|
||||
'none)))
|
||||
(lambda (t) (yield (system-idle-evt)))
|
||||
(lambda (t) (pause))
|
||||
))
|
||||
|
||||
(send canvas focus)
|
||||
|
||||
(let loop ()
|
||||
(let ([act (random-elem actions)]
|
||||
[t (if (zero? (random 2))
|
||||
orig-t
|
||||
(random-elem ts))])
|
||||
(printf "~s: ~s ~s\n" seed (eq-hash-code t) act)
|
||||
(act t)
|
||||
(loop))))
|
||||
|
||||
(define (run-one)
|
||||
(go void 50))
|
||||
|
||||
(define (run-two-concurrent)
|
||||
(define sema-one (make-semaphore))
|
||||
(define sema-two (make-semaphore))
|
||||
|
||||
(define (make sema-this sema-other x-pos)
|
||||
(parameterize ([current-eventspace (make-eventspace)])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(semaphore-wait sema-this)
|
||||
(go (lambda ()
|
||||
(semaphore-post sema-other)
|
||||
(semaphore-wait sema-this))
|
||||
x-pos)))
|
||||
(current-eventspace)))
|
||||
|
||||
(define e1 (make sema-one sema-two 50))
|
||||
(define e2 (make sema-two sema-one 350))
|
||||
(semaphore-post sema-one)
|
||||
(application-quit-handler (lambda args (exit)))
|
||||
(yield never-evt))
|
||||
|
||||
(define (run-two)
|
||||
(define one-box (box #f))
|
||||
(define two-box (box #f))
|
||||
(define (make box-this box-other x-pos)
|
||||
(let/ec esc
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(begin
|
||||
(let/cc k
|
||||
(set-box! box-this k)
|
||||
(esc))
|
||||
(go (lambda ()
|
||||
(let/cc k
|
||||
(set-box! box-this k)
|
||||
((unbox box-other))))
|
||||
x-pos))))))
|
||||
|
||||
(make one-box two-box 50)
|
||||
(make two-box one-box 350)
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
((unbox one-box)))))
|
||||
|
||||
(run-two)
|
||||
|
||||
(send canvas focus)
|
||||
|
||||
(let loop ()
|
||||
(let ([act (random-elem actions)]
|
||||
[t (if (zero? (random 2))
|
||||
orig-t
|
||||
(random-elem ts))])
|
||||
(printf "~s: ~s ~s\n" seed (eq-hash-code t) act)
|
||||
(act t)
|
||||
(loop)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user