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

DrDr bugs and spurious errors

Browse Source 
svn: r16412
This commit is contained in:
Jay McCarthy 2009-10-22 18:45:02 +00:00
parent 2955ff1b0e
commit 98488a89ef
5 changed files with 49 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/games/paint-by-numbers/raw-problems/build-solution-sets.ss
View File

@ -28,8 +28,8 @@ The col and row type specs are in sig.ss and the solution type is:
(prefix solve: "../solve.ss"))
(if (equal? (vector) argv)
(fprintf (current-error-port) "pass any command line argument to skip the solver~n~n")
(fprintf (current-error-port) "skipping the solver~n"))
(printf "pass any command line argument to skip the solver~n~n")
(printf "skipping the solver~n"))
(define memory-limit (* 1024 1024 400)) ;; in bytes (500 megs)
@ -156,12 +156,12 @@ The col and row type specs are in sig.ss and the solution type is:
(let loop ([n (- progress-bar-max dots-printed)])
(cond
[(zero? n) (void)]
[else (display "." (current-error-port))
[else (display ".")
(loop (- n 1))]))
(newline (current-error-port))]
(newline)]
[else
(let ([dots-to-print (floor (- (* progress-bar-max (/ counter (- max 1))) dots-printed))])
'(fprintf (current-error-port) "~spercentage: ~a ~a ~a ~a~n"
'(printf "~spercentage: ~a ~a ~a ~a~n"
cleanup
dots-to-print
counter
@ -172,19 +172,19 @@ The col and row type specs are in sig.ss and the solution type is:
(cond
[(zero? n) (void)]
[else
(display "." (current-error-port))
(display ".")
(loop (- n 1))]))
(flush-output (current-error-port)))]))))
(flush-output))]))))
(define (setup-progress max cleanup)
(display guide-string (current-error-port))
(newline (current-error-port))
(display guide-string)
(newline)
(build-progress-outputer max cleanup))
(define (solve name rows cols)
(cond
[(equal? argv (vector))
(fprintf (current-error-port) "Solving ~s; memory limit ~a~n"
(printf "Solving ~s; memory limit ~a~n"
name (format-memory-txt memory-limit))
(let ([row-count (length rows)]
[col-count (length cols)])
@ -240,8 +240,8 @@ The col and row type specs are in sig.ss and the solution type is:
(update-memory-display)
(semaphore-post done)))])
(semaphore-wait done)
(newline (current-error-port))
(newline (current-error-port))
(newline)
(newline)
(if sucessful?
board
#f))]

6
collects/readline/mzrl.ss
View File

@ -110,11 +110,9 @@
;; need to capture the real input port below
(define real-input-port (current-input-port))
(unless (eq? 'stdin (object-name real-input-port))
(fprintf (current-error-port)
"mzrl warning: could not capture the real input port\n"))
(log-warning "mzrl warning: could not capture the real input port\n"))
(unless (terminal-port? real-input-port)
(fprintf (current-error-port)
"mzrl warning: input port is not a terminal\n"))
(log-warning "mzrl warning: input port is not a terminal\n"))
;; make it possible to run Scheme threads while waiting for input
(set-ffi-obj! "rl_event_hook" libreadline (_fun -> _int)

6
collects/tests/mred/testing.ss
View File

@ -12,7 +12,7 @@
(set! test-count (add1 test-count))
(unless (equal? expect got)
(let ([s (format "~a: expected ~e; got ~e" name expect got)])
(printf "ERROR: ~a~n" s)
(fprintf (current-error-port) "ERROR: ~a~n" s)
(set! errs (cons s errs)))))
(define-syntax mismatch
@ -53,9 +53,9 @@
(if (null? errs)
(printf "Passed all ~a tests~n" test-count)
(begin
(printf "~a Error(s) in ~a tests~n" (length errs) test-count)
(fprintf (current-error-port) "~a Error(s) in ~a tests~n" (length errs) test-count)
(for-each
(lambda (s)
(printf "~a~n" s))
(fprintf (current-error-port) "~a~n" s))
(reverse errs)))))

48
collects/tests/mzscheme/cache-image-snip-test.ss
View File

