aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--main.rkt57
1 files changed, 22 insertions, 35 deletions
diff --git a/main.rkt b/main.rkt
index 99616d2..4536a0f 100644
--- a/main.rkt
+++ b/main.rkt
@@ -8,28 +8,18 @@
(require tojoqk/amb)
(define CELL-SIZE 30)
-(define ARROW-LENGTH 40)
-(define ARROW-SIZE 15)
+(define ARROW-LENGTH 30)
+(define ARROW-SIZE 10)
(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)))]))
+ (cc-superimpose (square CELL-SIZE)
+ (scale (filled-ellipse CELL-SIZE CELL-SIZE) 1/4)))
(define (pict-cons-cell pair)
- (hc-append -1
- (pict-cell (car pair))
+ (hc-append (pict-cell (car pair))
(pict-cell (cdr pair))))
(define (cdr-find _ p)
@@ -70,7 +60,7 @@
(define (pict-atom x)
(cc-superimpose (cellophane (filled-rectangle CELL-SIZE CELL-SIZE) 0)
- (text (~a x))))
+ (text (~s x))))
(define (cdr* lst)
(if (null? lst)
@@ -85,26 +75,20 @@
[(pair? sexp)
(let*-values ([(p) (pict-cons-cell sexp)]
[(p-1 height-list)
- (cond
- [(need-arrow? (cdr sexp))
- (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)))]
- [else (values p (cons 0 (cdr* 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)
- (cond
- [(need-arrow? (car sexp))
- (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))))]
- [else (values p 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)))]))
@@ -116,3 +100,6 @@
(%pict-sexp sexp '()))
result)))
(provide/contract [pict-sexp (any/c . -> . pict?)])
+
+(define show pict-sexp)
+(provide/contract [show (any/c . -> . pict?)])