#lang scheme/gui
(require scheme/list)
;; helper
;; create new list that is the cumulative sum of the source list
;; returns row/column offsets from the origin including the width of the line grid
(define (offsets num-list spacer-width)
  (foldl (lambda (v cum-list) 
           (append cum-list (list (+ v spacer-width (last cum-list)))))
         (list (+ 0 spacer-width))
         (drop-right num-list 1)))
;; table-map
(define-syntax map-table
  (syntax-rules ()
    ((_ function table)
     (map 
      (lambda (row) 
        (map function row))
      table))))

(define-syntax for-each-table
  (syntax-rules ()
    ((_ function table)
     (for-each 
      (lambda (row) 
        (for-each function row))
      table))))



(define-syntax map-cols-to-rows
  (syntax-rules ()
    ((_ function c-lst r-lst)
     (map 
      (lambda (row-e) 
        (map (lambda (col-e) (function col-e row-e)) c-lst))
      r-lst))))


;; swap rows with columns
(define (swap-table table)
  (apply map (lambda args args) table))


;; create new list that is the cumulative sum of the source list
(define (sumnr num-list)
  (foldl (lambda (v cum-list) 
           (append cum-list (list (+ v (last cum-list)))))
         (list (car num-list))
         (cdr num-list)))


(provide table-snip%
         ;table-snipclass%
         
         )
; lay out table
; left alligned cells
; column width set by first row
; row height set by text extent



(define table-snip%
  (class snip%
    (inherit set-snipclass get-style get-admin)
    (init-field
     (hmargin 1) ; spacing between content and border
     (vmargin 1) ;
     (grid-width 1) ; 0 for no grid
     
     (table '(("test" "table")(a b)(b c)(c d))))
    
    (define body-pen (send the-pen-list find-or-create-pen "blue" 0 'solid))
    (define body-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
    (define/private (get r c)
      (list-ref (list-ref table r) c))
    
    (define/override get-extent
      (lambda (dc x y w h descent space lspace rspace)
        (for-each (lambda (b) (when (box? b) (set-box! b 0)))
                  (list descent space lspace rspace))
        (let-values (((table-offs width height row-grids col-grids) (table-offsets (table-dimentions dc))))
          (when (box? w) (set-box! w width))
          (when (box? h) (set-box! h height)))))
    
    ;;;;;;;;
    ;; (width height) of each cell as rendered by display
    (define (table-dimentions dc); (table of cell-text (width height))
      (map-table
       (lambda (datum)
         (let-values (((w h b s) (send dc get-text-extent (format "~A" datum) 
                                       (send (get-style) get-font))))
           (list w h)))
       table))
    
    ;; the positioning offsets for each cell
    ; values: (offsets-for-drawing-cell-contents(x y)) table-width table-height  row-grids col-grids
    (define (table-offsets dimentions-table)
      (define heights-table (map-table cadr dimentions-table))
      (define widths-table (map-table car dimentions-table))
      
      ;; row and column widths and heights including the border and margin
      (define col-widths (map (lambda (c) 
                                (+ (apply max c) (* 2 grid-width) (* 2 hmargin))) ;; *2 because on both sides
                              (swap-table widths-table)
                              ))
      (define row-heights (map (lambda (r) 
                                 (+ (apply max r) (* 2 grid-width) (* 2 vmargin)))
                               heights-table))
      ;; col and row offsets from the origin
      (define col-offsets (offsets col-widths grid-width))
      (define row-offsets (offsets row-heights grid-width))
      ;; this cross-check the col/row-offsets with the table width
      (define table-width (apply + grid-width (* (length col-widths) grid-width) col-widths))
      (define table-height (apply + grid-width (* (length row-heights) grid-width) row-heights))
      
      (define cell-offsets 
        (map-cols-to-rows (lambda (w h) (list w h))
                          col-offsets row-offsets))
      
      ;; col and row grids from the origin
      (define col-grids (append (map (lambda (o)(- o grid-width)) col-offsets) (list table-width)))
      (define row-grids (append (map (lambda (o)(- o grid-width)) row-offsets) (list table-height)))
      
      (values cell-offsets table-width table-height row-grids col-grids))
    
    (define/override (draw dc x y left top right bottom dx dy draw-caret?)
      (define-values (table-offs width height row-grids col-grids) (table-offsets (table-dimentions dc)))
      (let ([orig-pen (send dc get-pen)]
            [orig-brush (send dc get-brush)]
            [snip-w (- right left)]
            [snip-h (- bottom top)])
        (send dc set-pen body-pen)
        (send dc set-brush body-brush)
        (if (> grid-width 0)
            (begin
              (for-each ;row
               (lambda (gy)
                 (send dc draw-line x (+ y gy) (+ x width) (+ y gy)))
               row-grids)
              (for-each ;row
               (lambda (gx)
                 (send dc draw-line (+ x gx) y  (+ x gx) (+ y height)))
               col-grids))
            (void))
        
        (for-each
         (lambda (row offset-rows)
           (for-each (lambda (cel cell-offsets)
                       (let ((pos (map (lambda (xx yy) (+ xx yy)) (list x y) cell-offsets)))
                         (send dc draw-text (format "~A" cel) (car pos) (cadr pos))))
                     row offset-rows))
         table table-offs)
        (send dc set-pen orig-pen)
        (send dc set-brush orig-brush)))
    (super-instantiate ())
    (set-snipclass table-snipclass%)
    ))

(define table-snipclass%
  (make-object
      (class snip-class% 
        (define/override (read s)
          (make-object table-snip%))
        (super-instantiate ())
        )))

;;;;;;;;;;;;;;;;