#lang scheme/base

(require "base.ss")

(require scheme/list
         "struct.ss")

; Procedures -------------------------------------

; (U range quotable) ... [#:style style] [#:cf (listof conditional-format)] -> union
(define (hc-append #:style [style empty-style] #:cf [cf null] . ranges)
  (let* ([ranges         (flatten-ranges ranges)]
         [overall-width  (apply + (map range-width ranges))]
         [overall-height (apply max (map range-height ranges))])
    (make-union (compose ranges
                         (lambda (range x y) x)
                         (lambda (range x y) (quotient (- overall-height (range-height range)) 2))
                         (lambda (range x y) (range-width range))
                         (lambda (range x y) 0))
                overall-width
                overall-height
                style
                #:cf cf)))

; (U range quotable) ... [#:style style] [#:cf (listof conditional-format)] -> union
(define (ht-append #:style [style empty-style] #:cf [cf null] . ranges)
  (let* ([ranges         (flatten-ranges ranges)]
         [overall-width  (apply + (map range-width ranges))]
         [overall-height (apply max (map range-height ranges))])
    (make-union (compose ranges
                         (lambda (range x y) x)
                         (lambda (range x y) 0)
                         (lambda (range x y) (range-width range))
                         (lambda (range x y) 0))
                overall-width
                overall-height
                style
                #:cf cf)))

; (U range quotable) ... [#:style style] [#:cf (listof conditional-format)] -> union
(define (hb-append #:style [style empty-style] #:cf [cf null] . ranges)
  (let* ([ranges         (flatten-ranges ranges)]
         [overall-width  (apply + (map range-width ranges))]
         [overall-height (apply max (map range-height ranges))])
    (make-union (compose ranges
                         (lambda (range x y) x)
                         (lambda (range x y) (- overall-height (range-height range)))
                         (lambda (range x y) (range-width range))
                         (lambda (range x y) 0))
                overall-width
                overall-height
                style
                #:cf cf)))

; (U range quotable) ... [#:style style] [#:cf (listof conditional-format)] -> union
(define (vc-append #:style [style empty-style] #:cf [cf null] . ranges)
  (let* ([ranges         (flatten-ranges ranges)]
         [overall-width  (apply max (map range-width ranges))]
         [overall-height (apply + (map range-height ranges))])
    (make-union (compose ranges
                         (lambda (range x y) (quotient (- overall-width (range-width range)) 2))
                         (lambda (range x y) y)
                         (lambda (range x y) 0)
                         (lambda (range x y) (range-height range)))
                overall-width
                overall-height
                style
                #:cf cf)))

; (U range quotable) ... [#:style style] [#:cf (listof conditional-format)] -> union
(define (vl-append #:style [style empty-style] #:cf [cf null] . ranges)
  (let* ([ranges         (flatten-ranges ranges)]
         [overall-width  (apply max (map range-width ranges))]
         [overall-height (apply + (map range-height ranges))])
    (make-union (compose ranges
                         (lambda (range x y) 0)
                         (lambda (range x y) y)
                         (lambda (range x y) 0)
                         (lambda (range x y) (range-height range)))
                overall-width
                overall-height
                style
                #:cf cf)))

; (U range quotable) ... [#:style style] [#:cf (listof conditional-format)] -> union
(define (vr-append #:style [style empty-style] #:cf [cf null] . ranges)
  (let* ([ranges         (flatten-ranges ranges)]
         [overall-width  (apply max (map range-width ranges))]
         [overall-height (apply + (map range-height ranges))])
    (make-union (compose ranges
                         (lambda (range x y) (- overall-width (range-width range)))
                         (lambda (range x y) y)
                         (lambda (range x y) 0)
                         (lambda (range x y) (range-height range)))
                overall-width
                overall-height
                style
                #:cf cf)))

; (U range quotable) [natural] [#:style style] [#:cf (listof conditional-format)] -> range
(define (l-pad range [num 1] #:style [style empty-style] #:cf [cf null])
  (let ([range (quote-range range)])
    (make-union (list (make-part range num 0))
                (+ (range-width range) num)
                (range-height range)
                #:cf cf)))

; (U range quotable) [natural] [#:style style] [#:cf (listof conditional-format)] -> range
(define (r-pad range [num 1] #:style [style empty-style] #:cf [cf null])
  (let ([range (quote-range range)])
    (make-union (list (make-part range 0 0))
                (+ (range-width range) num)
                (range-height range)
                style
                #:cf cf)))

; (U range quotable) [natural] [#:style style] [#:cf (listof conditional-format)] -> range
(define (t-pad range [num 1] #:style [style empty-style] #:cf [cf null])
  (let ([range (quote-range range)])
    (make-union (list (make-part range 0 num))
                (range-width range)
                (+ (range-height range) num)
                style
                #:cf cf)))

; (U range quotable) [natural] [#:style style] [#:cf (listof conditional-format)] -> range
(define (b-pad range [num 1] #:style [style empty-style] #:cf [cf null])
  (let ([range (quote-range range)])
    (make-union (list (make-part range 0 0))
                (range-width range)
                (+ (range-height range) num)
                style
                #:cf cf)))

; range style -> range
(define (style-range range style)
  (if style
      (make-union (list (make-part range 0 0))
                  (range-width range)
                  (range-height range)
                  style)
      range))

; range [border-style] [color] -> range
(define (outline-range range [border-style (border-style thin)] [color (rgb 0 0 0)])
  (let* ([w    (sub1 (range-width  range))]
         [h    (sub1 (range-height range))]
         [line (make-line border-style color)])
    (style-range range
                 (make-uncompiled-style
                  (lambda (x y)
                    (make-compiled-style #:border (make-border #:top    (and (= y 0) line)
                                                               #:right  (and (= x w) line)
                                                               #:bottom (and (= y h) line)
                                                               #:left   (and (= x 0) line))))))))

; range [natural] [color] [color] -> range
(define (stripe-rows range [stripe-size 1] [color1 (rgb 1 1 1)] [color2 (rgb .5 1 1)])
  (let ([twice-stripe-size (* 2 stripe-size)])
    (style-range range
                 (make-uncompiled-style
                  (lambda (x y)
                    (make-compiled-style #:fill (make-solid-fill (if (< (remainder y twice-stripe-size)
                                                                        stripe-size)
                                                                     color1
                                                                     color2))))))))

; range [natural] [color] [color] -> range
(define (stripe-cols range [stripe-size 1] [color1 (rgb 1 1 1)] [color2 (rgb .5 1 1)])
  (let ([twice-stripe-size (* 2 stripe-size)])
    (style-range range
                 (make-uncompiled-style
                  (lambda (x y)
                    (make-compiled-style #:fill (make-solid-fill (if (< (remainder x twice-stripe-size)
                                                                        stripe-size)
                                                                     color1
                                                                     color2))))))))

; range [(U range #f)] [(U range #f)] [border-style] [border-style] [color] [color] -> range
(define (tabulate data
                  [col-headers        #f]
                  [row-headers        #f]
                  [outer-border-style (border-style medium)]
                  [inner-border-style (border-style thin)]
                  [color1             (rgb 1 1 1)]
                  [color2             (rgb .5 1 1)])
  ; range
  (define col-data
    (stripe-rows (if row-headers
                     (ht-append (outline-range row-headers inner-border-style)
                                (outline-range data inner-border-style))
                     (outline-range data inner-border-style))
                 (min (add1 (quotient (range-height data) 10)) 5)
                 color1
                 color2))
  ; range
  (outline-range (if col-headers
                     (vl-append (outline-range (if row-headers
                                                   (l-pad col-headers (range-width row-headers))
                                                   col-headers)
                                               inner-border-style)
                                col-data)
                     col-data)
                 outer-border-style))

; Helpers ----------------------------------------

;  (listof range)
;  (range natural natural -> natural)
;  (range natural natural -> natural)
;  (range natural natural -> natural)
;  (range natural natural -> natural)
; ->
;  (listof part)
(define (compose ranges calc-x calc-y calc-dx calc-dy)
  (define-values (parts x y)
    (for/fold ([parts null] [x 0] [y 0])
              ([range (in-list ranges)])
              (values (cons (make-part range
                                       (calc-x range x y)
                                       (calc-y range x y))
                            parts)
                      (+ x (calc-dx range x y))
                      (+ y (calc-dy range x y)))))
  (reverse parts))

; any -> boolean
(define (range+quotable? item)
  (or (range? item)
      (boolean? item)
      (number? item)
      (symbol? item)
      (string? item)
      (formula? item)))

; (U range quotable) -> range
(define (quote-range item)
  (if (range? item)
      item
      (make-cell item)))

; tree -> (listof range)
;
; where tree : (U range+quotable (listof tree))
(define (flatten-ranges tree)
  (let ([ans (flatten tree)])
    (if (pair? ans)
        (map quote-range ans)
        (raise-type-error 'ranges-rest-argument "expected one or more ranges" tree))))

; Provide statements -----------------------------

; any -> boolean
(define (treeof-range+quotable? item)
  (or (range+quotable? item)
      (null? item)
      (and (pair? item) (andmap treeof-range+quotable? item))))

(provide/contract
 [hc-append     (->* () (#:style style? #:cf (listof conditional-format?)) #:rest treeof-range+quotable? union?)]
 [ht-append     (->* () (#:style style? #:cf (listof conditional-format?)) #:rest treeof-range+quotable? union?)]
 [hb-append     (->* () (#:style style? #:cf (listof conditional-format?)) #:rest treeof-range+quotable? union?)]
 [vc-append     (->* () (#:style style? #:cf (listof conditional-format?)) #:rest treeof-range+quotable? union?)]
 [vl-append     (->* () (#:style style? #:cf (listof conditional-format?)) #:rest treeof-range+quotable? union?)]
 [vr-append     (->* () (#:style style? #:cf (listof conditional-format?)) #:rest treeof-range+quotable? union?)]
 [l-pad         (->* (range+quotable?) (natural-number/c #:style style? #:cf (listof conditional-format?)) range?)]
 [r-pad         (->* (range+quotable?) (natural-number/c #:style style? #:cf (listof conditional-format?)) range?)]
 [t-pad         (->* (range+quotable?) (natural-number/c #:style style? #:cf (listof conditional-format?)) range?)]
 [b-pad         (->* (range+quotable?) (natural-number/c #:style style? #:cf (listof conditional-format?)) range?)]
 [style-range   (-> range? style? range?)]
 [outline-range (->* (range?) (border-style? color?) range?)]
 [stripe-rows   (->* (range?) (natural-number/c color? color?) range?)]
 [stripe-cols   (->* (range?) (natural-number/c color? color?) range?)]
 [tabulate      (->* (range?)
                     ((or/c range? #f)
                      (or/c range? #f)
                      border-style?
                      border-style?
                      color?
                      color?)
                     range?)])