#lang scheme/gui
(require scheme/list)
(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)))
(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))))
(define (swap-table table)
(apply map (lambda args args) table))
(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%
)
(define table-snip%
(class snip%
(inherit set-snipclass get-style get-admin)
(init-field
(hmargin 1) (vmargin 1) (grid-width 1)
(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)))))
(define (table-dimentions dc) (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))
(define (table-offsets dimentions-table)
(define heights-table (map-table cadr dimentions-table))
(define widths-table (map-table car dimentions-table))
(define col-widths (map (lambda (c)
(+ (apply max c) (* 2 grid-width) (* 2 hmargin))) (swap-table widths-table)
))
(define row-heights (map (lambda (r)
(+ (apply max r) (* 2 grid-width) (* 2 vmargin)))
heights-table))
(define col-offsets (offsets col-widths grid-width))
(define row-offsets (offsets row-heights grid-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))
(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 (lambda (gy)
(send dc draw-line x (+ y gy) (+ x width) (+ y gy)))
row-grids)
(for-each (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 ())
)))