Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

60 lines (48 sloc) 1.95 kB
#lang slideshow
(require slideshow/pict)
(define DELTA 40)
(define FT 12)
; (fsa "unlock" "lock" "push" "tick")
(define (fsa L C O unlock lock push tick)
(define (make-state txt)
(define t (text txt '() FT))
(define e (rounded-rectangle (+ 10 (pict-width t)) (+ 10 (pict-height t))))
(cc-superimpose t e))
(define locked (make-state L))
(define closed (make-state C))
(define open (make-state O))
(define bg (rectangle (+ (pict-width locked) (* 2 DELTA))
(+ (pict-height locked)
(pict-height closed)
(pict-height open)
(* 3 DELTA))))
(define width (pict-width bg))
(define (center base state y)
(define w (pict-width state))
(define d (quotient (round (- width w)) 2))
(pin-over base d y state))
(define nx
(center
(center
(center
bg locked (/ DELTA 2))
closed
(+ (/ DELTA 2) (pict-height locked) DELTA))
open
(+ (/ DELTA 2) DELTA (pict-height locked) DELTA (pict-height closed))))
(define (add-labeled-arrow nx locked lb-find closed lt-find txt)
(define-values (x0 y0) (lb-find nx locked))
(define-values (x1 y1) (lt-find nx closed))
(define lbl (text txt '() (- FT 2)))
(define wlbl (pict-width lbl))
(define hlbl (pict-height lbl))
(define x (- x0 (/ wlbl 2)))
(define y (+ y0 (/ ( - y1 y0 hlbl) 2)))
(pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl))
(define l1 (add-labeled-arrow nx locked lb-find closed lt-find unlock))
(define l2 (add-labeled-arrow l1 closed lb-find open lt-find push))
(define l3 (add-labeled-arrow l2 open rt-find closed rb-find tick))
(define l4 (add-labeled-arrow l3 closed rt-find locked rb-find lock))
l4)
(fsa "locked" "closed" "open" "unlock" "lock" "push" "time")
(fsa "'locked" "'closed" "'open" "#\\u" "#\\l" "#\\space" "tick")
Jump to Line
Something went wrong with that request. Please try again.