Skip to content

Instantly share code, notes, and snippets.

@bennn
Created Jul 16, 2019
Embed
What would you like to do?
Diagram
#lang scribble/manual
@(require pict ppict/2)
@(define (textit str)
(text str '(italic) 12))
@(define (node sym)
(define p (textit (symbol->string sym)))
(define p+ (cc-superimpose (blank (+ 10 (pict-width p)) (+ 4 (pict-height p))) p))
(tag-pict p+ sym))
@(struct arrow [src find-src tgt find-tgt label label-x label-y] #:transparent)
@(define (make-arrow src find-src tgt find-tgt label [label-x 0] [label-y 0])
(arrow src find-src tgt find-tgt label label-x label-y))
@(cc-superimpose
(rectangle 300 150)
(ppict-do
(blank 280 110)
#:go (coord 0 0)
(node 'A)
#:go (coord 1/2 0)
(node 'B)
#:go (coord 1/2 1)
(node 'C)
#:go (coord 1 1)
(node 'D)
#:set (let ([pp ppict-do-state])
(for/fold ([pp pp])
([a (list (make-arrow 'A rc-find 'B lc-find @textit{f})
(make-arrow 'A rb-find 'C lt-find @textit{g ∘ f} -45 -2)
(make-arrow 'B cb-find 'C ct-find @textit{g} 8 -7)
(make-arrow 'B rb-find 'D lt-find @textit{h ∘ g} 15 2)
(make-arrow 'C rc-find 'D lc-find @textit{h}))])
(pin-arrow-line
7 pp
(find-tag pp (arrow-src a)) (arrow-find-src a)
(find-tag pp (arrow-tgt a)) (arrow-find-tgt a)
#:label (arrow-label a)
#:x-adjust-label (arrow-label-x a)
#:y-adjust-label (arrow-label-y a))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment