PasteRack.org
Paste # 88406
2019-06-07 22:08:31

Fork as a new paste.

Paste viewed 135 times.


Embed:

Updated Chart Lag Test

  1. #lang racket
  2.  
  3. (require math/statistics
  4.          plot
  5.          racket/gui)
  6.  
  7. ;; Begin code from Alex H from ActivityLog2. GPL v3.0 Licensed
  8.  
  9. (define (draw-centered-message dc msg font)
  10.   (let-values (([cw ch] (send dc get-size))
  11.                ([w h x y] (send dc get-text-extent msg font #t)))
  12.     (send dc set-font font)
  13.     (send dc set-text-foreground "gray")
  14.     (let ((ox (- (/ cw 2) (/ w 2)))
  15.           (oy (- (/ ch 2) (/ h 2))))
  16.       (send dc draw-text msg ox oy))))
  17.  
  18. (define read-only-pb%
  19.   (class pasteboard%
  20.     (define writable? #t)
  21.     (define main-snip #f)
  22.     (define floating-snips '())
  23.     ;; Message to be shown when there is no main snip in the canvas.
  24.     (define no-main-snip-message #f)
  25.     (define message-font
  26.       (send the-font-list find-or-create-font 36 'default 'normal 'normal))
  27.  
  28.     (define/public (set-writable w?) (set! writable? w?))
  29.  
  30.     ;; (define/augment (can-change-style? start len) writable?)
  31.     (define/augment (can-delete? snip) writable?)
  32.     (define/augment (can-insert? snip before x y) writable?)
  33.     (define/augment (can-load-file? filename format) writable?)
  34.     (define/augment (can-save-file? filename format) writable?)
  35.     (define/augment (can-move-to? snip x y dragging?)
  36.       (or (not dragging?) (not (eq? snip main-snip))))
  37.     (define/override (can-do-edit-operation? op [recursive? #t])
  38.       (case op
  39.         [(copy select-all)  #t]
  40.         [else    writable?]))
  41.  
  42.     (define/augment (on-insert snip before x y)
  43.       (unless (send this find-first-snip)
  44.         (set! main-snip snip)))
  45.  
  46.     (define/augment (after-insert snip before x y)
  47.       (when (eq? main-snip snip)
  48.         (send this move-to snip 0 0))
  49.       (when (and main-snip (not (eq? snip main-snip)))
  50.         (send this set-before snip main-snip)))
  51.  
  52.     (define/public (set-background-message msg)
  53.       (set! no-main-snip-message msg))
  54.  
  55.     (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
  56.       (when before?
  57.         ;; Draw a message when there is no snip in the pasteboard.
  58.         (unless (send this find-first-snip)
  59.           (send dc clear)
  60.           (when no-main-snip-message
  61.             (draw-centered-message dc no-main-snip-message message-font)))))
  62.  
  63.     (super-new)
  64.     ;;(send this hide-caret #t)
  65.     (send this set-selection-visible #f)
  66.     ))
  67.  
  68. (define settable-snip-canvas%
  69.   (class editor-canvas%
  70.     (init parent
  71.           [style null]
  72.           [label #f]
  73.           [horizontal-inset 5]
  74.           [vertical-inset 5]
  75.           [enabled #t]
  76.           [vert-margin 0]
  77.           [horiz-margin 0]
  78.           [min-width 0]
  79.           [min-height 0]
  80.           [stretchable-width #t]
  81.           [stretchable-height #t])
  82.  
  83.     (define snip #f)
  84.     (define pb (new read-only-pb%))
  85.     (send pb set-writable #f)
  86.  
  87.     (define/public (get-snip) snip)
  88.  
  89.     (define/override (on-size w h)
  90.       (update-snip w h)
  91.       (super on-size w h))
  92.  
  93.     (define/override (on-paint)
  94.       (define begin-timestamp (current-inexact-milliseconds))
  95.       (super on-paint)
  96.       (define end-timestamp (current-inexact-milliseconds))
  97.       (set! paint-event-stats (update-statistics paint-event-stats (- end-timestamp begin-timestamp))))
  98.  
  99.     (define (update-snip w h)
  100.       (define snip-w (max 0 (- w (* 2 horizontal-inset))))
  101.       (define snip-h (max 0 (- h (* 2 vertical-inset))))
  102.       (when snip
  103.         (send snip resize snip-w snip-h)
  104.         (send pb move-to snip 0 0)))
  105.  
  106.     (define/public (set-snip s)
  107.       (set! snip s)
  108.       (send this suspend-flush)
  109.       (send pb set-writable #t)
  110.       (send pb begin-edit-sequence #f)
  111.       (send pb erase)
  112.       (when snip
  113.         (let-values (([w h] (send (send this get-dc) get-size)))
  114.           (update-snip w h))
  115.         (send pb insert snip))
  116.       (send pb end-edit-sequence)
  117.       (send pb set-writable #f)
  118.       (send this resume-flush))
  119.  
  120.     (define/public (set-floating-snip s)
  121.       (send pb set-writable #t)
  122.       (send pb insert s)
  123.       (send pb set-writable #f))
  124.  
  125.     (define/public (export-image-to-file file-name (width #f) (height #f))
  126.       (let-values (((cw ch) (send this get-size)))
  127.         (unless (and width height)
  128.           (set! width (or width cw))
  129.           (set! height (or height ch)))
  130.         (let* ((bitmap (if (regexp-match #px".*\\.(?i:svg)" file-name)
  131.                            #f
  132.                            (make-bitmap width height #t)))
  133.                (dc (if bitmap
  134.                        (new bitmap-dc% [bitmap bitmap])
  135.                        (new svg-dc%
  136.                             [width width] [height height]
  137.                             [output file-name]
  138.                             [exists 'truncate/replace]))))
  139.           ;; NOTE: scaling works, but makes the entire plot blurry
  140.           (send dc scale (/ width cw) (/ height ch))
  141.           (unless bitmap
  142.             (send dc start-doc "export to file"))
  143.           ;; NOTE: print-to-dc handles start-page/end-page calls
  144.           (send (send this get-editor) print-to-dc dc 0)
  145.           (unless bitmap
  146.             (send dc end-doc))
  147.           (when bitmap
  148.             (send bitmap save-file file-name 'png)))))
  149.  
  150.     (super-new [parent parent]
  151.                [editor pb]
  152.                [horizontal-inset horizontal-inset]
  153.                [vertical-inset vertical-inset]
  154.                [label label]
  155.                [enabled enabled]
  156.                [style (list* 'no-hscroll 'no-vscroll style)]
  157.                [vert-margin vert-margin]
  158.                [horiz-margin horiz-margin]
  159.                [min-width min-width]
  160.                [min-height min-height]
  161.                [stretchable-width stretchable-width]
  162.                [stretchable-height stretchable-height])
  163.  
  164.     (define/public (set-background-message msg)
  165.       (send pb set-background-message msg)
  166.       (send this refresh))
  167.  
  168.     ;(send this lazy-refresh #t)
  169.     ))
  170.  
  171. ;; End code from Alex H from ActivityLog2
  172.  
  173. (define mouse-event-stats empty-statistics)
  174.  
  175. (define paint-event-stats empty-statistics)
  176.  
  177. (define ((make-current-value-renderer fn) snip event x y)
  178.   (define delta (- (current-milliseconds) (send event get-time-stamp)))
  179.   (set! mouse-event-stats (update-statistics mouse-event-stats delta))
  180.   (cond [(> 2 delta)
  181.          (define overlays
  182.            (and x y (eq? (send event get-event-type) 'motion)
  183.                 (list (vrule x #:style 'long-dash)
  184.                       (point-label (vector x (fn x)) #:anchor 'auto))))
  185.          (send snip set-overlay-renderers overlays)]))
  186.  
  187. (define main-window (new frame% [label ""]
  188.                          [width 1000]
  189.                          [height 1000]))
  190.  
  191. (define plot-canvas (new settable-snip-canvas%
  192.                          [parent main-window]))
  193.  
  194. (define snip (plot-snip (function sin) #:x-min 0 #:x-max (* 2 pi) #:y-min -1.5 #:y-max 1.5))
  195.  
  196. (send snip set-mouse-event-callback (make-current-value-renderer sin))
  197.  
  198. (send plot-canvas set-snip snip)
  199.  
  200. (send main-window show #t)
  201.  
  202. (thread (λ ()
  203.           (sleep 10)
  204.           (printf "Mouse\nMin: ~a\nMax: ~a\nMean: ~a\nStdDev: ~a\n\n" (statistics-min mouse-event-stats) (statistics-max mouse-event-stats)
  205.                   (statistics-mean mouse-event-stats) (statistics-stddev mouse-event-stats))
  206.           (printf "Paint\nMin: ~a\nMax: ~a\nMean: ~a\nStdDev: ~a\n\n" (statistics-min paint-event-stats) (statistics-max paint-event-stats)
  207.                   (statistics-mean paint-event-stats) (statistics-stddev paint-event-stats))))

=>