135 lines
4.3 KiB
Racket
135 lines
4.3 KiB
Racket
#lang racket/base
|
|
|
|
(require (for-syntax racket/base)
|
|
racket/class
|
|
racket/draw
|
|
racket/match
|
|
pict
|
|
syntax/parse/define)
|
|
|
|
(define (s-frame color hatched? t)
|
|
(define p (inset (text t) 10))
|
|
(define-values [w h] (values (pict-width p) (pict-height p)))
|
|
(define fr
|
|
(dc (λ (dc dx dy)
|
|
(define old-brush (send dc get-brush))
|
|
(define old-pen (send dc get-pen))
|
|
(define color-bg (make-object color%
|
|
(send color red)
|
|
(send color green)
|
|
(send color blue)
|
|
0.5))
|
|
(send dc set-brush
|
|
(new brush% [style (if hatched? 'fdiagonal-hatch 'transparent)]
|
|
[color color-bg]))
|
|
(send dc set-pen
|
|
(new pen% [width 1] [color color]))
|
|
(define path (new dc-path%))
|
|
(send path move-to 0 0)
|
|
(send path line-to (- w 0.5) 0)
|
|
(send path line-to (- w 0.5) (- h 0.5))
|
|
(send path line-to 0 (- h 0.5))
|
|
(send path close)
|
|
(send dc draw-path path dx dy)
|
|
(send dc set-brush old-brush)
|
|
(send dc set-pen old-pen))
|
|
w h))
|
|
(cc-superimpose fr p))
|
|
|
|
(define (s-arrow label-text . blocks)
|
|
(match blocks
|
|
['() (blank 0 0)]
|
|
[(list pict-a) pict-a]
|
|
[(cons pict-a pict-bs)
|
|
(define pict-b (apply s-arrow label-text pict-bs))
|
|
(pin-arrow-line
|
|
10 (hc-append 100 pict-a pict-b)
|
|
pict-a rc-find
|
|
pict-b lc-find
|
|
#:line-width 1
|
|
#:style 'solid
|
|
#:color "black"
|
|
#:label (label-text))]))
|
|
|
|
(define (add-bottom-label p label-text [l-offset 0])
|
|
(define-values [w h] (values (- (pict-width p) l-offset) (pict-height p)))
|
|
(define bracket (hb-append (vline 0 5) (hline w 0) (vline 0 5)))
|
|
(define label (text label-text))
|
|
(vr-append p
|
|
(vc-append (inset bracket 0 10 0 0)
|
|
(cc-superimpose (blank w (pict-height label)) label))))
|
|
|
|
|
|
(define (backgroundify-diagram p-raw)
|
|
(define p (inset p-raw 20))
|
|
(cc-superimpose (filled-rectangle (pict-width p) (pict-height p)
|
|
#:draw-border? #f #:color "white")
|
|
p))
|
|
|
|
(define (save-to-svg p name)
|
|
(define svg (new svg-dc%
|
|
[width (pict-width p)]
|
|
[height (pict-height p)]
|
|
[output (format "~a.svg" name)]
|
|
[exists 'replace]))
|
|
(send svg start-doc "rendering SVG")
|
|
(send svg start-page)
|
|
(draw-pict p svg 0 0)
|
|
(send svg end-page)
|
|
(send svg end-doc))
|
|
|
|
(define-simple-macro (define-diagram name:id value:expr)
|
|
#:with name-string (datum->syntax #'name (symbol->string (syntax->datum #'name)))
|
|
(save-to-svg (backgroundify-diagram value) name-string))
|
|
|
|
|
|
(define c-reg (make-object color% 150 150 150))
|
|
(define c-pad (make-object color% 200 80 80))
|
|
(define c-len (make-object color% 200 80 80))
|
|
|
|
(define c-blue (make-object color% 150 150 200))
|
|
(define c-green (make-object color% 30 200 30))
|
|
|
|
(define-diagram sha-diagram
|
|
(add-bottom-label
|
|
(ht-append (s-frame c-reg #f "data")
|
|
(s-frame c-pad #t "padding")
|
|
(s-frame c-len #t "data len"))
|
|
"hashed data"))
|
|
|
|
(define-diagram sha-diagram-extended
|
|
(add-bottom-label
|
|
(ht-append
|
|
(add-bottom-label
|
|
(ht-append
|
|
(add-bottom-label
|
|
(ht-append (s-frame c-reg #f "data")
|
|
(s-frame c-pad #f "padding")
|
|
(s-frame c-len #f "data len"))
|
|
"originally hashed")
|
|
(s-frame c-reg #f "extend data"))
|
|
"append this"
|
|
(pict-width (s-frame c-reg #f "data")))
|
|
(s-frame c-pad #t "padding")
|
|
(s-frame c-len #t "total data len"))
|
|
"extended hash"))
|
|
|
|
|
|
(define-diagram sha-compression-diagram
|
|
(vc-append
|
|
(blank 1 60)
|
|
(s-arrow (λ ()
|
|
(define pict-a (s-frame c-reg #f "input block"))
|
|
(define pict-b (text "SHA-2 round"))
|
|
(pin-arrow-line
|
|
5 (vc-append 30 pict-a pict-b)
|
|
pict-a cb-find
|
|
pict-b ct-find
|
|
#:line-width 1
|
|
#:style 'solid
|
|
#:color "black"))
|
|
(s-frame c-blue #t "SHA-2 state constants")
|
|
(s-frame c-reg #t "state 1")
|
|
(s-frame c-reg #t "state 2")
|
|
(s-frame c-green #f "output hash"))))
|