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

=>