233 lines
9.2 KiB
Racket
233 lines
9.2 KiB
Racket
#lang racket/base
|
|
(require framework
|
|
slideshow/pict
|
|
racket/runtime-path
|
|
racket/gui/base
|
|
(for-syntax racket/base)
|
|
racket/class
|
|
racket/promise
|
|
"../pict.rkt"
|
|
"../reduction-semantics.rkt")
|
|
|
|
(provide btest done show-bitmap-test-gui?)
|
|
|
|
(define show-bitmap-test-gui? (make-parameter #t))
|
|
|
|
(define just-save-failures? (getenv "PLTJUSTSAVEFAILURES"))
|
|
|
|
(define tests 0)
|
|
(define failed-tests 0)
|
|
(define failed-panels '())
|
|
(define (done)
|
|
(if (zero? failed-tests)
|
|
(printf "bitmap-test.rkt: ~a tests, all passed\n" tests)
|
|
(eprintf "bitmap-test.rkt: ~a tests, ~a failed\n" tests failed-tests)))
|
|
|
|
(define-syntax (btest stx)
|
|
(syntax-case stx ()
|
|
[(_ test-exp bitmap-filename)
|
|
#`(test/proc
|
|
#,(syntax-line stx)
|
|
(λ () test-exp)
|
|
bitmap-filename)]))
|
|
|
|
(define-runtime-path bmps-dir (format "bmps-~a" (system-type)))
|
|
|
|
(define (test/proc line-number pict-thunk raw-bitmap-filename)
|
|
(set! tests (+ tests 1))
|
|
(let* ([pict (set-fonts/call pict-thunk)]
|
|
[bitmap-filename
|
|
(build-path bmps-dir
|
|
raw-bitmap-filename)]
|
|
[old-bitmap (if (file-exists? bitmap-filename)
|
|
(read-bitmap bitmap-filename)
|
|
(let* ([bm (make-bitmap 100 20)]
|
|
[bdc (make-object bitmap-dc% bm)])
|
|
(send bdc clear)
|
|
(send bdc draw-text "does not exist" 0 0)
|
|
(send bdc set-bitmap #f)
|
|
bm))]
|
|
[new-bitmap ((if (eq? (system-type) 'unix)
|
|
make-bitmap
|
|
make-screen-bitmap)
|
|
(ceiling (inexact->exact (pict-width pict)))
|
|
(ceiling (inexact->exact (pict-height pict))))]
|
|
[bdc (make-object bitmap-dc% new-bitmap)])
|
|
(send bdc clear)
|
|
(draw-pict pict bdc 0 0)
|
|
(send bdc set-bitmap #f)
|
|
(unless (bitmaps-same? old-bitmap new-bitmap)
|
|
(set! failed-tests (+ failed-tests 1))
|
|
(cond
|
|
[just-save-failures?
|
|
(eprintf "saving ~a\n" bitmap-filename)
|
|
(void (send new-bitmap save-file bitmap-filename 'png))]
|
|
[else
|
|
(when (show-bitmap-test-gui?)
|
|
(let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap)])
|
|
(set! failed-panels (append failed-panels (list failed-panel)))))]))))
|
|
|
|
(define (set-fonts/call thunk)
|
|
(case (system-type)
|
|
[(unix)
|
|
(let ([rewrite-style
|
|
(λ (s)
|
|
(let loop ([s s])
|
|
(cond
|
|
[(pair? s) (cons (loop (car s)) (loop (cdr s)))]
|
|
[(eq? s 'roman) (verify-face "DejaVu Serif")]
|
|
[(eq? s 'swiss) (verify-face "DejaVu Sans")]
|
|
[else s])))])
|
|
(parameterize ([label-style (rewrite-style (label-style))]
|
|
[literal-style (rewrite-style (literal-style))]
|
|
[metafunction-style (rewrite-style (metafunction-style))]
|
|
[non-terminal-style (rewrite-style (non-terminal-style))]
|
|
[non-terminal-subscript-style (rewrite-style (non-terminal-subscript-style))]
|
|
[non-terminal-superscript-style (rewrite-style (non-terminal-superscript-style))]
|
|
[default-style (rewrite-style (default-style))])
|
|
(thunk)))]
|
|
[else
|
|
(thunk)]))
|
|
|
|
(define (verify-face face)
|
|
(unless (member face (get-face-list))
|
|
(error 'verify-face "unknown face: ~s" face))
|
|
face)
|
|
|
|
(define (bitmaps-same? old-bitmap new-bitmap)
|
|
(let ([w (send old-bitmap get-width)]
|
|
[h (send old-bitmap get-height)])
|
|
(and (= w (send new-bitmap get-width))
|
|
(= h (send new-bitmap get-height))
|
|
(let ([bytes1 (make-bytes (* w h 4))]
|
|
[bytes2 (make-bytes (* w h 4))])
|
|
(send old-bitmap get-argb-pixels 0 0 w h bytes1)
|
|
(send new-bitmap get-argb-pixels 0 0 w h bytes2)
|
|
(equal? bytes1 bytes2)))))
|
|
|
|
(define (compute-diffs old-bitmap new-bitmap)
|
|
(let* ([w (max (send old-bitmap get-width)
|
|
(send new-bitmap get-width))]
|
|
[h (max (send old-bitmap get-height)
|
|
(send new-bitmap get-height))]
|
|
[diff-bitmap (make-bitmap w h)] ;; this bitmap holds the diff only, that we compute via set-pixel, not drawing
|
|
[new (make-object bitmap-dc% new-bitmap)]
|
|
[old (make-object bitmap-dc% old-bitmap)]
|
|
[diff (make-object bitmap-dc% diff-bitmap)]
|
|
[new-c (make-object color%)]
|
|
[old-c (make-object color%)])
|
|
(let loop ([x 0])
|
|
(unless (= x w)
|
|
(let loop ([y 0])
|
|
(unless (= y h)
|
|
(cond
|
|
[(and (< x (send new-bitmap get-width))
|
|
(< y (send new-bitmap get-height))
|
|
(< x (send old-bitmap get-width))
|
|
(< y (send old-bitmap get-height)))
|
|
(send new get-pixel x y new-c)
|
|
(send old get-pixel x y old-c)
|
|
(cond
|
|
[(and (= (send new-c red) (send old-c red))
|
|
(= (send new-c green) (send old-c green))
|
|
(= (send new-c blue) (send old-c blue)))
|
|
(send diff set-pixel x y new-c)]
|
|
[else
|
|
(send new-c set 255 0 0)
|
|
(send diff set-pixel x y new-c)])]
|
|
[else
|
|
(send new-c set 255 0 0)
|
|
(send diff set-pixel x y new-c)])
|
|
(loop (+ y 1))))
|
|
(loop (+ x 1))))
|
|
(send diff set-bitmap #f)
|
|
(send old set-bitmap #f)
|
|
(send new set-bitmap #f)
|
|
diff-bitmap))
|
|
|
|
(define test-result-single-panel #f)
|
|
(define (get-test-result-single-panel)
|
|
(cond
|
|
[test-result-single-panel
|
|
test-result-single-panel]
|
|
[else
|
|
(let ()
|
|
(define f (new frame% [label "bitmap-test.rkt failures"]))
|
|
(define lined (new vertical-panel% [parent f] [style '(border)]))
|
|
(define sp (new panel:single% [parent lined]))
|
|
(define current-index 0)
|
|
(define hp (new horizontal-panel% [parent f] [alignment '(center center)]))
|
|
(define prev
|
|
(new button%
|
|
[label "Prev"]
|
|
[parent hp]
|
|
[callback
|
|
(λ (x y)
|
|
(set! current-index (modulo (- current-index 1) (length failed-panels)))
|
|
(update-gui))]))
|
|
(define next (new button%
|
|
[label "Next"]
|
|
[parent hp]
|
|
[callback
|
|
(λ (x y)
|
|
(set! current-index (modulo (+ current-index 1) (length failed-panels)))
|
|
(update-gui))]))
|
|
(define (update-gui)
|
|
(send sp active-child (list-ref failed-panels current-index)))
|
|
(set! test-result-single-panel sp)
|
|
(send f show #t)
|
|
sp)]))
|
|
|
|
(define (make-failed-panel line-number filename old-bitmap new-bitmap)
|
|
(define diff-bitmap 'unk)
|
|
(define f (new vertical-panel% [parent (get-test-result-single-panel)]))
|
|
(define msg (new message% [label (format "line ~a" line-number)] [parent f]))
|
|
(define hp (new horizontal-panel% [parent f]))
|
|
(define vp1 (new vertical-panel% [parent hp]))
|
|
(define vp2 (new vertical-panel% [parent hp]))
|
|
(define computing-label "Computing diff ...")
|
|
(define computing-msg (new message% [label computing-label] [parent f]))
|
|
(define chk (new check-box%
|
|
[label "Show diff"]
|
|
[parent f]
|
|
[callback
|
|
(λ (_1 _2)
|
|
(define (update-check)
|
|
(cond
|
|
[(send chk get-value)
|
|
(send right-hand set-label (force diff-bitmap))]
|
|
[else
|
|
(send right-hand set-label new-bitmap)]))
|
|
(cond
|
|
[(eq? diff-bitmap 'unk)
|
|
(send chk enable #f)
|
|
(send computing-msg set-label computing-label)
|
|
(thread
|
|
(λ ()
|
|
(set! diff-bitmap (compute-diffs old-bitmap new-bitmap))
|
|
(queue-callback
|
|
(λ ()
|
|
(send computing-msg set-label "")
|
|
(send chk enable #t)
|
|
(update-check)))))]
|
|
[else
|
|
(update-check)]))]))
|
|
(send computing-msg set-label "")
|
|
(define btn (new button%
|
|
[parent f]
|
|
[label "Save"]
|
|
[callback
|
|
(λ (x y)
|
|
(send new-bitmap save-file filename 'png))]))
|
|
(define left-label (new message% [parent vp1] [label "Old"]))
|
|
(define left-hand (new message%
|
|
[parent vp1]
|
|
[label old-bitmap]))
|
|
(define right-label (new message% [parent vp2] [label "New"]))
|
|
(define right-hand (new message%
|
|
[parent vp2]
|
|
[label new-bitmap]))
|
|
(send left-hand set-label old-bitmap)
|
|
(send right-hand set-label new-bitmap)
|
|
f)
|