;; returns value in car and graphics object in cdr
(define leaf
  (lambda (value)
    (cons value
	  (adjoin (straight 40)
		  (text (expr->string value))))))

;; (comb (car left) (car right)) is new car
;; adorn of (cdr left) and (cdr right) is new cdr
(define tree-step
  (lambda (comb left right)
    (cons (comb (car left) (car right))
	  (adjoin (straight 40)
		  (adorn (adjoin (bend +30) 
				 (cdr left))
			 (adjoin (bend -30) 
				 (cdr right)))))))

(define make-drawing-program
  (lambda (tpred comb ltree rtree aproc)
    (lambda (x)
      (letrec
        ((loop
	  (lambda (x)
	    (if (tpred x)
		(tree-step comb 
			   (loop (ltree x)) 
			   (loop (rtree x)))
		(leaf (aproc x))))))
	(cdr (loop x))))))

(define add
  (lambda (s)
    (if (pair? s)
	(+ (add (car s))
	   (add (cdr s)))
	(if (null? s)
	    0
	    s))))

(define dadd
  (make-drawing-program
   pair?
   +
   car
   cdr
   (lambda (s)
     (if (null? s)
	 0
	 s))))

> (dadd '(1 2))
#<struct:graphic>
> 



;; The versions of label, leaf, tree-step, and make-drawing-program
;; given below contain all the "bells and whistles."

(define label
  (lambda args
    (text 
     (apply string-append
	    " "
	    (map expr->string args)))))

(define leaf
  (lambda (x value phi color)
    (cons value
	  (adjoin (straight (* 3 (abs phi)) color)
		  (if (eq? x value)
		      (label x)
		      (label x '-> value))))))

(define tree-step
  (lambda (comb left right d phi color)
    (let ((value (comb (car left) (car right))))
      (cons value
	    (adjoin (straight (* 3 (abs phi)) color)
		    (label value)
		    (bend (- phi))
		    (adorn (adjoin (bend (/ 65 d))
				   (cdr left))
			   (adjoin (bend (- (/ 65 d)))
				   (cdr right))))))))

(define make-drawing-program
  (lambda (tpred comb ltree rtree aproc)
    (lambda (x)
      (letrec
        ((loop
	  (lambda (x d phi color)
	    (if (tpred x)
		(tree-step comb
			   (loop (ltree x) (+ d 1) (/ 65 d) red)
			   (loop (rtree x) (+ d 1) (- (/ 65 d)) blue)
			   d
			   phi
			   color)
		(leaf x (aproc x) phi color)))))
	(adjoin (transparent 400)
		(bend -180)
		(cdr (loop x 1 0 blue)))))))

> (dadd '(((1 2) 3 4) ((5))))
#<struct:graphic>
> 



(define atom-map
  (lambda (proc s)
    (if (pair? s)
	(cons (atom-map proc (car s))
	      (atom-map proc (cdr s)))
	(if (null? s)
	    ()
	    (proc s)))))

(define datom-map
  (lambda (proc s)
    ((make-drawing-program
      pair?
      cons
      car
      cdr
      (lambda (s)
	(if (null? s)
	    ()
	    (proc s))))
     s)))

> (datom-map number? '(((a) 3) 2 c))
#<struct:graphic>
> 


(define copy
  (lambda (s)
    (if (pair? s)
	(cons (copy (car s))
	      (copy (cdr s)))
	s)))
	  
(define dcopy
  (make-drawing-program 
   pair? 
   cons
   car 
   cdr 
   (lambda (x) x)))

> (dcopy '((1) ((2)) 3))
#<struct:graphic>
> 


(define biggest
  (lambda (s)
    (if (pair? s)
	(max (biggest (car s))
	     (biggest (cdr s)))
	(if (null? s)
	    0
	    s))))

(define dbiggest
  (make-drawing-program
   pair?
   max
   car
   cdr
   (lambda (s)
     (if (null? s)
	 0
	 s))))

> (dbiggest '((1 2 3) (4 5)))
#<struct:graphic>
> 


(define fib
  (lambda (x)
    (if (<= x 1)
	x
	(+ (fib (- x 1)) (fib (- x 2))))))

(define dfib
  (make-drawing-program
   (lambda (x) (> x 1))
   + 
   (lambda (x) (- x 1)) 
   (lambda (x) (- x 2))
   (lambda (x) x)))

> (dfib 6)
#<struct:graphic>
> 


(define swap
  (lambda (x y s)
    (if (pair? s)
	(cons (swap x y (car s))
	      (swap x y (cdr s)))
	(cond ((eq? s x) y)
	      ((eq? s y) x)
	      (else
	       s)))))

(define dswap
  (lambda (x y s)
    ((make-drawing-program
      pair?
      cons
      car
      cdr
      (lambda (s)
	(cond ((eq? s x) y)
	      ((eq? s y) x)
	      (else s))))
     s)))

> (dswap 'foo 'bar '((foo) bar))
#<struct:graphic>
> 


;; expr->string is used in the definitions of leaf and tree-step
(define expr->string
  (lambda (s)
    (letrec
      ((cdr->string
	(lambda (ls)
	  (cond ((null? ls) "")
		((pair? ls)
		 (let ((rest (cdr ls)))
		   (string-append
		    " "
		    (expr->string (car ls))
		    (cond ((null? rest) "")
			  ((pair? rest)
			   (cdr->string rest))
			  (else
			   (string-append
			    " . "
			    (expr->string rest)))))))
		(else
		 (string-append
		  " . "
		  (expr->string ls)))))))
      (cond ((null? s) "()")
	    ((pair? s)
	     (string-append
	      "("
	      (expr->string (car s))
	      (cdr->string (cdr s))
	      ")"))
	    ((vector? s)
	     (string-append "#" (expr->string (vector->list s))))
	    ((number? s)
	     (number->string s))
	    ((symbol? s)
	     (symbol->string s))
	    ((char? s)
	     (case s
	       ((#\newline) "#\newline")
	       ((#\space) "#\space")
	       ((#\tab) "#\tab")
	       (else
		(string-append (string #\# #\\) (string s)))))
	    ((string? s)
	     (string-append (string #\") s (string #\")))
	    ((boolean? s)
	     (if s "#t" "#f"))
	    (else
	     (error 'expr->string "Unreadable type."))))))