Diagram

diagram.scrbl

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