blob: 2e1bb7fec6496229d73d89ceabeea6b3d270fd72 (
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
|
#lang racket/base
(require pict)
(require racket/gui/base)
(require racket/format)
(require racket/function)
(require racket/match)
(require racket/contract)
(require "amb.rkt")
(define CELL-SIZE 30)
(define ARROW-LENGTH 30)
(define ARROW-SIZE 10)
(define (square n)
(rectangle n n))
(define (pict-cell x)
(cc-superimpose (square CELL-SIZE)
(scale (filled-ellipse CELL-SIZE CELL-SIZE) 1/4)))
(define (pict-cons-cell pair)
(hc-append (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 (~s x))))
(define (cdr* lst)
(if (null? lst)
'()
(cdr lst)))
(define (%pict-sexp sexp height-list)
(when (and (pair? height-list)
(<= 0 (car height-list)))
(amb))
(cond
[(pair? sexp)
(let*-values ([(p) (pict-cons-cell sexp)]
[(p-1 height-list)
(let-values ([(pict-cdr cdr-height-list)
(%pict-sexp (cdr sexp) (cdr* height-list))])
(values (arrow-from-cdr p pict-cdr)
(cons 0 cdr-height-list)))]
[(p-2 height-list)
(match-let ([(cons len height-list)
(let retry ([len 0]
[height-list height-list])
(amb (cons len height-list)
(retry (add1 len) (map sub1 height-list))))])
(let-values ([(pict-car height-list)
(%pict-sexp (car sexp) height-list)])
(values (arrow-from-car len p pict-car)
(map (λ (x) (+ x len)) height-list))))])
(values (lt-superimpose p-1 p-2) height-list))]
[else
(values (pict-atom sexp) (cons 0 (cdr* height-list)))]))
(define (pict-sexp sexp)
(call-with-amb
(thunk
(define-values (result height-list)
(%pict-sexp sexp '()))
result)))
(provide/contract [pict-sexp (any/c . -> . pict?)])
(define show pict-sexp)
(provide/contract [show (any/c . -> . pict?)])
|
