Skip to content

Instantly share code, notes, and snippets.

@LiberalArtist
Last active November 6, 2022 02:31
Show Gist options
  • Save LiberalArtist/130452b8086c8007c08d6a0ee552c4f2 to your computer and use it in GitHub Desktop.
Save LiberalArtist/130452b8086c8007c08d6a0ee552c4f2 to your computer and use it in GitHub Desktop.
Racket release branch diagram
*~
\#*
.\#*
.DS_Store
compiled/
/doc/
Display the source blob
Display the rendered blob
Raw
#!/usr/bin/env -S slideshow --export
#lang slideshow/widescreen
;; SPDX-License-Identifier: (Apache-2.0 OR MIT)
(require pict
pict/conditional
pict/balloon
slideshow/text
slideshow/step)
(define-syntax-rule (define-labels id ...)
(define-values [id ...]
(let ([mk (λ (sym)
(pict-case sym #:combine rbl-superimpose
[(id) (tt (symbol->string 'id))] ...))])
(big (values (mk 'id) ...)))))
(define-labels master release stable)
(define commit-width
(* 8/10 (pict-width master)))
(define commit-height
(* 3/2 (pict-height master)))
(define master-color
"Pale Turquoise")
(define stable-color
"Yellow")
(define merge-color
"Light Green")
(define tag-color
"Fuchsia")
(define line-thickness
(* 1/5 (current-font-size)))
(define (midline* [width (* 1/4 commit-width)])
(filled-rectangle width line-thickness))
(define midline
(midline*))
(define (commit [label ""] #:dense? [dense? #f] #:color [color master-color])
(cc-superimpose (filled-rounded-rectangle
commit-width commit-height
#:border-width line-thickness
#:draw-border? #t
#:color color)
(if dense?
(small (t label))
(t label))))
(define before-merge-8.7
(commit "8.7.0.3"))
(define v8.7
(commit "8.7" #:color stable-color))
(define before-branch
(commit "8.7.0.12"))
(define alpha
(commit "8.7.0.900" #:color stable-color))
(define post-branch
(commit "8.8.0.1"))
(define v8.8
(commit "8.8" #:color stable-color))
(define merge-8.7
(commit "merge 8.7" #:color merge-color))
(define cherry-pick
(commit "cherry pick" #:dense? #t #:color merge-color))
(define dev1 (commit))
(define dev2 (commit))
(define merge-8.8
(commit "merge 8.8" #:color merge-color))
(define (tag label)
(wrap-balloon (tt label) 'n 0 (- (pict-width midline)) tag-color))
(define (map-balloon f b)
(make-balloon (f (balloon-pict b)) (balloon-point-x b) (balloon-point-y b)))
(define tag8.7 (tag "v8.7"))
(define tag8.8 (tag "v8.8"))
(define all-steps
(with-steps
[Start Branch ContinueMaster CherryPick FinalCommit ToStable Tag DeleteRelease Merge]
(define-syntax-rule (from? id)
(not (before? id)))
(define-syntax-rule (vfrom id)
(if (from? id) identity ghost))
(define-syntax-rule (step-case #:combine combine [id rhs0 rhs* ...] ...)
(pict-cond
#:combine combine
[(only? id) rhs0 rhs* ...] ...
[#t (if (or (only? id) ...)
(blank)
(error 'step-case "not exhaustive"))]))
(define title
(step-case
#:combine cbl-superimpose
[Start (titlet "Before Release Process")]
[Branch (hbl-append (titlet "Create ") (tt "release") (titlet " Branch"))]
[ContinueMaster (hbl-append (titlet "Continue Development on ") (tt "master"))]
[CherryPick (titlet "Fix Bugs")]
[FinalCommit (titlet "Commit New Version")]
[ToStable (hbl-append (titlet "Fast-forward ") (tt "stable"))]
[Tag (hbl-append (titlet "Tag via ") (tt "finalize-catalog.sh"))]
[DeleteRelease (hbl-append (titlet "Delete ") (tt "release") (titlet " Branch"))]
[Merge (hbl-append
(titlet "Merge ") (tt "stable") (titlet " into ") (tt "master")
(titlet " (using ") (tt "-s ours") (titlet ")"))]))
(define (fade p)
(cellophane p 0.25))
(define master-commits
(hc-append midline
before-merge-8.7
midline
merge-8.7
midline
before-branch
((vfrom Branch)
(hc-append midline
post-branch
((vfrom ContinueMaster)
(hc-append midline dev1 midline dev2
((vfrom Merge)
(hc-append midline merge-8.8))))))))
(define combined-commits
((vfrom CherryPick)
(hc-append cherry-pick ((vfrom FinalCommit)
(hc-append midline v8.8)))))
(define faded-combined-commits
(launder (fade combined-commits)))
(define release-commits
(hc-append (ghost midline)
(ghost (commit))
(ghost midline)
(ghost (commit))
(ghost midline)
(ghost (commit))
(ghost midline)
((vafter Branch) alpha)
((cond
[(between-excl? CherryPick ToStable)
identity]
[(between-excl? ToStable DeleteRelease)
fade]
[else
ghost])
midline)
(if (between-excl? CherryPick ToStable)
combined-commits
((vbetween-excl ToStable DeleteRelease)
faded-combined-commits))
(ghost midline)
(ghost (commit))))
(define skipped-commit-width
(+ (* 3 commit-width)
(* 4 (pict-width midline))))
(define stable-commits
(hc-append midline
v8.7
(ghost (midline* skipped-commit-width))
(if (from? ToStable)
combined-commits
(ghost faded-combined-commits))
(ghost midline)
(ghost (commit))))
(define background-line
(hline (pict-width master-commits) 1))
(define branches
(apply (curry vl-append commit-height)
(map (curry apply hc-append (pict-width midline))
`([,master ,(cc-superimpose background-line master-commits)]
[,((vbetween-excl Branch DeleteRelease)
release)
,(cc-superimpose (lc-superimpose
((vbetween-excl Branch ToStable)
background-line)
((vbetween-excl ToStable DeleteRelease)
(hline skipped-commit-width
(pict-height background-line))))
release-commits)]
[,stable ,(cc-superimpose background-line stable-commits)]))))
(define (ancestor-line branches from to #:from-above? from-above?)
(pin-line #:line-width (pict-height midline)
branches
from
rc-find
to
(λ (parent child)
(define inset 6)
(define-values [find +/-]
(if from-above?
(values lt-find +)
(values lb-find -)))
(define-values [x y]
(find parent child))
(values (+ x inset) (+/- y inset)))))
(let* ([branches (pin-balloon tag8.7 branches v8.7 cb-find)]
[branches (if (before? Tag)
branches
(pin-balloon tag8.8 branches v8.8 cb-find))]
[branches (ancestor-line branches
v8.7
merge-8.7
#:from-above? #f)]
[branches (if (before? Branch)
branches
(ancestor-line branches
before-branch
alpha
#:from-above? #t))]
[branches (if (before? ToStable)
branches
(ancestor-line branches
alpha
cherry-pick
#:from-above? #t))]
[branches (if (before? Merge)
branches
(ancestor-line branches
v8.8
merge-8.8
#:from-above? #f))]
[branches (if (before? CherryPick)
branches
(pin-arrow-line (pict-width midline)
#:line-width (pict-height midline)
#:style 'dot
branches
dev1
cb-find
cherry-pick
ct-find))]
[row-height (* 1/3 (pict-height branches))]
[branches (panorama branches)])
(vc-append
row-height
title
(scale-to-fit branches titleless-page)))))
(for-each slide all-steps)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment