vm-pictures.rkt from paper sources
This commit is contained in:
parent
0c07fb3b0e
commit
123fe6026a
|
@ -0,0 +1,95 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (only-in racket/math pi))
|
||||
(require slideshow/pict)
|
||||
(require file/convertible)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define default-font (make-parameter 'roman))
|
||||
|
||||
(define final-border (make-parameter 1))
|
||||
|
||||
(define process-angle (make-parameter 90))
|
||||
(define process-width (make-parameter 24))
|
||||
(define process-corner (make-parameter 6))
|
||||
(define process-height (make-parameter 98))
|
||||
(define process-gap (make-parameter 6))
|
||||
|
||||
(define leg-offset (make-parameter 4))
|
||||
(define leg-width (make-parameter 2))
|
||||
(define leg-spot-width (make-parameter 4))
|
||||
|
||||
(define (default-leg-height)
|
||||
(/ (network-height) 2))
|
||||
|
||||
(define (meta-leg-height)
|
||||
(+ (default-leg-height) (vm-height) (network-height)))
|
||||
|
||||
(define network-height (make-parameter 12))
|
||||
(define vm-height (make-parameter 27))
|
||||
(define process-label-size (make-parameter 12))
|
||||
(define network-label-size (make-parameter 9))
|
||||
(define vm-label-size (make-parameter 12))
|
||||
(define ellipsis-size (make-parameter 24))
|
||||
|
||||
(define (process label)
|
||||
(cb-superimpose
|
||||
(vc-append (text label (default-font) (process-label-size) (d2r (process-angle)))
|
||||
(blank (/ (- (process-width) (process-label-size)) 2)))
|
||||
(rounded-rectangle (process-width) (process-height) (process-corner))))
|
||||
|
||||
(define (process-group . ps)
|
||||
(apply hb-append (process-gap) ps))
|
||||
|
||||
(define (process-space)
|
||||
(blank (- (/ (process-width) 2) (* 2 (process-gap))) (process-height)))
|
||||
|
||||
(define (vm-label str)
|
||||
(text str (default-font) (vm-label-size) (d2r 0)))
|
||||
|
||||
(define (network-label str)
|
||||
(text str (default-font) (network-label-size) (d2r 0)))
|
||||
|
||||
(define (vm label net-label . ps)
|
||||
(define ps-pict (apply process-group ps))
|
||||
(define label-width (max (pict-width label) (pict-width net-label)))
|
||||
(define width (max (+ label-width (* 2 (max (vm-label-size) (network-label-size))))
|
||||
(pict-width ps-pict)))
|
||||
(vl-append ps-pict
|
||||
(cc-superimpose (rectangle width (network-height)) net-label)
|
||||
(cc-superimpose (rectangle width (vm-height)) label)))
|
||||
|
||||
(define (process-ellipsis)
|
||||
(cc-superimpose (text ". . ." (default-font) (ellipsis-size) 0)
|
||||
(blank 0 (process-height))))
|
||||
|
||||
(define (d2r d)
|
||||
(* pi (/ d 180.0)))
|
||||
|
||||
(define (leg p offset height)
|
||||
(define x (+ (/ (pict-width p) 2) (* offset (leg-offset))))
|
||||
(define y (pict-height p))
|
||||
(define leg-pict (vc-append (vline (leg-width) (- height (/ (leg-spot-width) 2)))
|
||||
(disk (leg-spot-width) #:draw-border? #f)))
|
||||
(pin-over p (- x (/ (pict-width leg-pict) 2)) y leg-pict))
|
||||
|
||||
(define (relay-legs p)
|
||||
(leg (leg p 1 (default-leg-height)) -1 (meta-leg-height)))
|
||||
|
||||
(define (local-leg p)
|
||||
(leg p 0 (default-leg-height)))
|
||||
|
||||
(define (render p #:target [target 'eps])
|
||||
(case target
|
||||
[(screen)
|
||||
;; FFS. This connects to the display even if you don't use it.
|
||||
;; (local-require racket/gui/base)
|
||||
;; (show-pict (panorama p) 800 600)
|
||||
(log-error "You need to uncomment a couple of lines in vm-pictures.rkt")
|
||||
(void)]
|
||||
[(eps)
|
||||
(display (convert (cc-superimpose (blank (+ (pict-width p) (* 2 (final-border)))
|
||||
(+ (pict-height p) (* 2 (final-border))))
|
||||
(panorama p))
|
||||
'eps-bytes))]))
|
Loading…
Reference in New Issue