@ -12,11 +12,11 @@
(overlay-bitmap argb dx dy b1 b2)
(argb-vector argb))
(let ([argb (make-argb (vector 100 10 20 30) 1)]
(let ([argb (make-argb (vector 100 10 20 30) 1 1)]
[bm (build-bitmap void 1 1)])
(test #(100 10 20 30) overlay-bitmap/ret argb 0 0 bm bm))
(let ([argb (make-argb (make-vector 4 0) 1)]
(let ([argb (make-argb (make-vector 4 0) 1 1)]
[bm (build-bitmap
(lambda (dc)
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
@ -24,7 +24,7 @@
1 1)])
(test #4(0) overlay-bitmap/ret argb 0 0 bm bm))
(let ([argb (make-argb (make-vector 4 100) 1)]
(let ([argb (make-argb (make-vector 4 100) 1 1)]
[bm (build-bitmap
(lambda (dc)
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
@ -32,11 +32,11 @@
1 1)])
(test #4(0) overlay-bitmap/ret argb 0 0 bm bm))
(let ([argb (make-argb (make-vector 8 254) 1)]
(let ([argb (make-argb (make-vector 8 254) 1 1)]
[bm (build-bitmap void 1 2)])
(test #8(254) overlay-bitmap/ret argb 0 0 bm bm))
(let ([argb (make-argb (make-vector 8 0) 1)]
(let ([argb (make-argb (make-vector 8 0) 1 1)]
[bm (build-bitmap
(lambda (dc)
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
@ -44,7 +44,7 @@
1 2)])
(test #8(0) overlay-bitmap/ret argb 0 0 bm bm))
(let ([argb (make-argb (make-vector 16 100) 2)]
(let ([argb (make-argb (make-vector 16 100) 2 2)]
[bm (build-bitmap
(lambda (dc)
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
@ -56,7 +56,7 @@
100 100 100 100)
overlay-bitmap/ret argb 0 0 bm bm))
(let ([argb (make-argb (make-vector 16 100) 2)]
(let ([argb (make-argb (make-vector 16 100) 2 2)]
[bm (build-bitmap
(lambda (dc)
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
@ -68,7 +68,7 @@
100 100 100 100)
overlay-bitmap/ret argb 0 0 bm bm))
(let ([argb (make-argb (make-vector 16 100) 2)]
(let ([argb (make-argb (make-vector 16 100) 2 2)]
[bm (build-bitmap
(lambda (dc)
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
@ -80,7 +80,7 @@
100 100 100 100)
overlay-bitmap/ret argb 0 0 bm bm))
(let ([argb (make-argb (make-vector 16 100) 2)]
(let ([argb (make-argb (make-vector 16 100) 2 2)]
[bm (build-bitmap
(lambda (dc)
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
@ -92,7 +92,7 @@
0 0 0 0)
overlay-bitmap/ret argb 0 0 bm bm))
(let ([argb (make-argb (make-vector 4 200) 1)]
(let ([argb (make-argb (make-vector 4 200) 1 1)]
[c (build-bitmap
(lambda (dc)
(send dc set-pen
@ -106,7 +106,7 @@
1 1)])
(test #4(0 0 0 100) overlay-bitmap/ret argb 0 0 c m))
(let ([argb (make-argb (make-vector 4 200) 1)]
(let ([argb (make-argb (make-vector 4 200) 1 1)]
[c (build-bitmap
(lambda (dc)
(send dc set-pen
@ -120,7 +120,7 @@
1 1)])
(test #4(0 0 100 0) overlay-bitmap/ret argb 0 0 c m))
(let ([argb (make-argb (make-vector 4 200) 1)]
(let ([argb (make-argb (make-vector 4 200) 1 1)]
[c (build-bitmap
(lambda (dc)
(send dc set-pen
@ -134,7 +134,7 @@
1 1)])
(test #4(0 100 0 0) overlay-bitmap/ret argb 0 0 c m))
(let ([argb (make-argb (make-vector (* 2 2 4) 200) 2)]
(let ([argb (make-argb (make-vector (* 2 2 4) 200) 2 2)]
[bm (build-bitmap
(lambda (dc)
(send dc set-pen
@ -148,7 +148,7 @@
1 0
bm bm))
(let ([argb (make-argb (make-vector (* 2 2 4) 200) 2)]
(let ([argb (make-argb (make-vector (* 2 2 4) 200) 2 2)]
[bm (build-bitmap
(lambda (dc)
(send dc set-pen
@ -173,7 +173,7 @@
[get-one
(lambda (bm)
(let ([dc (make-object bitmap-dc% bm)]
[str (make-string (* 4 w h) #\000)])
[str (make-bytes (* 4 w h) 0)])
(send dc get-argb-pixels 0 0 w h str)
(send dc set-bitmap #f)
str))])
@ -181,17 +181,17 @@
(get-one (send main-bm get-loaded-mask)))
(get-one main-bm))))
(test '("\377\377\377\377" "\377\377\377\377") argb->bitmap->string (make-argb #(255 255 255 255) 1))
(test '("\377\377\377\377" "\377\0\0\0") argb->bitmap->string (make-argb #(255 0 0 0) 1))
(test '("\377\1\1\1" "\377\100\100\100") argb->bitmap->string (make-argb #(1 64 64 64) 1))
(test '("\377\001\001\001\377\010\010\010\377\377\377\377\377\000\000\000"
"\377\100\100\100\377\001\010\100\377\377\377\377\377\000\000\000")
(test '(#"\377\377\377\377" #"\377\377\377\377") argb->bitmap->string (make-argb #(255 255 255 255) 1 1))
(test '(#"\377\377\377\377" #"\377\0\0\0") argb->bitmap->string (make-argb #(255 0 0 0) 1 1))
(test '(#"\377\1\1\1" #"\377\100\100\100") argb->bitmap->string (make-argb #(1 64 64 64) 1 1))
(test '(#"\377\001\001\001\377\010\010\010\377\377\377\377\377\000\000\000"
#"\377\100\100\100\377\001\010\100\377\377\377\377\377\000\000\000")
argb->bitmap->string
(make-argb #(1 64 64 64
8 1 8 64
255 255 255 255
0 0 0 0)
2))
2 2))
(define (show-bitmap bm mask title)
(define f (new frame% (label title) (width 200) (height 200)))
@ -212,7 +212,7 @@
[w 100]
[h 30]
[argb-vector (make-vector (* w h 4) 0)]
[argb (make-argb argb-vector w)]
[argb (make-argb argb-vector w h)]
[c1 (build-bitmap
(lambda (dc)
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
@ -280,8 +280,8 @@
(show-bitmap new-bitmap #f "difference"))
(let* ([argb-bitmap (flatten-bitmap (argb->bitmap argb))]
[argb-ents (map char->integer (string->list (cadr (bitmap->string argb-bitmap))))]
[bitmap-ents (map char->integer (string->list (cadr (bitmap->string final))))])
[argb-ents (bytes->list (cadr (bitmap->string argb-bitmap)))]
[bitmap-ents (bytes->list (cadr (bitmap->string final)))])
(test #t (lambda (x) x) (andmap (lambda (x y) (<= (abs (- x y)) 3))
argb-ents
bitmap-ents))))

15
collects/wxme/xml.ss
View File

@ -20,13 +20,14 @@
(read-editor-snip text? vers stream elim-whitespace? xml-editor%)))
(define/override (generate-special editor src line col pos)
(let* ([port (send editor get-content-port)]
[xml (read-xml port)]
[xexpr (xml->xexpr (document-element xml))]
[clean-xexpr (if (send editor get-data)
(eliminate-whitespace-in-empty-tags xexpr)
xexpr)])
(list 'quasiquote clean-xexpr)))
(parameterize ([permissive-xexprs #t])
(let* ([port (send editor get-content-port)]
[xml (read-xml port)]
[xexpr (xml->xexpr (document-element xml))]
[clean-xexpr (if (send editor get-data)
(eliminate-whitespace-in-empty-tags xexpr)
xexpr)])
(list 'quasiquote clean-xexpr))))
(super-new))))