<![CDATA[
(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
<![CDATA[
(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>
>
]]>
<![CDATA[
> (parse "((foo . bar))")
#<graphic:adjoin>
>
]]>
<![CDATA[
> (parse "(define sqr (lambda (x) (* x x)))")
#<graphic:adjoin>
>
]]>
<![CDATA[
> (parse "(((frodo . sam)) (merry) pippin)")
#<graphic:adjoin>
>
]]>
