Skip to content

Instantly share code, notes, and snippets.

@alex-hhh
Created March 20, 2018 06:13
Show Gist options
  • Save alex-hhh/67a67d791ee6c73d3c13e50981cf43cf to your computer and use it in GitHub Desktop.
Save alex-hhh/67a67d791ee6c73d3c13e50981cf43cf to your computer and use it in GitHub Desktop.
Interactive overlays with the Racket Plot Package
#lang racket
(require racket/gui mrlib/snip-canvas plot pict racket/draw)
(define (pie-slice w h angle)
(define nangle (let ((npi (floor (/ angle (* 2 pi)))))
(- angle (* 2 pi npi))))
(define (draw dc dx dy) (send dc draw-arc dx dy w h (- (/ nangle 2)) (/ nangle 2)))
(dc draw w h))
(define item-font (send the-font-list find-or-create-font 12 'default 'normal 'normal))
(define background (make-object color% #xff #xf8 #xdc 0.8))
(define (make-tag x y)
(define p (hc-append
(text "sin(" item-font)
(colorize (pie-slice 15 15 x) "black")
(text ") = " item-font)
(text (~r y #:precision '(= 2)) item-font)))
(define r (filled-rounded-rectangle
(+ (pict-width p) 10) (+ (pict-height p) 10) -0.2
#:draw-border? #f #:color background))
(cc-superimpose r p))
(define ((make-current-value-renderer fn) snip event x y)
(define overlays
(and x y (eq? (send event get-event-type) 'motion)
(let ((pict (make-tag x (fn x))))
(list
(vrule x #:style 'long-dash)
(point-pict (vector x y) pict #:anchor 'auto #:point-sym 'none)))))
(send snip set-overlay-renderers overlays))
(define (make-plot-snip width height)
(define snip (plot-snip (function sin)
#:x-min 0 #:x-max (* 2 pi)
#:y-min -1.5 #:y-max 1.5
#:width width #:height height))
(send snip set-mouse-event-callback (make-current-value-renderer sin))
snip)
(define toplevel (new frame% [label "Plot"] [width 500] [height 200] [border 5]))
(define canvas (new snip-canvas% [parent toplevel] [make-snip make-plot-snip]))
(send toplevel show #t)
#lang racket
(require racket/gui mrlib/snip-canvas plot)
(define ((make-current-value-renderer fn) snip event x y)
(define overlays
(and x y (eq? (send event get-event-type) 'motion)
(list
(vrule x #:style 'long-dash)
(point-label (vector x (fn x)) #:anchor 'auto))))
(send snip set-overlay-renderers overlays))
(define (make-plot-snip width height)
(define snip (plot-snip (function sin)
#:x-min 0 #:x-max (* 2 pi)
#:y-min -1.5 #:y-max 1.5
#:width width #:height height))
(send snip set-mouse-event-callback (make-current-value-renderer sin))
snip)
(define toplevel (new frame% [label "Plot"] [width 500] [height 200] [border 5]))
(define canvas (new snip-canvas% [parent toplevel] [make-snip make-plot-snip]))
(send toplevel show #t)
#lang racket
(require racket/gui mrlib/snip-canvas plot)
(define drag-start #f)
(define (drag-selection-callback snip event x y)
(case (send event get-event-type)
((left-down) (set! drag-start x))
((left-up) (set! drag-start #f))
((motion)
(define overlays
(and x drag-start
(list
(rectangles (list (vector (ivl drag-start x) (ivl -inf.0 +inf.0)))
#:color "blue"
#:alpha 0.2)
(point-label (vector (* 0.5 (+ drag-start x)) 0)
(~r (radians->degrees (abs (- x drag-start))) #:precision 1)
#:anchor 'center #:point-sym 'none)
)))
(send snip set-overlay-renderers overlays))))
(define (make-plot-snip width height)
(define snip (plot-snip (function sin)
#:x-min -5 #:x-max 5
#:y-min -1.5 #:y-max 1.5
#:width width #:height height))
(send snip set-mouse-event-callback drag-selection-callback)
snip)
(define toplevel (new frame% [label "Plot"] [width 500] [height 200] [border 5]))
(define canvas (new snip-canvas% [parent toplevel] [make-snip make-plot-snip]))
(send toplevel show #t)
#lang racket
(require racket/gui mrlib/snip-canvas plot)
(define series1 '(#(Eggs 1.5) #(Bacon 2.5) #(Pancakes 3.5)))
(define series2 '(#(Eggs 1.4) #(Bacon 2.3) #(Pancakes 3.1)))
(define (xposition->histogram-slot xposition
(skip (discrete-histogram-skip))
(gap (discrete-histogram-gap)))
(let* ((slot (exact-floor (/ xposition skip)))
(offset (- xposition (* skip slot)))
(series (exact-floor offset))
(on-bar? (< (/ gap 2) (- offset series) (- 1 (/ gap 2)))))
(if on-bar? (values series slot) (values #f #f))))
(define (fetch-value-at x)
(let-values (((series slot) (xposition->histogram-slot x 2.5)))
(and series slot (< series 2)
(let* ((s (if (eq? series 0) series1 series2))
(b (list-ref s slot)))
(vector-ref b 1)))))
(define (on-hover snip event x y)
(define ovelays
(and x y (eq? (send event get-event-type) 'motion)
(let ((value (fetch-value-at x)))
(and value (<= y value)
(list (point-label (vector x y)
(format "~a minutes" value)
#:anchor 'auto #:point-sym 'none))))))
(send snip set-overlay-renderers ovelays))
(define (make-plot-snip width height)
(define snip (plot-snip
(list
(discrete-histogram series1 #:skip 2.5 #:x-min 0)
(discrete-histogram series2 #:skip 2.5 #:x-min 1 #:color 2 #:line-color 2))
#:x-label "Breakfast Food" #:y-label "Cooking Time (minutes)"
#:y-max 4
#:width width #:height height))
(send snip set-mouse-event-callback on-hover)
snip)
(define toplevel (new frame% [label "Plot"] [width 500] [height 350] [border 5]))
(define canvas (new snip-canvas% [parent toplevel] [make-snip make-plot-snip]))
(send toplevel show #t)
#lang racket
(require racket/gui mrlib/snip-canvas plot)
(define ((make-tangent-renderer fn derivative) snip event x y)
(define overlays
(and x y (eq? (send event get-event-type) 'motion)
(let* ((slope (derivative x))
(intercept (- (fn x) (* slope x)))
(tangent (lambda (x) (+ (* slope x) intercept))))
(list (function tangent #:color "blue")
(points (list (vector x (fn x))))))))
(send snip set-overlay-renderers overlays))
(define (make-plot-snip width height)
(define snip (plot-snip (function sin)
#:x-min -5 #:x-max 5
#:y-min -1.5 #:y-max 1.5
#:width width #:height height))
(send snip set-mouse-event-callback (make-tangent-renderer sin cos))
snip)
(define toplevel (new frame% [label "Plot"] [width 500] [height 200] [border 5]))
(define canvas (new snip-canvas% [parent toplevel] [make-snip make-plot-snip]))
(send toplevel show #t)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment