suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

more random mred testing

Browse Source 
svn: r14863
This commit is contained in:
Matthew Flatt 2009-05-19 00:27:39 +00:00
parent c4b4af817b
commit 63a7a9c77b
1 changed files with 39 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/tests/mred/wxme-random.ss
View File

@ -1,20 +1,24 @@
#lang scheme/gui #lang scheme/gui
(define seed 704050726 #;(abs (current-milliseconds))) (define seed 700438844 #;(abs (current-milliseconds)))
(random-seed seed) (random-seed seed)
(define t (new text%)) ; scroll-line-location bug
(define orig-t (new text%))
(define frame (define frame
(new frame% [label "Test"] (new frame% [label "Test"]
[width 300] [width 300]
[height 400])) [height 400]))
(define canvas (define canvas
(new editor-canvas% [parent frame] [editor t])) (new editor-canvas% [parent frame] [editor orig-t]))
(send frame show #t) (send frame show #t)
(send t set-max-undo-history 100) (define (init t)
(send t set-max-undo-history 100))
(init orig-t)
(define (random-elem v) (define (random-elem v)
(vector-ref v (random (vector-length v)))) (vector-ref v (random (vector-length v))))
@ -22,40 +26,51 @@
(define (random-string) (define (random-string)
(random-elem '#("a" "x\ny\nz\n" "hello there"))) (random-elem '#("a" "x\ny\nz\n" "hello there")))
(define seq 0) (define seqs (make-hasheq))
(define ts (make-weak-hasheq))
(define actions (define actions
(vector (vector
(lambda () (send t undo)) (lambda (t) (send t undo))
(lambda () (send t redo)) (lambda (t) (send t redo))
(lambda () (send t insert (random-string) (random (add1 (send t last-position))))) (lambda (t) (send t insert (random-string) (random (add1 (send t last-position)))))
(lambda () (lambda (t)
(let ([pos (random (add1 (send t last-position)))]) (let ([pos (random (add1 (send t last-position)))])
(send t delete pos (random (max 1 (- (send t last-position) pos)))))) (send t delete pos (random (max 1 (- (send t last-position) pos))))))
(lambda () (lambda (t)
(send t begin-edit-sequence) (send t begin-edit-sequence)
(set! seq (add1 seq))) (hash-update! seqs t add1 0))
(lambda () (lambda (t)
(let loop () (let loop ()
(when (positive? seq) (when (positive? (hash-ref seqs t 0))
(send t end-edit-sequence) (send t end-edit-sequence)
(set! seq (sub1 seq)) (hash-update! seqs t sub1)
(when (zero? (random 2)) (when (zero? (random 2))
(loop))))) (loop)))))
(lambda () (lambda (t)
(let ([pos (random (add1 (send t last-position)))]) (let ([pos (random (add1 (send t last-position)))])
(send t set-position pos (random (max 1 (- (send t last-position) pos)))))) (send t set-position pos (random (max 1 (- (send t last-position) pos))))))
(lambda () (send t copy)) (lambda (t) (send t copy))
(lambda () (send t cut)) (lambda (t) (send t cut))
(lambda () (send t paste)) (lambda (t) (send t paste))
(lambda () (send t change-style (make-object style-delta% 'change-size (add1 (random 42))))) (lambda (t) (send t change-style (make-object style-delta% 'change-size (add1 (random 42)))))
(lambda () (send t insert (make-object editor-snip%))) (lambda (t)
(let ([t2 (new text%)])
(hash-set! ts t2 #t)
(init t2)
(send t insert (make-object editor-snip% t2))))
(lambda (t)
(send t set-max-width (if (zero? (random 2)) 100.0 'none)))
)) ))
(let loop () (let loop ()
(let ([act (random-elem actions)]) (let ([act (random-elem actions)]
[t (if (zero? (random 2))
orig-t
(for/fold ([t orig-t])
([t (in-hash-keys ts)]
[n (in-range (random (add1 (hash-count ts))))])
t))])
(printf "~s: ~s\n" seed act) (printf "~s: ~s\n" seed act)
(act) (act t)
(loop))) (loop)))