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