(define (not-first-eq? x y) (or (null? x) (not (eq? (car x) y)))) (define (not-first-atom? x) (or (null? x) (let ((y (car x))) (not (or (symbol? y) (number? y)))))) ;; S -> () | (E) | A | (S . S) (define S (lambda (ls d succ fail) (S1 ls d succ (lambda () (S2 ls d succ (lambda () (A ls d succ (lambda () (S4 ls d succ fail))))))))) ;; () (define S1 (lambda (ls d succ fail) (if (not-first-eq? ls #\() (fail) (if (not-first-eq? (cdr ls) #\)) (fail) (succ '(()) (cddr ls) (adj (text "S") (st (/ 200 d)) (text "()"))))))) ;; (E) (define S2 (lambda (ls d succ fail) (if (not-first-eq? ls #\() (fail) (E (cdr ls) d (lambda (sexpr1 rest1 g1) (if (not-first-eq? rest1 #\)) (fail) (succ (list sexpr1) (cdr rest1) (adj (text "(E)") (st (/ 200 d)) g1)))) fail)))) ;; A (define A (lambda (ls d succ fail) (if (not-first-atom? ls) (fail) (succ (list (car ls)) (cdr ls) (adj (text "A") (st (/ 200 d)) (text (car ls))))))) ;; (S . S) (define S4 (lambda (ls d succ fail) (if (not-first-eq? ls #\() (fail) (S (cdr ls) (+ d 1) (lambda (sexpr1 rest1 g1) (if (not-first-eq? rest1 #\.) (fail) (S (cdr rest1) (+ d 1) (lambda (sexpr2 rest2 g2) (if (not-first-eq? rest2 #\)) (fail) (succ (list (cons (car sexpr1) (car sexpr2))) (cdr rest2) (branch "(S . S)" d green g1 g2)))) fail))) fail)))) ;; E -> (E)E | SE | S (define E (lambda (ls d succ fail) (E1 ls d succ (lambda () (E2 ls d succ (lambda () (S ls d succ fail))))))) ;; (E)E (define E1 (lambda (ls d succ fail) (if (not-first-eq? ls #\() (fail) (E (cdr ls) (+ d 1) (lambda (sexpr1 rest1 g1) (if (not-first-eq? rest1 #\)) (fail) (E (cdr rest1) (+ d 1) (lambda (sexpr2 rest2 g2) (succ (cons sexpr1 sexpr2) rest2 (branch "(E)E" d red g1 g2))) fail))) fail)))) ;; SE (define E2 (lambda (ls d succ fail) (if (null? ls) (fail) (S ls (+ d 1) (lambda (sexpr1 rest1 g1) (E rest1 (+ d 1) (lambda (sexpr2 rest2 g2) (succ (cons sexpr1 sexpr2) rest2 (branch "SE" d blue g1 g2))) fail)) fail)))) (define branch (lambda (txt d color g1 g2) (adorn (text txt) (adj (be (/ -160 d)) (st (/ 200 d) color) (be (/ 160 d)) g1) (adj (be (/ 160 d)) (st (/ 200 d) color) (be (/ -160 d)) g2)))) ;; Requires scanner (define parse (lambda (str) (S (scan (string->list str)) 2 (lambda (sexpr rest g) g) (lambda () (error "parse error."))))) > (parse "(1 2 3)") #<graphic:adjoin> > > (parse "((foo . bar))") #<graphic:adjoin> > > (parse "(define sqr (lambda (x) (* x x)))") #<graphic:adjoin> > > (parse "(((frodo . sam)) (merry) pippin)") #<graphic:adjoin> >