60 lines
1.9 KiB
Scheme
60 lines
1.9 KiB
Scheme
#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")
|