writeups/2023/dcq/res/diagram.rkt

#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"))))