;;; 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 (harder 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) ;;red)
(define cons-square-side 20)
(define cons-delta-y 40)
(define cons-delta-x 40)
(define character-width 12) ; this assumes that the font is fixed-width
                            ; (which it is, unless you modify the C part)
(define character-height 20)
(define border 30)

;;; This turns a list of lists of elements into a list of elements,
;;; with the same elements in the same order:
(define (flatten list-of-lists)
  (apply append list-of-lists))

(use-modules (srfi srfi-9))

;;; Each box contains the s-expression it represents (in the case of
;;; conses the car and cdr are not really important, so the representation
;;; may be considered redundant; yet it's simpler this way).
;;; The pivot, minimum and maximum coordinates are absolute (i.e. relative
;;; to the top-left of window). The minimum and maximum coordindates take
;;; into account all subboxes.
;;; subboxes is a list of boxes, whose pivot coordinates are in the
;;; same reference system as the parent.
(define-record-type box-type
  (make-box s-expression
            minimum-drawn-x maximum-drawn-x
            minimum-drawn-y maximum-drawn-y
            pivot-x pivot-y
            minimum-x maximum-x
            minimum-y maximum-y
            subboxes)
  box?
  (s-expression box-s-expression box-set-s-expression!)
  (minimum-drawn-x box-minimum-drawn-x box-set-minimum-drawn-x!)
  (maximum-drawn-x box-maximum-drawn-x box-set-maximum-drawn-x!)
  (minimum-drawn-y box-minimum-drawn-y box-set-minimum-drawn-y!)
  (maximum-drawn-y box-maximum-drawn-y box-set-maximum-drawn-y!)
  (pivot-x box-pivot-x box-set-pivot-x!)
  (pivot-y box-pivot-y box-set-pivot-y!)
  (minimum-x box-minimum-x box-set-minimum-x!)
  (maximum-x box-maximum-x box-set-maximum-x!)
  (minimum-y box-minimum-y box-set-minimum-y!)
  (maximum-y box-maximum-y box-set-maximum-y!)
  (subboxes box-subboxes box-set-subboxes!))

(define (box-width box)
  (- (box-maximum-x box)
     (box-minimum-x box)))
(define (box-height box)
  (- (box-maximum-y box)
     (box-minimum-y box)))

(define (box-translate delta-x delta-y box)
  (make-box (box-s-expression box)
            (+ delta-x (box-minimum-drawn-x box))
            (+ delta-x (box-maximum-drawn-x box))
            (+ delta-y (box-minimum-drawn-y box))
            (+ delta-y (box-maximum-drawn-y box))
            (+ delta-x (box-pivot-x box))
            (+ delta-y (box-pivot-y box))
            (+ delta-x (box-minimum-x box))
            (+ delta-x (box-maximum-x box))
            (+ delta-y (box-minimum-y box))
            (+ delta-y (box-maximum-y box))
            (map (lambda (subbox)
                   (box-translate delta-x delta-y subbox))
                 (box-subboxes box))))

(define (s-expression->boxes s-expression)
  (if (pair? s-expression)
      (cons->boxes s-expression)
      (list (atom->box s-expression)))) ; there's only one way to box an atom

(define (atom->box a)
  (let* ((a-as-string (s-expression->string a))
         (a-width (* (string-length a-as-string) character-width)))
    (make-box a
              0 a-width
              0 character-height
              (/ a-width 2) (/ character-height 2) ; the pivot is in the center
              0 a-width
              0 character-height
              '()))) ; no subboxes

(define (cartesian-product list-a list-b)
  (if (null? list-a)
      '()
      (append (map (lambda (element-b)
                     (cons (car list-a) element-b))
                   list-b)
              (cartesian-product (cdr list-a) list-b))))
                           
(define (cons->boxes c)
  (let* ((car-boxes (s-expression->boxes (car c)))
         (cdr-boxes (s-expression->boxes (cdr c)))
         (car-box-and-cdr-box-pairs
          (cartesian-product car-boxes cdr-boxes))
         (right-angle-boxes-with-short-pointers
          (map (lambda (car-box-and-cdr-box)
                 (make-cons-right-angle-box c
                                            (car car-box-and-cdr-box)
                                            (cdr car-box-and-cdr-box)
                                            1))
               car-box-and-cdr-box-pairs))
         (isosceles-boxes-with-short-pointers
          (map (lambda (car-box-and-cdr-box)
                 (make-cons-isosceles-box c
                                          (car car-box-and-cdr-box)
                                          (cdr car-box-and-cdr-box)
                                          1))
               car-box-and-cdr-box-pairs))
         (right-angle-boxes-with-long-pointers
          (map (lambda (car-box-and-cdr-box)
                 (make-cons-right-angle-box c
                                            (car car-box-and-cdr-box)
                                            (cdr car-box-and-cdr-box)
                                            2))
               car-box-and-cdr-box-pairs))
         ;; (isosceles-boxes-with-long-pointers
         ;;  (map (lambda (car-box-and-cdr-box)
         ;;         (make-cons-isosceles-box c
         ;;                                  (car car-box-and-cdr-box)
         ;;                                  (cdr car-box-and-cdr-box)
         ;;                                  2))
         ;;       car-box-and-cdr-box-pairs))
         )
    (append right-angle-boxes-with-short-pointers
            isosceles-boxes-with-short-pointers
            right-angle-boxes-with-long-pointers
            ;;isosceles-boxes-with-long-pointers
            )))

(define (join-in-a-new-box s-expression minimum-drawn-x maximum-drawn-x minimum-drawn-y maximum-drawn-y
                           pivot-x pivot-y already-translated-subboxes)
  (make-box s-expression
            minimum-drawn-x
            maximum-drawn-x
            minimum-drawn-y
            maximum-drawn-y
            pivot-x
            pivot-y
            (min minimum-drawn-x
                 (apply min (map box-minimum-x already-translated-subboxes)))
            (max maximum-drawn-x
                 (apply max (map box-maximum-x already-translated-subboxes)))
            (min minimum-drawn-y
                 (apply min (map box-minimum-y already-translated-subboxes)))
            (max maximum-drawn-y
                 (apply max (map box-maximum-y already-translated-subboxes)))
            already-translated-subboxes))

(define (box-translate-pivot-into new-pivot-x new-pivot-y box)
  (let* ((old-pivot-x (box-pivot-x box))
         (old-pivot-y (box-pivot-y box))
         (delta-x (- new-pivot-x old-pivot-x))
         (delta-y (- new-pivot-y old-pivot-y)))
    (box-translate delta-x delta-y box)))

(define (box-move-to-top-left-angle border box)
  (let ((minimum-x (box-minimum-x box))
        (minimum-y (box-minimum-y box)))
    (box-translate (- border minimum-x)
                   (- border minimum-y)
                   box)))

(define (make-cons-right-angle-box c car-box cdr-box pointer-length-factor)
  (let* (;(cons-delta-x (* pointer-length-factor cons-delta-x))
         (cons-delta-y (* pointer-length-factor cons-delta-y))
         (pivot-x cons-square-side)
         (pivot-y (/ cons-square-side 2))
         (car-pivot-x (/ cons-square-side 2))
         (car-pivot-y (+ cons-square-side
                         cons-delta-y))
         (cdr-pivot-x (+ (* cons-square-side 2.5)
                         cons-delta-x))
         (cdr-pivot-y (/ cons-square-side 2))
         (translated-car-box
          (box-translate-pivot-into car-pivot-x car-pivot-y car-box))
         (translated-cdr-box
          (box-translate-pivot-into cdr-pivot-x cdr-pivot-y cdr-box)))
    (join-in-a-new-box c
                       0 (* cons-square-side 2)
                       0 cons-square-side
                       pivot-x
                       pivot-y
                       (list translated-car-box translated-cdr-box))))

(define (make-cons-isosceles-box c car-box cdr-box pointer-length-factor)
  (let* ((cons-delta-x (* pointer-length-factor cons-delta-x))
         (cons-delta-y (* pointer-length-factor cons-delta-y))
         (pivot-x cons-square-side)
         (pivot-y (/ cons-square-side 2))
         (half-base cons-delta-x)
         (car-pivot-x (- pivot-x half-base))
         (car-pivot-y (+ cons-square-side cons-delta-y))
         (cdr-pivot-x (+ pivot-x half-base))
         (cdr-pivot-y car-pivot-y)
         (translated-car-box
          (box-translate-pivot-into car-pivot-x car-pivot-y car-box))
         (translated-cdr-box
          (box-translate-pivot-into cdr-pivot-x cdr-pivot-y cdr-box)))
    (join-in-a-new-box c
                       0 (* cons-square-side 2)
                       0 cons-square-side
                       pivot-x
                       pivot-y
                       (list translated-car-box translated-cdr-box))))

;;; Return #t iff the two boxes (in the same reference system)
;;; are disjoint, *without considering subboxes*.
(define (box-disjoint? box-1 box-2)
  (or (< (box-maximum-drawn-x box-1)
         (box-minimum-drawn-x box-2))   ; box-1 on the left
      (< (box-maximum-drawn-x box-2)
         (box-minimum-drawn-x box-1))   ; box-1 on the right
      (< (box-maximum-drawn-y box-1)
         (box-minimum-drawn-y box-2))   ; box-1 above
      (< (box-maximum-drawn-y box-2)
         (box-minimum-drawn-y box-1)))) ; box-1 below

(define (for-all? predicate? list)
  (cond ((null? list)
         #t)
        ((predicate? (car list))
         (for-all? predicate? (cdr list)))
        (else
         #f)))

(define (box-pairwise-disjoint? list-of-boxes)
  (cond ((null? list-of-boxes)
         #t)
        ((for-all? (lambda (other-box)
                     (box-disjoint? (car list-of-boxes) other-box))
                   (cdr list-of-boxes))
         (box-pairwise-disjoint? (cdr list-of-boxes)))
        (else
         #f)))

;;; Return #t iff all the subboxes of the given box are pairwise disjoint:
(define (box-valid? box)
  (box-pairwise-disjoint? (box-and-all-its-subboxes-down-to-leaves box)))
(define (box-and-all-its-subboxes-down-to-leaves box)
  (let ((direct-subboxes (box-subboxes box)))
    (cons box
          (flatten (map box-and-all-its-subboxes-down-to-leaves
                        direct-subboxes)))))

;;; Particularly when no valid solution exists, we can at least sort the
;;; solutions accoding to the number of overlaps, and show the best one:
(define (box-badness box)
  (let ((boxes (box-and-all-its-subboxes-down-to-leaves box)))
    (box-badness-with-respect-to (car boxes)
                                 (cdr boxes))))
(define (box-badness-with-respect-to box other-boxes)
  (if (null? other-boxes)
      0
      (+ (length (filter (lambda (other-box)
                           (not (box-disjoint? box other-box)))
                         other-boxes))
         (box-badness-with-respect-to (car other-boxes)
                                      (cdr other-boxes)))))
(define (box-sort-by-badness list-of-boxes)
  ;; We prefer stability here, because the first generated solutions are better
  ;; than the next ones (we try right angle before isosceles conses):
  (stable-sort list-of-boxes
               (lambda (box-a box-b)
                 (< (box-badness box-a) (box-badness box-b)))))

;;; This is useful for debugging:
(define (box-highlight box)
  (let ((box-minimum-x (box-minimum-x box))
        (box-minimum-y (box-minimum-y box))
        (box-width (box-width box))
        (box-height (box-height box))
        (border 2)
        (color (random-color)))
    (for i 1 (/ (* box-width box-height) 10)
         (draw-pixel (+ (random box-width) box-minimum-x)
                     (+ (random box-height) box-minimum-y)
                     color))))
;    (draw-rectangle (+ box-minimum-x border)
;                    (+ box-minimum-y border)
;                    (- box-width border)
;                    (- box-height border)
;                    color)))

(define (box-draw box)
  ;;(box-highlight box)
  (if (pair? (box-s-expression box))
      (begin
        (draw-cons-box (box-pivot-x box) (box-pivot-y box))
                                        ;(sleep 1) (refresh)
        (let ((car-subbox (car (box-subboxes box)))
              (cdr-subbox (cadr (box-subboxes box))))
          (draw-line-from-car (box-pivot-x box) (box-pivot-y box)
                              (box-pivot-x car-subbox) (box-pivot-y car-subbox))
          (draw-line-from-cdr (box-pivot-x box) (box-pivot-y box)
                              (box-pivot-x cdr-subbox) (box-pivot-y cdr-subbox))
          (box-draw car-subbox)
          (box-draw cdr-subbox)))
      (draw-atom (s-expression->string (box-s-expression box))
                 (box-pivot-x box)
                 (box-pivot-y box))))

;;; Draw an atom, given its written representation and its center position:
(define (draw-atom text x y)
  (let* ((text-length (string-length text))
         (text-width (* text-length character-width)))
    (draw-rectangle (- x (/ text-width 2)) (- y (/ character-height 2))
                    text-width character-height
                    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 (s-expression->string s-expression)
  (let ((string-port (open-output-string)))
    (write s-expression string-port)
    (get-output-string string-port)))

(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 ab abc abcd)
  ;'((foo . bar) c d e f)
  ;'((foo . bar) foobar (quux . z))
  ;'fooo
  ;'(a . b)
  '(a b c d)
  )

(simple-format #t "Computing boxes...\n") (flush-all-ports)
(let* ((all-boxes (box-sort-by-badness (s-expression->boxes e)))
       (valid-boxes (filter box-valid? all-boxes))
       (sleep-time 3000000)
       ;;(boxes-to-draw (if (null? valid-boxes) all-boxes valid-boxes)))
       (boxes-to-draw all-boxes))
  (simple-format #t "~a boxes over ~a are valid\n" (length valid-boxes) (length all-boxes))  (flush-all-ports)
  ;;(display (map box-badness all-boxes)) (newline)
  (while #t
         (map (lambda (box)
                (set! background (if (box-valid? box) black red))
                (clear background)
                (box-draw (box-move-to-top-left-angle border box))
                (draw-centered-text (s-expression->string `(badness ,(box-badness box)))
                                    (/ (window-width) 2)
                                    (- (window-height) border)
                                    (light yellow))
                (refresh)
                (handle-quit-event-only)
                (usleep sleep-time))
              boxes-to-draw)
         (handle-quit-event-only)
         (usleep sleep-time)))