98 lines
2.2 KiB
Racket
98 lines
2.2 KiB
Racket
#lang racket/base
|
|
(require slideshow/pict
|
|
racket/draw
|
|
racket/class
|
|
racket/math)
|
|
|
|
(provide module-hierarchy)
|
|
|
|
(define GAP 12)
|
|
|
|
(define file-color (make-object color% #xEC #xF5 #xF5))
|
|
|
|
(define folder
|
|
(let ()
|
|
(define W 200)
|
|
(define H 144)
|
|
(define dy (* -8/3 2))
|
|
(define p (make-object dc-path%))
|
|
(send p move-to 0 50)
|
|
(send p arc 0 (+ 22 dy) 8 8 pi (/ pi 2) #f)
|
|
(send p arc 2 (+ 18 dy) 4 4 (/ pi -2) 0 #t)
|
|
(send p arc 6 0 20 20 pi (/ pi 2) #f)
|
|
(send p line-to 60 0)
|
|
(send p arc 50 0 20 20 (/ pi 2) 0 #f)
|
|
(send p arc 70 (+ 22 dy) 2 2 pi (* 3/2 pi))
|
|
(send p arc 180 (+ 24 dy) 20 20 (/ pi 2) 0 #f)
|
|
(send p arc 180 120 20 20 0 (/ pi -2) #f)
|
|
(send p arc 0 120 20 20 (/ pi -2) (- pi) #f)
|
|
(send p close)
|
|
|
|
(scale
|
|
(dc (lambda (dc x y)
|
|
(define b (send dc get-brush))
|
|
(send dc set-brush file-color 'solid)
|
|
(send dc draw-path p x y)
|
|
(send dc set-brush b))
|
|
W H)
|
|
12/32)))
|
|
|
|
(define file
|
|
(file-icon (/ 75 2) 54 file-color))
|
|
|
|
(define (lbl i t)
|
|
(vc-append 4 i (text t '(bold . modern) 12)))
|
|
|
|
(define (listing p)
|
|
(frame (inset p GAP)
|
|
#:color "blue"))
|
|
|
|
(define db-folder (launder folder))
|
|
(define mach-folder (launder folder))
|
|
(define mach-listing
|
|
(listing
|
|
(vc-append
|
|
GAP
|
|
(lbl file "control.rkt")
|
|
(hc-append (* 2 GAP)
|
|
(lbl file "sensors.rkt")
|
|
(lbl file "actuators.rkt")))))
|
|
(define db-listing
|
|
(listing
|
|
(vc-append
|
|
GAP
|
|
(lbl file "lookup.rkt")
|
|
(hc-append (* 2 GAP)
|
|
(lbl file "barcodes.rkt")
|
|
(lbl file "makers.rkt")))))
|
|
|
|
(define (zoom from to p)
|
|
(pin-line
|
|
(pin-line p
|
|
from lb-find
|
|
to lt-find
|
|
#:style 'dot)
|
|
from rb-find
|
|
to rt-find
|
|
#:style 'dot))
|
|
|
|
|
|
(define module-hierarchy
|
|
(inset
|
|
(zoom
|
|
db-folder db-listing
|
|
(zoom
|
|
mach-folder mach-listing
|
|
(vc-append
|
|
(* 3 GAP)
|
|
(listing
|
|
(hc-append (* 4 GAP)
|
|
(lbl file "sort.rkt")
|
|
(lbl db-folder "db")
|
|
(lbl mach-folder "machine")))
|
|
(hc-append
|
|
(* 2 GAP)
|
|
db-listing
|
|
mach-listing))))
|
|
2))
|