;;; This file is part of guile-with-graphics, a graphic library for Guile

;;; Copyright (C) 2009  Luca Saiu

;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.

;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.

;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


(initialize-graphics "Box-and-pointer diagram (easy version)" 800 600)

(load "color.scm") ;; this must be loaded *after* graphics is initialized
(load "utility.scm")
(load "graphics.scm")
(load "interactive.scm")

;;; Global settings:
(define foreground (make-color 1 1 1))
(define background black)
(define cons-square-side 30)
(define layer-distance 70)

(define (average a b)
  (/ (+ a b)
     2))

;;; Draw an atom, given its written representation and its center position:
(define (draw-atom text x y)
  (draw-rectangle (- x cons-square-side) (- y (/ cons-square-side 2))
                  (+ x cons-square-side) cons-square-side
                  background)
  (draw-centered-text text x y foreground))

;;; Draw a cons box (no pointers), given its center position:
(define (draw-cons-box center-x center-y)
  (let* ((leftmost-x (- center-x cons-square-side))
         (rightmost-x (+ center-x cons-square-side))
         (half-side (/ cons-square-side 2))
         (double-side (* cons-square-side 2))
         (top-y (- center-y half-side))
         (bottom-y (+ center-y half-side)))
    (draw-rectangle leftmost-x top-y double-side cons-square-side background)
    (draw-rectangle-border leftmost-x top-y double-side cons-square-side foreground)
    (draw-line center-x top-y center-x bottom-y foreground)))

;;; Draw the pointers coming out of a cons box:
(define (draw-line-from-car cons-center-x cons-center-y x2 y2)
  (draw-line (- cons-center-x (/ cons-square-side 2)) cons-center-y x2 y2 foreground))
(define (draw-line-from-cdr cons-center-x cons-center-y x2 y2)
  (draw-line (+ cons-center-x (/ cons-square-side 2)) cons-center-y x2 y2 foreground))

(define (draw-cons-with-bounds cons minimum-x maximum-x y)
  (let* ((center-x (average minimum-x maximum-x))
         (car-and-cdr-y (+ y layer-distance))
         (car-x (average minimum-x center-x))
         (cdr-x (average center-x maximum-x)))
    (draw-cons-box center-x y)
    (draw-line-from-car center-x y car-x car-and-cdr-y)
    (draw-line-from-cdr center-x y cdr-x car-and-cdr-y)
    (draw-s-expression-with-bounds (car cons) minimum-x center-x car-and-cdr-y)
    (draw-s-expression-with-bounds (cdr cons) center-x maximum-x car-and-cdr-y)))

(define (draw-s-expression-with-bounds s-expression minimum-x maximum-x y)
  (if (pair? s-expression)
      (draw-cons-with-bounds s-expression minimum-x maximum-x y)
      (draw-atom (s-expression->string s-expression) (average minimum-x maximum-x) y)))

(define (s-expression->string s-expression)
  (let ((string-port (open-output-string)))
    (write s-expression string-port)
    (get-output-string string-port)))

(define (draw-s-expression s-expression)
  (draw-s-expression-with-bounds s-expression 0 (- (window-width) 1) layer-distance))

(define e
  ;'((a . #f) . (b))
  ;`(((a . (() . ())) b) ,cons c)
  ;'(a (1 2 3) c d e)
  ;'(((foo bar) . 1) (b . 2) (c . 3))
  ;'((foo . 1) (bar . 2) (quux . 3))
  ;'(a b c d)
  '((a . #f) b)
  )

(clear black)
(draw-s-expression e)

(while #t
  (refresh)
  (handle-quit-event-only))