#lang racket/base

;; Extra drawing, font, color and style functions.

(require racket/draw racket/class racket/match racket/list racket/contract racket/math
         "math.rkt"
         "contract.rkt"
         "contract-doc.rkt"
         "sample.rkt")

(provide (all-defined-out))

;; ===================================================================================================
;; Drawing text rotated around an anchor point

(define (draw-text/anchor dc str x y [anchor 'top-left] [combine? #f] [offset 0] [angle 0])
  (define-values (width height _1 _2) (send dc get-text-extent str #f combine? offset))
  (define dx (case anchor
               [(top-left left bottom-left)     0]
               [(top center bottom)             (* 1/2 width)]
               [(top-right right bottom-right)  width]
               [else  (raise-type-error 'draw-text/anchor "anchor/c" anchor)]))
  (define dy (case anchor
               [(top-left top top-right)           0]
               [(left center right)                (* 1/2 height)]
               [(bottom-left bottom bottom-right)  height]))
  (define rdx (+ (* (sin angle) dy) (* (cos angle) dx)))
  (define rdy (- (* (cos angle) dy) (* (sin angle) dx)))
  
  (send dc draw-text str (- x rdx) (- y rdy) combine? offset angle))

(define (get-text-corners/anchor dc str x y [anchor 'top-left] [combine? #f] [offset 0] [angle 0])
  (define-values (width height _1 _2) (send dc get-text-extent str #f combine? offset))
  (define dxs (case anchor
                [(top-left left bottom-left)     (list 0 width)]
                [(top center bottom)             (list (* -1/2 width) (* 1/2 width))]
                [(top-right right bottom-right)  (list (- width) 0)]
                [else  (raise-type-error 'get-text-corners/anchor "anchor/c" anchor)]))
  (define dys (case anchor
                [(top-left top top-right)           (list 0 height)]
                [(left center right)                (list (* -1/2 height) (* 1/2 width))]
                [(bottom-left bottom bottom-right)  (list (- height) 0)]))
  
  (for*/list ([dx  (in-list dxs)] [dy  (in-list dys)])
    (define rdx (+ (* (sin angle) dy) (* (cos angle) dx)))
    (define rdy (- (* (cos angle) dy) (* (sin angle) dx)))
    (vector (+ x rdx) (+ y rdy))))

;; ===================================================================================================
;; Draw paramter normalization

(define (real->font-size size)
  (define i (inexact->exact (round size)))
  (min (max i 1) 255))

(define (real->color-byte f)
  (define i (inexact->exact (floor f)))
  (min (max i 0) 255))

(define (color%? c) (is-a? c color%))

(defproc (->color [c color/c]) (list/c real? real? real?)
  (match c
    [(? color%?)  (list (send c red) (send c green) (send c blue))]
    [(? string?)  (define color (send the-color-database find-color c))
                  (when (not color) (error 'decode-color "unknown color name ~e" c))
                  (->color color)]
    [(list (? real?) (? real?) (? real?))  c]
    [(? symbol?)  (->color (symbol->string c))]
    [_  (error '->color "unable to convert to color triple: ~e" c)]))

(define (color->color% c)
  (match-define (list r g b) c)
  (make-object color% (real->color-byte r) (real->color-byte g) (real->color-byte b)))

(define (rgb->hsv rgb)
  (match-define (list r g b) (map (λ (x) (/ x 255)) rgb))
  (define mx (max r g b))
  (define mn (min r g b))
  (define c (- mx mn))
  (define h (* 60 (cond [(zero? c)  0]
                        [(= mx r)   (/ (- g b) c)]
                        [(= mx g)   (+ (/ (- b r) c) 2)]
                        [(= mx b)   (+ (/ (- r g) c) 4)])))
  (list (if (h . < . 0) (+ h 360) h)
        (if (zero? mx) 0 (/ c mx))
        mx))

(define (hsv->rgb hsv)
  (match-define (list h s v) hsv)
  (define c (* v s))
  (let ([h  (/ (real-modulo h 360) 60)])
    (define x (* c (- 1 (abs (- (real-modulo h 2) 1)))))
    (define-values (r g b)
      (cond [(and (0 . <= . h) (h . < . 1))  (values c x 0)]
            [(and (1 . <= . h) (h . < . 2))  (values x c 0)]
            [(and (2 . <= . h) (h . < . 3))  (values 0 c x)]
            [(and (3 . <= . h) (h . < . 4))  (values 0 x c)]
            [(and (4 . <= . h) (h . < . 5))  (values x 0 c)]
            [(and (5 . <= . h) (h . < . 6))  (values c 0 x)]))
    (define m (- v c))
    (list (* 255 (+ r m))
          (* 255 (+ g m))
          (* 255 (+ b m)))))

(define (integer->hue n)
  (let ([n  (abs n)])
    (define i (+ (case (remainder n 6) [(0) 0] [(1) 2] [(2) 4] [(3) 1] [(4) 3] [(5) 5])
                 (* 6 3 (quotient n 6))))
    (remainder (* i 59) 360)))

(define (integer->gray-value n)
  (* 1/7 (remainder (abs n) 8)))

(define (integer->pen-color n)
  (define h (integer->hue n))
  (hsv->rgb (list (- h (* 25 (sin (* (/ h 360) (* 3 pi)))))
                  1
                  (+ 1/2 (* 1/6 (sin (* (/ h 360) (* 3 pi))))))))

(define (integer->brush-color n)
  (define h (integer->hue n))
  (hsv->rgb (list (let ([y  (* (/ (- (sqrt (+ (/ h 60) 2)) (sqrt 2))
                                  (- (sqrt 8) (sqrt 2)))
                               6)])
                    (- h (* 15 (sin (* (/ y 6) (* 3 pi))))))
                  (+ 3/16 (* 3/32 (sin (* (/ h 360) (* 2 pi)))))
                  1)))

(define (integer->gray-pen-color i)
  (make-list 3 (* 128 (expt (integer->gray-value i) 3/4))))

(define (integer->gray-brush-color i)
  (make-list 3 (+ 127 (* 128 (expt (- 1 (integer->gray-value i)) 3/4)))))

(define pen-colors
  (for/vector ([color  (in-list (append (list (integer->gray-pen-color 0))
                                        (build-list 120 integer->pen-color)
                                        (build-list 7 (λ (n) (integer->gray-pen-color (- 7 n))))))])
    (map real->color-byte color)))

(define brush-colors
  (for/vector ([color  (in-list (append (list (integer->gray-brush-color 0))
                                        (build-list 120 integer->brush-color)
                                        (build-list 7 (λ (n) (integer->gray-brush-color (- 7 n))))))])
    (map real->color-byte color)))

(defproc (->pen-color [c plot-color/c]) (list/c real? real? real?)
  (cond [(exact-integer? c)  (vector-ref pen-colors (modulo c 128))]
        [else                (->color c)]))

(defproc (->brush-color [c plot-color/c]) (list/c real? real? real?)
  (cond [(exact-integer? c)  (vector-ref brush-colors (modulo c 128))]
        [else                (->color c)]))

#|
(define pen-colors
  '#((0 0 0)          ; black
     (128 0 0)        ; red
     (0 96 0)         ; green
     (0 0 160)        ; blue
     (192 96 0)       ; yellow
     (0 112 128)      ; cyan
     (160 32 240)     ; magenta
     (160 160 160)))  ; gray

(defproc (->pen-color [c plot-color/c]) (list/c real? real? real?)
  (cond [(exact-integer? c)  (vector-ref pen-colors (modulo c 8))]
        [else                (->color c)]))

(define brush-colors
  '#((255 255 255)    ; white
     (255 192 192)    ; red
     (192 255 192)    ; green
     (212 224 240)    ; blue
     (255 248 192)    ; yellow
     (192 240 255)    ; cyan
     (240 224 255)    ; magenta
     (212 212 212)))  ; gray

(defproc (->brush-color [c plot-color/c]) (list/c real? real? real?)
  (cond [(exact-integer? c)  (vector-ref brush-colors (modulo c 8))]
        [else                (->color c)]))
|#

(defproc (->pen-style [s plot-pen-style/c]) symbol?
  (cond [(exact-integer? s)  (case (remainder (abs s) 5)
                               [(0)  'solid]
                               [(1)  'dot]
                               [(2)  'long-dash]
                               [(3)  'short-dash]
                               [(4)  'dot-dash])]
        [(symbol? s)  s]
        [else  (raise-type-error '->pen-style "symbol or integer" s)]))

(defproc (->brush-style [s plot-brush-style/c]) symbol?
  (cond [(exact-integer? s)  (case (remainder (abs s) 7)
                               [(0)  'solid]
                               [(1)  'bdiagonal-hatch]
                               [(2)  'fdiagonal-hatch]
                               [(3)  'crossdiag-hatch]
                               [(4)  'horizontal-hatch]
                               [(5)  'vertical-hatch]
                               [(6)  'cross-hatch])]
        [(symbol? s)  s]
        [else  (raise-type-error '->brush-style "symbol or integer" s)]))

;; ===================================================================================================
;; Color functions

(defproc (color-seq [c1 color/c] [c2 color/c] [num exact-nonnegative-integer?]
                    [#:start? start? boolean? #t]
                    [#:end? end? boolean? #t]) (listof (list/c real? real? real?))
  (match-define (list r1 g1 b1) (->color c1))
  (match-define (list r2 g2 b2) (->color c2))
  (define rs (linear-seq r1 r2 num #:start? start? #:end? end?))
  (define gs (linear-seq g1 g2 num #:start? start? #:end? end?))
  (define bs (linear-seq b1 b2 num #:start? start? #:end? end?))
  (map list rs gs bs))

(defproc (color-seq* [colors (listof color/c)] [num exact-nonnegative-integer?]
                     [#:start? start? boolean? #t]
                     [#:end? end? boolean? #t]) (listof (list/c real? real? real?))
  (when (empty? colors) (raise-type-error 'color-seq* "nonempty (listof plot-color/c)" colors))
  (match-define (list (list rs gs bs) ...) (map ->color colors))
  (let ([rs  (linear-seq* rs num #:start? start? #:end? end?)]
        [gs  (linear-seq* gs num #:start? start? #:end? end?)]
        [bs  (linear-seq* bs num #:start? start? #:end? end?)])
    (map list rs gs bs)))

;; Returns an alpha value b such that, if 
(defproc (alpha-expt [a (real-in 0 1)] [n (>/c 0)]) real?
  (- 1 (expt (- 1 a) n)))

(defproc (maybe-apply/list [list-or-proc (or/c (listof any/c) (any/c . -> . any/c))]
                           [xs (listof any/c)]) (listof any/c)
  (cond [(procedure? list-or-proc)  (list-or-proc xs)]
        [else                       list-or-proc]))

;; ===================================================================================================
;; Subdividing nonlinearly transformed shapes

(define subdivide-fracs '(3/7 4/7 2/7 5/7 1/7 6/7))

(define (subdivide-line transform v1 v2)
  (let loop ([v1 v1] [v2 v2] [depth 10])
    (let/ec return
      (when (zero? depth) (return (list v1 v2)))
      
      (define dc-v1 (transform v1))
      (define dc-v2 (transform v2))
      (define dc-dv (v- dc-v2 dc-v1))
      (when ((vmag dc-dv) . <= . 3)
        (return (list v1 v2)))
      
      (define dv (v- v2 v1))
      (define-values (max-area vc)
        (for/fold ([max-area 0] [vc v1]) ([frac  (in-list subdivide-fracs)])
          (define test-vc (v+ (v* dv frac) v1))
          (define test-area (abs (vcross2 dc-dv (v- (transform test-vc) dc-v1))))
          (cond [(test-area . > . max-area)  (values test-area test-vc)]
                [else  (values max-area vc)])))
      (when (max-area . <= . 3) (return (list v1 v2)))
      
      ;(plot3d-subdivisions (+ (plot3d-subdivisions) 1))
      (append (loop v1 vc (- depth 1))
              (rest (loop vc v2 (- depth 1)))))))

(define (subdivide-lines transform vs)
  (append
   (append*
    (for/list ([v1  (in-list vs)] [v2  (in-list (rest vs))])
      (define line-vs (subdivide-line transform v1 v2))
      (take line-vs (sub1 (length line-vs)))))
   (list (last vs))))

(define (subdivide-polygon transform vs)
  (subdivide-lines transform (cons (last vs) vs)))