;;; requires language-level "Full Scheme"

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

(define-signature viewS
  (view))

(define viewU
  (unit/sig viewS
    (import errorS bigDrawS plt:userspace^)
    













    ;; Konstanten
    (define red (make-rgb 1 0 0))
    (define black (make-rgb 0 0 0))
    
    (define space-between-branches 30)	;horizontal
    (define space-to-anchor 30)		;vertikal
    
    (define char-width 6)		;horizontale pixels pro char

    (define elem-height 20)		;Höhe einer Stringdarstellung
    
    (define empty-bounding-box		;bounding-box für '()
      (make-posn 10 10))
    









    ; SIGNATUR
    ; view : scheme-value -> VOID
    ; ERKLÄRUNG
    ; (view v) zeigt eine Baumdarstellung von v in einem separaten
    ; Fenster an. Abbruch durch 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))))))


    ; 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
	 ((null? elem)
	  empty-bounding-box)
	 ((pair? elem)
	  (pair-bounding-box elem))
	 ((struct? elem)
	  (struct-bounding-box elem))
	 (else
          (string-bounding-box elem)))))





    
    ; SIGNATUR
    ; string-bounding-box : scheme-value -> posn
    ; ERKLÄRUNG
    ; (string-bounding-box e) liefert die Breite und Höhe eines
    ; Rechtecks, in das die Stringdarstellung von e hereinpasst.
    ; DEFINITION
    (define string-bounding-box
      (lambda (elem)
        (let ((str (elem->string elem)))
          (make-posn (* char-width (string-length str)) 
                     elem-height))))












    ; SIGNATUR
    ; pair-bounding-box : pair -> posn
    ; ERKLÄRUNG
    ; (pair-bounding-box p) liefert die Breite und Höhe eines
    ; Rechtecks, in das die Baumdarstellung von p hereinpasst.
    ; DEFINITION
    (define pair-bounding-box
      (lambda (a-pair)
	(let ((car-bb (elem-bounding-box (car a-pair)))
	      (cdr-bb (elem-bounding-box (cdr a-pair))))
	  (make-posn (+ (posn-x car-bb)
			space-between-branches
			(posn-x cdr-bb))
		     (+ space-to-anchor
			(max (posn-y car-bb) (posn-y cdr-bb)))))))








    ; SIGNATUR
    ; struct-bounding-box : struct -> posn
    ; ERKLÄRUNG
    ; (struct-bounding-box s) liefert Breite und Höhe eines 
    ; Rechtecks, in das die Baumdarstellung von s hereinpasst.
    ; DEFINITION
    (define struct-bounding-box
      (lambda (s)
	(let* ((sv (struct->vector s))
	       (l (vector-length sv)))
	  (let loop ((i 1) (width 0) (height 0))
	    (if (>= i l)
		(make-posn (+ width (* (- l 1)
				       space-between-branches))
			   (+ height space-to-anchor))
		(let ((bb (elem-bounding-box (vector-ref sv i))))
		  (loop (+ i 1)
			(+ width (posn-x bb))
			(max height (posn-y 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) (symbol->string elem))
          ((boolean? elem) (if elem "#t" "#f"))
          ((null? elem) "'()")
          ((pair? elem) "<cons>")
          ((posn? elem) "<posn>")
	  ((struct? elem) "<struct>")
          (else "*unknown*"))))

    




    ; 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.
    ; DEFINITION
    (define elem-draw
      (lambda (v elem x0 y0)
        (cond
	 ((null? elem)
	  (empty-draw v x0 y0))
	 ((pair? elem)
	  (pair-draw v elem x0 y0))
	 ((struct? elem)
	  (struct-draw v elem x0 y0))
	 (else
          (string-draw v elem x0 y0)))))
    




    ; SIGNATUR
    ; string-draw : viewport scheme-value number number -> posn
    ; ERKLÄRUNG
    ; (string-draw v e x0 y0) zeichnet eine Stringdarstellung von e
    ; an Position x0 y0 ins Fenster v. Ergebnis: Ankerpunkt.
    ; DEFINITION
    (define string-draw
      (lambda (v elem x0 y0)
        (let* ((str (elem->string elem))
               (width (* char-width (string-length str))))
          ((draw-string v)
           (make-posn x0 (+ y0 10))
           str
           black)
          (make-posn (+ x0 (/ width 2)) y0))))






                            
    
    ; SIGNATUR
    ; empty-draw : viewport number number -> posn
    ; ERKLÄRUNG
    ; (empty-draw v x0 y0) zeichnet leere Liste als fetten Punkt in
    ; Fenster v an Position x0 y0. Ergebnis: Ankerpunkt.
    ; DEFINITION
    (define empty-draw
      (lambda (v x0 y0)
	((draw-solid-ellipse v)
	 (make-posn (+ 3 x0) y0) 4 4
	 black)
	(make-posn (+ x0 5) y0)))











    ; SIGNATUR
    ; pair-draw : viewport pair number number -> posn
    ; ERKLÄRUNG
    ; (pair-draw v a-pair 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 pair-draw
      (lambda (v a-pair x0 y0)
	(let* ((car-bb (elem-bounding-box (car a-pair)))
	       (cdr-bb (elem-bounding-box (cdr a-pair)))
	       (my-bb (make-posn (+ (posn-x car-bb)
				    space-between-branches
				    (posn-x cdr-bb))
				 (+ space-to-anchor
				    (max (posn-y car-bb) 
                                         (posn-y cdr-bb)))))






	       (my-anchor (make-posn (+ x0
					(posn-x car-bb)
					(/ space-between-branches 2))
				     y0))
	       (car-anchor 
                (elem-draw v (car a-pair) x0 (+ y0 space-to-anchor)))
	       (cdr-anchor 
                (elem-draw v
                           (cdr a-pair)
                           (+ x0 (posn-x car-bb) space-between-branches)
                           (+ y0 space-to-anchor))))
	  ((draw-line v) car-anchor my-anchor black)
	  ((draw-line v) cdr-anchor my-anchor black)
	  ((draw-string v) my-anchor "cons" red)
	  my-anchor)))








    ; SIGNATUR
    ; struct-draw : viewport struct number number -> posn
    ; ERKLÄRUNG
    ; (struct-draw v s x0 y0) zeichnet Repräsentation für s ins
    ; Fenster v an die Position x0 y0. Ergebnis: Ankerpunkt.
    (define struct-draw
      (lambda (v s x0 y0)
	(let* ((bb (struct-bounding-box s))
	       (sv (struct->vector s))
	       (y1 (+ y0 space-to-anchor))
	       (l (vector-length sv))
	       (my-anchor (make-posn (+ x0 (/ (posn-x bb) 2)) y0))
	       (type-code (symbol->string (vector-ref sv 0))))
	  ((draw-string v)
	   my-anchor
	   (substring type-code 7 (string-length type-code))
	   red)






	  (let loop ((i 1)
		     (width (- x0 space-between-branches)))
	    (if (< i l)
		(let* ((elem-i (vector-ref sv i))
		       (bb-i (elem-bounding-box elem-i))
		       (x-i (+ width space-between-branches))
		       (anchor-i (elem-draw v elem-i x-i y1)))
		  ((draw-line v) my-anchor anchor-i black)
		  (loop (+ i 1)
			(+ x-i (posn-x bb-i))))
		my-anchor)))))











    
    ))

(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)))