;;; requires language-level "Full Scheme"

(require-library "error.ss" "htdp")
(require-library "big-draw.ss" "htdp")

(define-signature viewS
  (view make-branch branch? branch-left branch-elem branch-right))

(define viewU
  (unit/sig viewS
    (import errorS bigDrawS plt:userspace^)
    
    (define red (make-rgb 1 0 0))
    (define black (make-rgb 0 0 0))
    
    ; SIGNATUR
    ; view : scheme-value -> VOID
    ; ERKLÄRUNG
    ; (view v) zeigt eine Baumdarstellung von v in einem separaten
    ; Fenster an. Abbruch druch Mausklick.
    ; DEFINITION
    (define view
      (lambda (s)
	(thread
	 (lambda ()
	   (open-graphics)
	   (let* ((bb (elem-bounding-box s))
		  (xoffset 10)
		  (yoffset 10)
		  (vwidth (+ (* xoffset 2) (posn-x bb)))
		  (vheigth (+ (* yoffset 2) (posn-y bb)))
		  (v (open-viewport "Structure View" vwidth vheigth)))
	     (elem-draw v s xoffset yoffset)
	     (get-mouse-click v)
	     (close-viewport v)
	     (close-graphics))))))
    
    (define space-between-branches 20)	;horizontal
    (define space-to-anchor 20)		;vertikal
    
    (define elem-width 30)
    (define elem-height 20)
    
    (define empty-bounding-box
      (make-posn 10 10))

    ; SIGNATUR
    ; elem-draw : viewport scheme-value number number -> posn
    ; ERKLÄRUNG
    ; (elem-draw v e x0 y0) zeichnet eine Baumdarstellung von e an
    ; Position x0 y0 (linke obere Ecke) ins Fenster v. Ergebnis:
    ; Position der Wurzel des Baums.
    (define elem-draw
      (lambda (v elem x0 y0)
        (cond
          ((or (cons? elem) (null? elem))
           (list-draw v elem x0 y0))
          ((branch? elem)
           (btree-draw v elem x0 y0))
          (else
           ((draw-string v)
            (make-posn (+ x0 (/ elem-width 3))
                       (+ y0 10))
            (elem->string elem)
	    black)
           (make-posn (+ x0 (/ elem-width 2)) y0)))))

    
    ; SIGNATUR
    ; list-draw : viewport list number number -> posn
    ; ERKLÄRUNG
    ; (list-draw v a-list x0 y0) zeichnet eine Baumdarstellung der
    ; Liste a-list an Position x0 y0 (linke obere Ecke) ins Fenster
    ; v. Liefert als Ergebnis die Position der Wurzel des Baums.
    ; DEFINITION
    (define list-draw
      (lambda (v a-list x0 y0)
        (if (null? a-list)
            (begin ((draw-solid-ellipse v)
                    (make-posn (+ 3 x0) y0) 4 4
		    black)
                   (make-posn (+ x0 5) y0))
            (let* ((elem-bb (elem-bounding-box (car a-list)))
                   (list-bb (list-bounding-box (cdr a-list)))
                   (my-bb (make-posn (+ (posn-x elem-bb)
                                        space-between-branches
                                        (posn-x list-bb))
                                     (+ space-to-anchor
                                        (max (posn-y elem-bb) (posn-y list-bb)))))
                   (len (length a-list))
                   (my-anchor (make-posn (+ x0
                                            (posn-x elem-bb)
                                            (/ space-between-branches 2))
                                         y0))
                   (elem-anchor (elem-draw v (car a-list) x0 (+ y0 space-to-anchor)))
                   (list-anchor (list-draw v (cdr a-list)
                                           (+ x0 (posn-x elem-bb)
                                              space-between-branches)
                                           (+ y0 space-to-anchor))))
              ((draw-line v) elem-anchor my-anchor black)
              ((draw-line v) list-anchor my-anchor black)
              ((draw-string v) my-anchor "cons" red)
              my-anchor))))
    
    ; SIGNATUR
    ; elem-bounding-box : scheme-value -> posn
    ; ERKLÄRUNG
    ; (elem-bounding-box e) liefert die Breite und Höhe eines
    ; Rechtecks, in das die Baumdarstellung von e hereinpasst.
    ; DEFINITION
    (define elem-bounding-box
      (lambda (elem)
        (cond
          ((cons? elem)
           (list-bounding-box elem))
          ((branch? elem)
           (btree-bounding-box elem))
          (else
           (make-posn elem-width elem-height)))))
    
    ; SIGNATUR
    ; list-bounding-box : list -> posn
    ; ERKLÄRUNG
    ; (list-bounding-box l) liefert die Breite und Höhe eines
    ; Rechtecks, in das die Baumdarstellung von l hereinpasst.
    ; DEFINITION
    (define list-bounding-box
      (lambda (a-list)
        (if (null? a-list)
            empty-bounding-box
            (let ((elem-bb (elem-bounding-box (car a-list)))
                  (list-bb (list-bounding-box (cdr a-list))))
              (make-posn (+ (posn-x elem-bb)
			    space-between-branches
			    (posn-x list-bb))
                         (+ space-to-anchor
			    (max (posn-y elem-bb) (posn-y list-bb))))))))
    
    ; SIGNATUR
    ; elem->string : scheme-value -> string
    ; ERKLÄRUNG
    ; liefert eine Stringrepräsentation des Arguments.
    ; DEFINITION
    (define elem->string
      (lambda (elem)
        (cond
          ((number? elem) (number->string elem))
          ((string? elem) elem)
          ((symbol? elem) elem)
          ((boolean? elem) (if elem "#t" "#f"))
          ((null? elem) "empty")
          ((pair? elem) "<cons>")
          ((posn? elem) "<posn>")
          (else "*unknown*"))))
    
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ; btree
    (define-struct branch (left elem right))
    
    (define btree-draw
      (lambda (v a-btree x0 y0)
        (if (null? a-btree)
            (begin ((draw-solid-ellipse v black)
                    (make-posn (+ 3 x0) y0) 4 4)
                   (make-posn (+ x0 5) y0))
            (let* ((left-bb (btree-bounding-box (branch-left a-btree)))
                   (elem-bb (elem-bounding-box (branch-elem a-btree)))
                   (right-bb (btree-bounding-box (branch-right a-btree)))
                   (my-bb (make-posn (+ (posn-x left-bb)
                                        space-between-branches
                                        (posn-x elem-bb)
                                        space-between-branches
                                        (posn-x right-bb))
                                     (+ space-to-anchor
                                        (max (posn-y left-bb)
                                             (posn-y elem-bb)
                                             (posn-y right-bb)))))
                   (my-anchor (make-posn (+ x0
                                            (posn-x left-bb)
                                            space-between-branches
                                            (/ (posn-x elem-bb) 2))
                                         y0))
                   (left-anchor (btree-draw v (branch-left a-btree)
                                            x0
                                            (+ y0 space-to-anchor)))
                   (elem-anchor (elem-draw v (branch-elem a-btree)
                                           (+ x0
                                              (posn-x left-bb)
                                              space-between-branches)
                                           (+ y0 space-to-anchor)))
                   (right-anchor (btree-draw v (branch-right a-btree)
                                             (+ x0
                                                (posn-x left-bb)
                                                space-between-branches
                                                (posn-x elem-bb)
                                                space-between-branches)
                                             (+ y0 space-to-anchor))))
              ((draw-line v) left-anchor my-anchor black)
              ((draw-line v) elem-anchor my-anchor black)
              ((draw-line v) right-anchor my-anchor black)
              ((draw-string v) my-anchor "branch" red)
              my-anchor))))
    
    (define btree-bounding-box
      (lambda (a-btree)
        (if (null? a-btree)
            empty-bounding-box
            (let ((left-bb (btree-bounding-box (branch-left a-btree)))
                  (elem-bb (elem-bounding-box (branch-elem a-btree)))
                  (right-bb (btree-bounding-box (branch-right a-btree))))
              (make-posn (+ (posn-x left-bb)
                            space-between-branches
                            (posn-x elem-bb)
                            space-between-branches
                            (posn-x right-bb))
                         (+ space-to-anchor
                            (max (posn-y left-bb)
                                 (posn-y elem-bb)
                                 (posn-y right-bb))))))))
    ))

(compound-unit/sig (import (PLT : plt:userspace^))
                   (link
                    [ERR   : errorS (errorU)]   
                    [DRAW  : bigDrawS  (bigDrawU ERR PLT)]
                    [PINGP : viewS (viewU ERR DRAW PLT)])
                   (export
                    (open DRAW)
                    (open PINGP)))