I have some plot code for dice statistics (unfinished). It seems from some observations that using unicode characters in the y-axis ticks makes the plot nearly unresponsive. Conversely, using ASCII-only characters has no issue.
If anyone can shed some light on why or how to improve things I would greatly appreciate it.
Here's some sample code. Change the characters in face->string to ASCII characters (e.g., *, s, o, b, d) to see a more performant version.
dice.rkt
#lang racket
(require syntax/parse/define
(for-syntax syntax/parse)
racket/hash
"distributions.rkt")
(begin-for-syntax
(define-syntax-class pip
[pattern n:number
#:with v #'n
#:with key #''accuracy]
[pattern {~datum ☼}
#:with v #'1
#:with key #''damage]
[pattern {~datum ↯}
#:with v #'1
#:with key #''surge]
[pattern {~datum ∅}
#:with v #'1
#:with key #''evade]
[pattern {~datum ▲}
#:with v #'1
#:with key #''block]
[pattern {~datum ※}
#:with v #'1
#:with key #''dodge]))
;; face: hash[attr -> count]
(define-syntax-parse-rule (face p:pip ...)
(for/fold ([f (hash)])
([k (list p.key ...)]
[v (list p.v ...)])
(hash-update f k (curry + v) 0)))
;; die: cons[label, list[face]]
(define-syntax-parse-rule (die label:string [pip:expr ...] ...)
(cons label (list (face pip ...) ...)))
(define (combine-faces f0 . fs)
(apply hash-union #:combine + f0 fs))
(define (face->string f)
(define (r k) (hash-ref f k 0))
(define repeat make-string)
(~a (r 'accuracy)
(repeat (r 'damage) #\☼)
(repeat (r 'surge) #\↯)
(repeat (r 'evade) #\∅)
(repeat (r 'block) #\▲)
(repeat (r 'dodge) #\※)))
(define red (die "red" [☼] [☼ ☼] [☼ ☼] [☼ ☼ ↯] [☼ ☼ ☼] [☼ ☼ ☼]))
(define blue (die "blue" [↯ 2] [☼ 2] [☼ ☼ 3] [☼ ↯ 3] [☼ ☼ 4] [☼ 5]))
(define green (die "green" [↯ 1] [☼ ↯ 1] [☼ ☼ 1] [☼ ↯ 2] [☼ ☼ 2] [☼ ☼ 3]))
(define yellow (die "yellow" [↯] [↯ ↯ ☼] [☼ ☼ 1] [☼ ↯ 1] [↯ 2] [☼ 2]))
;;
(define black (die "black" [▲] [▲] [▲ ▲] [▲ ▲] [▲ ▲ ▲] [∅]))
(define white (die "white" [] [▲] [∅] [▲ ∅] [▲ ∅] [※]))
;; red blue green yellow black white (exit)
;; TODO: make bag just the "c" value below (counter), and make `bag-xs` produce the equivalent of the xs value
;; bag like an unordered list
;; two bags equal if they have the same number of equivalent objects
(struct bag [xs c]
#:methods gen:equal+hash
[(define (equal-proc b1 b2 rec)
(rec (bag-c b1) (bag-c b2)))
(define (hash-proc b rec)
(rec (bag-c b)))
(define (hash2-proc b rec)
(hash-proc b rec))])
(define (make-bag xs)
(bag xs (counter xs)))
(define (merge-bag b1 b2)
(bag (append (bag-xs b1) (bag-xs b2))
(hash-union #:combine + (bag-c b1) (bag-c b2))))
(define (counter xs)
(for/fold ([c (hash)])
([x xs])
(hash-update c x add1 0)))
(module+ test
(require rackunit)
(check-equal? (make-bag (list 1 2 3 1)) (make-bag (list 3 1 1 2))))
;; roll: Dicrete-Dist[result]
;; result: hash[label -> bag[rerolled?[face]]]
;; rerolled?[X]: (cons boolean X)
;; total: face
;; outcome: Any (mapped out of face, typically by spending surges/evades/blocks/etc.?)
;; roll -> Discrete-Dist[face]
(define (total-roll r)
(dist-flatmap
r
(λ (r)
(list (apply combine-faces (map cdr (append-map bag-xs (hash-values r))))))))
(define (roll d0 . ds)
(foldl then-roll (roll1 d0) ds))
(define (then-roll d dist)
(define outcomes (discrete-dist-values (roll1 d)))
(dist-flatmap dist (λ (x) (map (curry merge-outcome x) outcomes))))
(define (merge-outcome x y)
(hash-union x y #:combine merge-bag))
(define (roll1 d)
(match-define (cons label faces) d)
(discrete-dist
(map (λ (face) (hash label (make-bag (list (cons #f face))))) faces)))
;; roll -> roll
(define (focus r)
(then-roll green r))
;;;
(require plot)
(define (p d xs . rs)
(parameterize ([plot-new-window? #t])
(plot (cons (discrete-histogram
(map vector xs (discrete-dist-probs d))
#:x-min 0 #:label "P[x]" #:invert? #t)
rs))))
(define the-roll (time (focus (roll blue green))))
(let* ([xs (discrete-dist-values the-roll)]
[labels
(for/list ([r xs])
(string-join
(for/list ([(label b) r])
(format "[~a: ~a]"
label
(string-join
(map (match-lambda
[(cons rerolled? f)
(format "~a~a"
(face->string f)
(if rerolled? "!" ""))])
(bag-xs b)))))))])
(p the-roll labels))
(define the-total-roll (time (total-roll the-roll)))
;; (define f (face 5 ☼ ☼ ☼ ↯))
(define f (face 7 ☼ ☼ ☼ ☼ ☼ ↯))
(define pd (pdf the-total-roll f))
(let ([xs (discrete-dist-values the-total-roll)])
(p the-total-roll (map face->string xs)
(point-label (vector pd (add1 (index-of xs f)))
(~a (/ (round (* 10000 pd)) 100) "%")
#:anchor 'right)))
distributions.rkt
#lang typed/racket
(provide (all-from-out math/distributions
math/statistics)
dist-flatmap)
(require math/distributions
math/statistics)
(define #:forall (A B)
(dist-flatmap [d : (Discrete-Dist A)]
[f : (A → (Listof B))]) : (Discrete-Dist B)
(define values (discrete-dist-values d))
(define ps (discrete-dist-probs d))
(define p-result
(hash->list
(for/fold ([r : (HashTable B Real) (hash)])
([v values]
[p ps])
(define new-vs (f v))
(define p* (/ p (length new-vs)))
(for/fold ([r r])
([v* new-vs])
(hash-update r v* (λ ([x : Real]) (+ p* x)) (thunk 0))))))
(discrete-dist (map (inst car B Real) p-result)
(map (inst cdr B Real) p-result)))
(module* example racket
(provide (all-defined-out))
(require (submod ".."))
(define d
(let ([d (discrete-dist '(a b c) '(2 5 3))])
(dist-flatmap d (match-lambda
['a (list 'a)]
['b (list 'a 'b)]
['c (list 'c 'd)])))))
(module* test racket
(require (submod ".." example)
math/distributions
rackunit)
(check-equal? (list->set (discrete-dist-values d)) (set 'a 'b 'c 'd))
(for ([x (discrete-dist-values d)])
(check-equal? (pdf d x)
(match x
['a 0.45]
['b 0.25]
['c 0.15]
['d 0.15]))))
(module* main racket
(require (submod "..")
(submod ".." example)
plot)
(plot-new-window? #t)
(define n 10000)
(define h (samples->hash (sample d n)))
(define xs (discrete-dist-values d))
(plot (list (discrete-histogram
(map vector xs (map (distribution-pdf d) xs))
#:x-min 0 #:skip 2 #:label "P[x]")
(discrete-histogram
(map vector xs (map (λ (x) (/ (hash-ref h x) n)) xs))
#:x-min 1 #:skip 2 #:line-style 'dot #:alpha 0.5 #:label "est. P[x]"))))
Can you explain what you mean by unresponsive? I tried your program on a Windows platform and it works fine: plots are displayed, resized and zoomed in quickly.
There is only a slight delay for the plots to show up when you run the program, I suspect this is because it takes some time to calculate the distributions before plotting them.
In this video, I run it once on my system with unicode characters and once with ASCII-only characters. The performance of the plot windows is notably better in the second run.
Your video doesn't allow me access. I can also report that I tested out your code and the windows respond just fine both with non-ASCII and ASCII characters.
Perhaps it could be something at the racket/gui layer specific to @benknoble 's machine about drawing those characters? Here's some code that just draws a bunch of a given character to try out.
#lang racket/gui
(define N 2000)
(define (do-drawing str)
(define (draw c dc)
(time
(for ([x (in-range N)])
(define-values (w h _1 _2) (send dc get-text-extent str))
(send dc draw-text str 0 0)
(send dc draw-text str w 0)
(send dc draw-text str 0 h))))
(define f (new frame% [label ""] [width 200] [height 200]))
(define c (new canvas% [parent f] [paint-callback draw]))
(define b (new button% [parent f] [label "refresh"] [callback (λ _ (send c refresh))]))
(send f show #t))
(do-drawing "☼↯∅▲※")
(do-drawing "*sobd")
Neither window feels responsive, but I don't notice any real differences between the two. The timings logged in the console support that (all but the very first one clustered around 500ms).
I only saw one timing printout on the terminal which was 1ms.
Assuming your timings were from my program (should be 2 in each run). The timings of 500ms I reported above were in response to robby; should have used quote-reply to be more clear for the mailing-list mode [I did this time and the system removed it from my post, so now I've edited it into a different format.]
I updated the test program from @robby to set the smoothing on the device context and to use the same font that the plot package is using. This should match closely what the plot package is doing with regard to drawing the labels. For me, even the updated example shows shows the same timings for both versions, but maybe there is something different on your machine?
Thanks for confirming this -- it seems to happen on a Mac only --I cannot reproduce the problem on Windows, and neither can Sam on Linux.
The problem also seems to be related to the contents of the strings used for labels/titles, but the plot package just passes those strings to racket/draw calls. Unfortunately, the program that Robby provided to draw the same strings onto a canvas does not seem to have performance issues, so I'm a puzzled as to what is going on.
@benknoble , can I ask you to try another version of the test program -- this one draws the strings onto a bitmap, so there is no GUI display. The plot package does not draw directly into a canvas frame, but draws to a bitmap first, then displays the bitmap onto a canvas; I'm trying to see if the performance problem is due to the difference between drawing to a canvas vs. drawing to a bitmap.
Thanks,
Alex.
#lang racket/gui
(require plot)
(define font
(if (plot-font-face)
(send the-font-list find-or-create-font
(plot-font-size)
(plot-font-family)
'normal
'normal)
(send the-font-list find-or-create-font
(plot-font-size)
(plot-font-face)
(plot-font-family)
'normal
'normal)))
(define (make-bm)
(make-bitmap (plot-width)
(plot-height)
#t
#:backing-scale (or (get-display-backing-scale) 1.0)))
(define N 2000)
(define (do-drawing/bm str)
(define (draw dc)
(send dc set-smoothing 'smoothed)
(send dc set-font font)
(time
(for ([x (in-range N)])
(define-values (w h _1 _2) (send dc get-text-extent str))
(send dc draw-text str 0 0)
(send dc draw-text str w 0)
(send dc draw-text str 0 h))))
(define bm (make-bitmap
(plot-width)
(plot-height)
#t ; alpha channel
#:backing-scale (or (get-display-backing-scale) 1.0)))
(define dc (make-object bitmap-dc% bm))
(draw dc))
(printf "Unicode chars timings:~%")
(do-drawing/bm "☼↯∅▲※")
(printf "ASCII chars timings:~%")
(do-drawing/bm "*sobd")
I found the culprit: combine-mode being #t in draw-text.
#lang racket
(require racket/draw)
(define N 500)
(define LEN 20)
(define DIM 50)
(define (make c)
(define target (make-bitmap DIM DIM))
(define dc (new bitmap-dc% [bitmap target]))
(for ([i N])
(send dc draw-text (make-string LEN c) 0 0 #t)))
(for ([i 5])
(println (list 'round i))
(time (make #\a))
(time (make #\☼)))
produces:
'(round 0)
cpu time: 49 real time: 66 gc time: 1
cpu time: 1374 real time: 1394 gc time: 20
'(round 1)
cpu time: 14 real time: 14 gc time: 0
cpu time: 1361 real time: 1364 gc time: 23
'(round 2)
cpu time: 14 real time: 14 gc time: 0
cpu time: 1311 real time: 1313 gc time: 5
'(round 3)
cpu time: 13 real time: 13 gc time: 0
cpu time: 1325 real time: 1327 gc time: 5
'(round 4)
cpu time: 14 real time: 14 gc time: 0
cpu time: 1314 real time: 1317 gc time: 5
EDITED: this might not be all culprits, however. In @benknoble's original program, it used to be that each refresh takes 3-4s. After switching combine-mode to #f, now it takes 1s, which is better. However, when ASCII character is used, it refreshes almost instantly.
EDITED 2: another culprit is combine-mode in get-text-extent, though there might be more?
Happy to try this if still needed, but it looks like Sorawee has already identified areas of interest. Unfortunately @mflatt argued in Discourse that changing combine-mode would be incorrect.
Can you point me to the message about changing combine mode? It sure seems like we can do better here at some layer, as the strings have only one character in them.
The slowness appears to stem from this binary search loop, which occurs when combine-mode is #t and when there is an unknown glyph for a font face. As I (or rather, Matthew and Sam) understand, it is for determining a fallback font.
The following program shows combinations of character and font face that cause the performance issues.
#lang racket
(require racket/draw)
(define LEN 1000)
(define DIM 50)
(define (make c font-face)
(define font
(cond
[font-face
(send the-font-list find-or-create-font
10
font-face
'default
'normal
'normal)]
[else
(send the-font-list find-or-create-font
10
'default
'normal
'normal)]))
(define target (make-bitmap DIM DIM))
(define dc (new bitmap-dc% [bitmap target]))
(send dc set-font font)
(send dc draw-text (make-string LEN c) 0 0 #t))
(for ([font-face '(#f "Arial" "Menlo")])
(printf "=== font face: ~a ===\n" font-face)
(for ([c "a☼↯∅▲※"])
(printf "char: ~a\n" c)
(time (make c font-face)))
(newline))
produces:
=== font face: #f ===
char: a
cpu time: 38 real time: 63 gc time: 0
char: ☼
cpu time: 995 real time: 1015 gc time: 3
char: ↯
cpu time: 962 real time: 962 gc time: 1
char: ∅
cpu time: 914 real time: 915 gc time: 4
char: ▲
cpu time: 937 real time: 938 gc time: 1
char: ※
cpu time: 0 real time: 0 gc time: 0
=== font face: Arial ===
char: a
cpu time: 2 real time: 3 gc time: 0
char: ☼
cpu time: 1 real time: 1 gc time: 0
char: ↯
cpu time: 942 real time: 942 gc time: 1
char: ∅
cpu time: 917 real time: 917 gc time: 0
char: ▲
cpu time: 1 real time: 1 gc time: 0
char: ※
cpu time: 982 real time: 983 gc time: 12
=== font face: Menlo ===
char: a
cpu time: 1 real time: 1 gc time: 0
char: ☼
cpu time: 0 real time: 0 gc time: 0
char: ↯
cpu time: 1 real time: 1 gc time: 0
char: ∅
cpu time: 0 real time: 0 gc time: 0
char: ▲
cpu time: 0 real time: 0 gc time: 0
char: ※
cpu time: 956 real time: 957 gc time: 1
Hi @sorawee , tanks for investigating this and finding the cause. I ran your program on Windows, and it looks like it has the same slowness for the Arial font, so the problem itself might not be MacOS related, just that the plot package uses a different default font on Windows.
Here are the results from running your program:
Welcome to DrRacket, version 8.7 [cs].
Language: racket, with debugging; memory limit: 128 MB.
=== font face: #f ===
char: a
cpu time: 0 real time: 4 gc time: 0
char: ☼
cpu time: 15 real time: 2 gc time: 0
char: ↯
cpu time: 0 real time: 10 gc time: 0
char: ∅
cpu time: 0 real time: 1 gc time: 0
char: ▲
cpu time: 0 real time: 7 gc time: 0
char: ※
cpu time: 0 real time: 3 gc time: 0
=== font face: Arial ===
char: a
cpu time: 15 real time: 1 gc time: 0
char: ☼
cpu time: 0 real time: 1 gc time: 0
char: ↯
cpu time: 687 real time: 1233 gc time: 0
char: ∅
cpu time: 296 real time: 1229 gc time: 0
char: ▲
cpu time: 0 real time: 26 gc time: 0
char: ※
cpu time: 328 real time: 1695 gc time: 0
=== font face: Menlo ===
char: a
cpu time: 0 real time: 3 gc time: 0
char: ☼
cpu time: 0 real time: 5 gc time: 0
char: ↯
cpu time: 0 real time: 1 gc time: 0
char: ∅
cpu time: 0 real time: 1 gc time: 0
char: ▲
cpu time: 0 real time: 3 gc time: 0
char: ※
cpu time: 0 real time: 1 gc time: 0
Is it doing this loop many times? Could there be a cache somewhere that has only a few dozen strings in it somehow that avoids the expensive calls in that loop, perhaps?
[I did this time and the system removed it from my post, so now I've edited it into a different format.]