diff options
| -rw-r--r-- | main.rkt | 57 |
1 files changed, 22 insertions, 35 deletions
@@ -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?)]) |