From 4c0836f31be32c771f5f9e5dd6ced9b7b238fd39 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Wed, 25 May 2022 21:34:23 +0900
Subject: main: Update.

---
 main.rkt | 57 ++++++++++++++++++++++-----------------------------------
 1 file changed, 22 insertions(+), 35 deletions(-)

(limited to 'main.rkt')

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?)])
-- 
cgit v1.2.3