blob: 95829ef8d50090df32aabb5cb3547db4063e6319 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
#lang racket
(require racket/contract)
(require pict)
(define CELL-SIZE 30)
(define ARROW-LENGTH 40)
(define ARROW-SIZE 15)
(define (square n)
(rectangle n n))
(define (need-arrow? x)
(or (pair? x)
(< 2 (string-length (~a x)))))
(define (pict-cell x)
(cond
[(need-arrow? x)
(cc-superimpose (square CELL-SIZE)
(scale (filled-ellipse CELL-SIZE CELL-SIZE) 1/4))]
[else
(cc-superimpose (square CELL-SIZE)
(text (~a x)))]))
(define (pict-cons-cell pair)
(hc-append -1
(pict-cell (car pair))
(pict-cell (cdr pair))))
(define (cdr-find _ p)
(values (- (pict-width p) (/ CELL-SIZE 2.0))
(/ CELL-SIZE 2.0)))
(define (car-find p _)
(values (/ CELL-SIZE 2.0)
(/ CELL-SIZE 2.0)))
(define (left-find p p1)
(values (- (pict-width p) (pict-width p1))
(/ CELL-SIZE 2.0)))
(define (top-find p p1)
(values (/ CELL-SIZE 2.0)
(- (pict-height p) (pict-height p1))))
(define (horizontal-combined p1 p2)
(ht-append ARROW-LENGTH p1 p2))
(define (vertical-combined n p1 p2)
(vl-append (- (* (+ CELL-SIZE ARROW-LENGTH) n)
(pict-height p1))
p1 p2))
(define (arrow-from-cdr p1 p2)
(pin-arrow-line ARROW-SIZE
(horizontal-combined p1 p2)
p1 cdr-find
p2 left-find))
(define (arrow-from-car n p1 p2)
(pin-arrow-line ARROW-SIZE
(vertical-combined n p1 p2)
p1 car-find
p2 top-find))
(define (pict-atom x)
(cc-superimpose (cellophane (filled-rectangle CELL-SIZE CELL-SIZE) 0)
(text (~a x))))
(define (cdr* lst)
(if (null? lst)
'()
(cdr lst)))
(define (pict-sexp/helper sexp height-list fail)
(when (and (pair? height-list)
(<= 0 (car height-list)))
(fail))
(cond
[(pair? sexp)
(let*-values ([(cell) (pict-cons-cell sexp)]
[(cell-1 height-list)
(cond
[(need-arrow? (cdr sexp))
(let-values ([(pict-cdr cdr-height-list)
(pict-sexp/helper (cdr sexp)
(cdr* height-list)
fail)])
(values (arrow-from-cdr cell pict-cdr)
(cons 0 cdr-height-list)))]
[else (values cell (cons 0 (cdr* height-list)))])]
[(cell-2 height-list)
(cond
[(need-arrow? (car sexp))
(let retry ([len 1] [height-list (map sub1 height-list)])
(let/cc escape
(let/cc fail
(let-values ([(pict-car height-list)
(pict-sexp/helper (car sexp)
height-list
fail)])
(escape (arrow-from-car len cell pict-car)
(map (λ (x) (+ x len)) height-list))))
(retry (add1 len) (map sub1 height-list))))]
[else (values cell height-list)])])
(values (lt-superimpose cell-1 cell-2) height-list))]
[else
(values (pict-atom sexp) (cons 0 (cdr* height-list)))]))
(define (pict-sexp sexp)
(define-values (result height-list)
(pict-sexp/helper sexp '() (λ () (error "pict-sexp: implementation error"))))
result)
(provide/contract [pict-sexp (any/c . -> . pict?)])
|
