From 03c2e7deb2cb7cf34f3b15fc6b1754ace88a47ad Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Sun, 24 Jun 2018 10:46:03 +0900 Subject: Rename pict-sexp.rkt to main.rkt --- main.rkt | 114 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ pict-sexp.rkt | 114 ---------------------------------------------------------- 2 files changed, 114 insertions(+), 114 deletions(-) create mode 100644 main.rkt delete mode 100644 pict-sexp.rkt diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..8bf8222 --- /dev/null +++ b/main.rkt @@ -0,0 +1,114 @@ +#lang racket +(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 pict-sexp) diff --git a/pict-sexp.rkt b/pict-sexp.rkt deleted file mode 100644 index 8bf8222..0000000 --- a/pict-sexp.rkt +++ /dev/null @@ -1,114 +0,0 @@ -#lang racket -(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 pict-sexp) -- cgit v1.2.3