;; 6.891 Problem Set 2 -- Nelson Elhage
;;
;; tables.scm -- Implementation of the table layout language for
;; problem 1.5, and associated objects

;;Public interface
(define (t-row . columns)
  (cons 'row (map make-column columns)))

(define (t-column . rows)
  (cons 'column (map make-row rows)))

(define (x-arrange table)
  (let ((subdivisions (subdivide-table table)))
    (layout-subdivisions subdivisions)))

;;Table row and column accessors
(define (make-column c)
  (cond ((table-column? c) c)
        ((table-row? c) (t-column c))
        ((primitive-content? c) c)
        (else (error "Unknown column type -- make-column: " c))))

(define (make-row r)
  (cond ((table-row? r) r)
        ((table-column? r) (t-row r))
        ((primitive-content? r) r)
        (else (error "Unknown row type -- make-row: " r))))

(define (primitive-content? elt)
  (or (string? elt)))

(define (table-row? r)
  (and (list? r)
       (eq? (car r) 'row)))

(define (table-column? c)
  (and (list? c)
       (eq? (car c) 'column)))

(define row-columns cdr)
(define column-rows cdr)

#|
Example:

(t-row (t-column (t-column "A") (t-row "B" "C"))
       (t-column "D" "E" "F")
       "G")

;Value: (row (column (row (column "A")) (row "B" "C")) (column "D" "E" "F") "G")
|#

(define (subdivide-row row bounds)
  (if (primitive-content? row)
      (bounds->subdivision bounds row)
      (let ((num-columns (length (row-columns row))))
        (define (iter columns index acc)
          (if (null? columns)
              acc
              (iter (cdr columns)
                    (1+ index)
                    (cons (subdivide-column (car columns)
                                            (bounds-nth-column bounds index num-columns))
                          acc))))
        (reduce subdivision-merge '()
                (reverse (iter (row-columns row) 0 '()))))))

(define (subdivide-column col bounds)
  (if (primitive-content? col)
      (bounds->subdivision bounds col)
      (let ((num-rows (length (column-rows col))))
        (define (iter rows index acc)
          (if (null? rows)
              acc
              (iter (cdr rows)
                    (1+ index)
                    (cons (subdivide-row (car rows)
                                         (bounds-nth-row bounds index num-rows))
                          acc))))
        (reduce subdivision-merge '()
                (reverse (iter (column-rows col) 0 '()))))))

(define (subdivide-table table)
  (subdivide-row (make-row table) (make-bounds 0 1 0 1)))

;;bounds objects are used to store the bounding rectangle of a cell of
;;a table
(define (make-bounds start-row end-row start-col end-col)
  (list 'bounds start-row end-row start-col end-col))

(define (bounds? b)
  (and (list? b)
       (eq? (car b) 'bounds)))

(define bounds-start-row second)
(define bounds-end-row third)
(define bounds-start-col fourth)
(define bounds-end-col fifth)


(define (bounds-nth-column bounds n total)
  (let* ((width (/ (- (bounds-end-col bounds) (bounds-start-col bounds)) total))
         (start-col (+ (bounds-start-col bounds) (* width n))))
    (make-bounds (bounds-start-row bounds) (bounds-end-row bounds)
                 start-col (+ start-col width))))

(define (bounds-nth-row bounds n total)
  (let* ((height (/ (- (bounds-end-row bounds) (bounds-start-row bounds)) total))
         (start-row (+ (bounds-start-row bounds) (* height n))))
    (make-bounds start-row (+ start-row height)
                 (bounds-start-col bounds) (bounds-end-col bounds))))


;;Subdivisions -- a table subdivision stores an ordered list of all
;;the column boundaries in a table, as well as an ordered alist
;;mapping (starting row => list of cells)
#|
As an example, the table

-------------------
|         |       |
|         |   D   |
|   A     |       |
|         |-------|
|         |       |
|---------|   E   |
|    |    |       |
|    |    |-------|
| B  | C  |       |
|    |    |   F   |
|    |    |       |
-------------------

Has columns (0 1/4 1/2)
and row list ((0 <A> <D>)
              (1/3 <E>)
              (1/2 <B> <C>)
              (2/3 <F>))

where each of A-F is ([cell bounds] . [content])
|#

(define (make-subdivision columns cells)
  (list 'subdivision columns cells))

(define (bounds->subdivision bounds content)
  (make-subdivision (list (bounds-start-col bounds)
                          (bounds-end-col bounds))
                    (list (list (bounds-start-row bounds)
                                (cons bounds content)))))

(define subdivision-columns second)
(define subdivision-rows third)

(define cell-bounds car)
(define cell-content cdr)

;;Merge two subvisions
(define (subdivision-merge s1 s2)
  (make-subdivision
   (subdivision-merge-columns (subdivision-columns s1)
                              (subdivision-columns s2))
   (subdivision-merge-rows (subdivision-rows s1)
                           (subdivision-rows s2))))


(define (subdivision-merge-columns c1 c2)
  (merge-lists c1 c2))

(define (subdivision-merge-rows r1 r2)
  (define (merge-colset cs1 cs2)
    (cons (car cs1)
          (merge-lists (cdr cs1) (cdr cs2)
                       (lambda (cell1 cell2)
                         (< (bounds-start-col (cell-bounds cell1))
                            (bounds-start-col (cell-bounds cell2))))
                       (lambda (a b)
                         (error "Two cells starting at the same location -- subdivision-merge-rowset")))))
  (merge-lists r1 r2
               (lambda (row1 row2)
                 (< (car row1) (car row2)))
               merge-colset))

;;Methods to lay out a subdivided table object into XHTML
(define (layout-subdivisions divs)
  (let ((columns (subdivision-columns divs))
        (row-starts (append (map car (subdivision-rows divs)) (list 1))))
    (x-table '((border "border"))
             (map (lambda (row) (layout-row columns row-starts row))
                  (subdivision-rows divs)))))

(define (layout-row columns row-starts row)
  (x-tr #f (map (lambda (cell)
                  (let ((bounds (cell-bounds cell))
                        (content (cell-content cell)))
                    (let ((rowspan (get-size row-starts
                                             (bounds-start-row bounds)
                                             (bounds-end-row bounds)))
                          (colspan (get-size columns
                                             (bounds-start-col bounds)
                                             (bounds-end-col bounds))))
                      (x-td `((colspan ,colspan)
                              (rowspan ,rowspan))
                            content))))
                (cdr row))))

;;Given a list of all the starting locations for rows or columns in a
;;table, find the number cells between a given start and end location
(define (get-size all start end)
  (let ((rest (memv start all)))
    (if (not rest) (error "Cell not found -- get-size"))
    (let ((end-index (search-list rest end)))
      (if (not end-index) (error "Cell end not found -- get-size"))
      end-index)))
#|
Example:

(get-size '(0 1/4 1/3 1/2 2/3) 0 1/3)

;Value: 2

|#