From: Matt Birkholz Date: Sat, 25 Oct 2014 21:04:44 +0000 (-0700) Subject: gl-glxgears: Move per-frame notes to %trace2. X-Git-Tag: mit-scheme-pucked-9.2.12~393 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=769d13a2ea4f5cf6edbf9fc3058dfd12c18dd799;p=mit-scheme.git gl-glxgears: Move per-frame notes to %trace2. --- diff --git a/src/gl/gl-glxgears.scm b/src/gl/gl-glxgears.scm index 4d62c72b5..4dad46c1b 100644 --- a/src/gl/gl-glxgears.scm +++ b/src/gl/gl-glxgears.scm @@ -59,7 +59,7 @@ USA. (gtk-window-set-opacity window 1.0) (gtk-window-set-title window title) (set-gtk-window-delete-event-callback! - window (lambda (w) (%trace ";closed "w"\n") 0)) + window (lambda (w) (%trace "closed "w) 0)) (gtk-container-set-border-width window 5) (let ((widget (%make-glxgears-demo width height))) (gtk-container-add window widget) @@ -97,11 +97,11 @@ USA. (make-animation-thread widget)) (define-method fix-widget-new-geometry-callback ((widget )) - (%trace "; (fix-widget-new-geometry-callback )\n") + (%trace "fix-widget-new-geometry-callback ") (wake-animation-thread widget)) (define (unrealize-callback widget) - (%trace "; unrealize-callback "widget" "(gtk-widget-destroyed? widget)"\n") + (%trace "unrealize-callback "widget" "(gtk-widget-destroyed? widget)) ;; Is this necessary when the context is about to be (already?) destroyed? #;(let ((gears (glxgears-demo-gears widget))) (with-glx-widget widget @@ -112,33 +112,33 @@ USA. (halt-animation-thread widget)) (define (draw-callback widget area) - (%trace "; draw-callback "widget" "area"\n")) + (%trace "draw-callback "widget" "area)) (define (map-handler widget) - (%trace "; map-handler "widget"\n") + (%trace "map-handler "widget) (set-glxgears-demo-mapped?! widget #t) (wake-animation-thread widget) #f) (define (unmap-handler widget) - (%trace "; unmap-handler "widget"\n") + (%trace "unmap-handler "widget) (set-glxgears-demo-mapped?! widget #f) #f) (define (enter-notify-handler widget) - (%trace "; enter-notify-handler "widget"\n") + (%trace "enter-notify-handler "widget) #f) (define (leave-notify-handler widget) - (%trace "; leave-notify-handler "widget"\n") + (%trace "leave-notify-handler "widget) #f) (define (focus-change-handler widget in?) - (%trace "; focus-change-handler "widget" "in?"\n") + (%trace "focus-change-handler "widget" "in?) #f) (define (visibility-notify-handler widget how) - (%trace "; visibility-notify-handler "widget" "how"\n") + (%trace "visibility-notify-handler "widget" "how) (let ((old (glxgears-demo-visibility widget))) (set-glxgears-demo-visibility! widget how) (if (and (eq? old 'OBSCURED) (not (eq? how 'OBSCURED))) @@ -146,7 +146,7 @@ USA. #t) (define (key-press-handler widget key bits) - (%trace "; key-press-handler "widget" "key" "bits"\n") + (%trace "key-press-handler "widget" "key" "bits) ;;(declare (ignore bits)) (case key ((#\escape #\q #\Q) (gtk-widget-destroy (gtk-widget-parent widget))) @@ -184,11 +184,11 @@ USA. widget (+ incr (glxgears-demo-view-roty widget)))) (define (motion-handler widget modifiers x y) - (%trace ";motion-handler "widget" "modifiers" "x"x"y"\n") + (%trace2 "motion-handler "widget" "modifiers" "x"x"y) #f) (define (button-handler widget name button modifiers x y) - (%trace ";button-handler "widget" "name" "button" "modifiers" "x"x"y"\n") + (%trace "button-handler "widget" "name" "button" "modifiers" "x"x"y) #f) (define (make-animation-thread widget) @@ -199,6 +199,7 @@ USA. (call-with-current-continuation (lambda (halt) (set-glxgears-demo-animation-halt! widget halt) + (%trace "animation thread started") (let loop () ;; Sleep when not mapped?, not animate?, or obscured. @@ -209,17 +210,14 @@ USA. (not (glxgears-demo-animate? widget)) (eq? 'OBSCURED visibility)) (begin - (fresh-line) - (%trace ";glxgears: sleeping") - (if (eq? 'OBSCURED visibility) - (%trace " while obscured")) - (%trace "...\n") + (if (and %trace? (eq? 'OBSCURED visibility)) + (%trace "sleeping while obscured...") + (%trace "sleeping...")) (suspend-current-thread) - (fresh-line) - (%trace ";glxgears: ...awake!\n")))))) + (%trace "...awake!")))))) (if (not (glxgears-demo-mapped? widget)) - (%trace ";glxgears: not mapped\n") + (%trace "not mapped!") (begin ;; Init, if necessary. (if (not (glxgears-demo-gears widget)) @@ -244,7 +242,7 @@ USA. ((glxgears-demo-animation-halt widget) unspecific)))) (define (draw-frame widget) - (%trace "; draw-frame\n") + (%trace2 "draw-frame") (if (glxgears-demo-animate? widget) (let ((now (real-time-clock)) @@ -262,9 +260,9 @@ USA. (with-glx-widget widget (lambda () (draw widget) - (%trace "; swap-buffers\n") + (%trace2 "swap-buffers") (glx:swap-buffers widget) - (%trace "; flush\n") + (%trace2 "flush") (gl:flush))) (if (and (glxgears-demo-animate? widget) (glxgears-demo-report-fps? widget)) @@ -276,13 +274,13 @@ USA. (->flonum (internal-time/ticks->seconds (fix:- now start))))) (if (>= seconds 5.0) (let ((fps (/ (->flonum count) seconds))) - (define-integrable (%3.1f n) + (define-integrable (%.1f n) (number->string (/ (round (* 10. n)) 10.))) - (define-integrable (%6.3f n) + (define-integrable (%.3f n) (number->string (/ (round (* 1000. n)) 1000.))) (for-each display (list "; glxgears: "count" frames" - " in "(%3.1f seconds)" seconds" - " = "(%6.3f fps)" FPS\n")) + " in "(%.1f seconds)" seconds" + " = "(%.3f fps)" FPS\n")) (set-glxgears-demo-frame-count-start! widget now) (set-glxgears-demo-frame-count! widget 0)))) (begin @@ -290,7 +288,7 @@ USA. (set-glxgears-demo-frame-count! widget 0)))))) (define (draw widget) - (%trace "; draw "widget"\n") + (%trace2 " draw "widget) (let ((angle (glxgears-demo-angle widget)) (gears (glxgears-demo-gears widget)) (view-rotx (glxgears-demo-view-rotx widget)) @@ -301,7 +299,8 @@ USA. (draw-gears angle gear1 gear2 gear3 view-rotx view-roty)))) (define (draw-gears angle gear1 gear2 gear3 view-rotx view-roty) - (%trace "; draw-gears "angle" "gear1" "gear2" "gear3" "view-rotx" "view-roty"\n") + (%trace2 " draw-gears " + angle" "gear1" "gear2" "gear3" "view-rotx" "view-roty) (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER) (gl:push-matrix) (gl:rotate view-rotx 1. 0. 0.) @@ -336,7 +335,7 @@ USA. (if (not (and (fix:= (car w.h) width) (fix:= (cdr w.h) height))) (begin - (%trace ";glxgears: reshape "width" "height" "widget"\n") + (%trace "reshape "width" "height" "widget) (with-glx-widget widget (lambda () (gl:viewport 0 0 width height) @@ -353,7 +352,7 @@ USA. (set-glxgears-demo-shape! widget (cons width height))))))) (define (init widget) - (%trace "; glxgears: init "widget"\n") + (%trace "init "widget) (reshape widget) (with-glx-widget widget (lambda () @@ -361,7 +360,7 @@ USA. (red (color 0.8 0.1 0.0 1.0)) (green (color 0.0 0.8 0.2 1.0)) (blue (color 0.2 0.2 1.0 1.0))) - (%trace ";light\n") + (%trace "light") (gl:light 'LIGHT0 'POSITION pos) (gl:enable 'CULL-FACE) (gl:enable 'LIGHTING) @@ -370,21 +369,21 @@ USA. ;; make the gears (let ((gear1 (gl:gen-lists 1))) - (%trace ";gear1 => "gear1"\n") + (%trace "gear1 = "gear1) (gl:new-list gear1 'COMPILE) (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE red) (draw-gear 1.0 4.0 1.0 20. 0.7) (gl:end-list) (let ((gear2 (gl:gen-lists 1))) - (%trace ";gear2 => "gear2"\n") + (%trace "gear2 = "gear2) (gl:new-list gear2 'COMPILE) (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE green) (draw-gear 0.5 2.0 2.0 10. 0.7) (gl:end-list) (let ((gear3 (gl:gen-lists 1))) - (%trace ";gear3 => "gear3"\n") + (%trace "gear3 = "gear3) (gl:new-list gear3 'COMPILE) (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE blue) (draw-gear 1.3 2.0 0.5 10. 0.7) @@ -398,7 +397,7 @@ USA. width ; width of gear teeth ; number of teeth tooth-depth) ; depth of tooth - (%trace "; draw-gear "inner-radius" "outer-radius" "width" "teeth" "tooth-depth"\n") + (%trace "draw-gear "inner-radius" "outer-radius" "width" "teeth" "tooth-depth) (let ((r0 inner-radius) (r1 (- outer-radius (/ tooth-depth 2.))) (r2 (+ outer-radius (/ tooth-depth 2.))) @@ -534,9 +533,16 @@ USA. (define-integrable color flo:4d) -(define %trace? #f) +(define %trace? #t) (define-syntax %trace (syntax-rules () ((_ ARGS ...) - (if %trace? (display ARGS ...))))) \ No newline at end of file + (if %trace? (outf-error "; " ARGS ... "\n"))))) + +(define %trace2? #f) + +(define-syntax %trace2 + (syntax-rules () + ((_ ARGS ...) + (if %trace2? (outf-error "; " ARGS ... "\n"))))) \ No newline at end of file