#lang racket

(require racket/gui racket/draw racket/date)

(provide date-chooser%)

(require "lib/triangle-button.rkt")

(require "lib/date-utils.rkt")

(require "lib/string-utils.rkt")

(define date-chooser%
  (class object%
    (super-new)
    
    (init-field
     parent-gui 
     width
     height
     [choosed-date (current-date)]
     [font (make-object font%)]
     [background-color "white"]
     [text-color "black"]
     [border-color "black"]
     [button-down-border-color "black"]
     [button-down-fill-color "white"]
     [button-up-border-color "white"]
     [button-up-fill-color "black"])
    
    (define/public (get-date)
      choosed-date)

    (define/public (set-date new-date)
      (set! choosed-date new-date))

    (define/private (get-year)
      (number->string (date-year choosed-date)))

    (define/private (get-month)
      (string-fill (number->string (date-month choosed-date)) #\0 2))

    (define/private (get-day)
      (string-fill (number->string (date-day choosed-date)) #\0 2))

    (define year-up-button #f)
    (define year-down-button #f)
    (define month-up-button #f)
    (define month-down-button #f)
    (define day-up-button #f)
    (define day-down-button #f)

    (define datechooser-canvas%
      (class canvas%
        (super-new)
        (inherit get-dc)

        (define/override (on-paint)
          (let ([my-dc (get-dc)])
            (send my-dc set-background background-color)
            (send my-dc clear)
            (send my-dc set-smoothing 'smoothed)
            (send my-dc set-text-foreground text-color)
            (send my-dc set-brush "white" 'transparent)
            (send my-dc set-pen border-color 1 'solid)
            (send my-dc set-font font)

            ;; use get-text-extent to calculate text width and height
            (let*-values ([(start-x) 0]
                          [(start-y) 0]
                          [(rec-spacing) 10]
                          [(text-horizontal-spacing) 5]
                          [(text-vertical-spacing) 2]
                          [(year-text-width year-text-height _1 _2)
                           (send my-dc get-text-extent (get-year))]
                          [(month-text-width month-text-height _1 _2)
                           (send my-dc get-text-extent (get-month))]
                          [(day-text-width day-text-height _1 _2)
                           (send my-dc get-text-extent (get-day))]
                          [(year-rec-width) (+ year-text-width (* text-horizontal-spacing 2))]
                          [(year-rec-height) (+ year-text-height (* text-vertical-spacing 2))]
                          [(all-height) year-rec-height]
                          [(month-rec-width) (+ month-text-width (* text-horizontal-spacing 2))]
                          [(month-rec-height) all-height]
                          [(day-rec-width) (+ day-text-width (* text-horizontal-spacing 2))]
                          [(day-rec-height) all-height]
                          [(all-width) (+ year-rec-width rec-spacing month-rec-width rec-spacing day-rec-width)]
                          [(all-height) year-rec-height])
              ;; calculate start-x start-y to make things center
              (if (>= all-width width)
                  (set! start-x 0)
                  (set! start-x (ceiling (/ (- width all-width) 2))))

              (if (>= all-height height)
                  (set! start-y 0)
                  (set! start-y (ceiling (/ (- height all-height) 2))))

              ;; use start-x and start-y above to calculate all part's coordinate.
              (let* ([button-width-ratio 3/4]
                     [button-spacing 5]
                     [button-height (ceiling (* year-rec-height 1/5))]
                     [year-rec-x start-x]
                     [year-rec-y start-y]
                     [year-x (+ year-rec-x text-horizontal-spacing)]
                     [year-y (+ year-rec-y text-vertical-spacing)]
                     [year-btn-width (* year-rec-width button-width-ratio)]
                     [year-up-x (+ year-rec-x (ceiling (/ (- year-rec-width year-btn-width) 2)))]
                     [year-up-y (- year-rec-y button-spacing)]
                     [year-down-x year-up-x]
                     [year-down-y (+ year-rec-y year-rec-height button-spacing)]
                     [month-rec-x (+ year-rec-x year-rec-width rec-spacing)]
                     [month-rec-y start-y]
                     [month-x (+ month-rec-x text-horizontal-spacing)]
                     [month-y year-y]
                     [month-btn-width (* month-rec-width button-width-ratio)]
                     [month-up-x (+ month-rec-x (ceiling (/ (- month-rec-width month-btn-width) 2)))]
                     [month-up-y (- month-rec-y button-spacing)]
                     [month-down-x month-up-x]
                     [month-down-y (+ month-rec-y month-rec-height button-spacing)]
                     [day-rec-x (+ month-rec-x month-rec-width rec-spacing)]
                     [day-rec-y start-y]
                     [day-x (+ day-rec-x text-horizontal-spacing)]
                     [day-y year-y]
                     [day-btn-width (* day-rec-width button-width-ratio)]
                     [day-up-x (+ day-rec-x (ceiling (/ (- day-rec-width day-btn-width) 2)))]
                     [day-up-y (- day-rec-y button-spacing)]
                     [day-down-x day-up-x]
                     [day-down-y (+ day-rec-y day-rec-height button-spacing)])

                (set! year-up-button
                      (new triangle% 
                           [name 'year-up]
                           [start-point-x year-up-x] [start-point-y year-up-y]
                           [width year-btn-width] [height button-height]
                           [direction 'up]
                           [down-border-color button-down-border-color]
                           [down-fill-color button-down-fill-color]
                           [up-border-color button-up-border-color]
                           [up-fill-color button-up-fill-color]))

                (set! year-down-button
                      (new triangle% 
                           [name 'year-down]
                           [start-point-x year-down-x] [start-point-y year-down-y]
                           [width year-btn-width] [height button-height]
                           [direction 'down]
                           [down-border-color button-down-border-color]
                           [down-fill-color button-down-fill-color]
                           [up-border-color button-up-border-color]
                           [up-fill-color button-up-fill-color]))

                (set! month-up-button 
                      (new triangle% 
                           [name 'month-up]
                           [start-point-x month-up-x] [start-point-y month-up-y]
                           [width month-btn-width] [height button-height]
                           [direction 'up]
                           [down-border-color button-down-border-color]
                           [down-fill-color button-down-fill-color]
                           [up-border-color button-up-border-color]
                           [up-fill-color button-up-fill-color]))

                (set! month-down-button
                      (new triangle% 
                           [name 'month-down]
                           [start-point-x month-down-x] [start-point-y month-down-y]
                           [width month-btn-width] [height button-height]
                           [direction 'down]
                           [down-border-color button-down-border-color]
                           [down-fill-color button-down-fill-color]
                           [up-border-color button-up-border-color]
                           [up-fill-color button-up-fill-color]))

                (set! day-up-button
                      (new triangle% 
                           [name 'day-up]
                           [start-point-x day-up-x] [start-point-y day-up-y]
                           [width day-btn-width] [height button-height]
                           [direction 'up]
                           [down-border-color button-down-border-color]
                           [down-fill-color button-down-fill-color]
                           [up-border-color button-up-border-color]
                           [up-fill-color button-up-fill-color]))

                (set! day-down-button
                      (new triangle% 
                           [name 'day-down]
                           [start-point-x day-down-x] [start-point-y day-down-y]
                           [width day-btn-width] [height button-height]
                           [direction 'down]
                           [down-border-color button-down-border-color]
                           [down-fill-color button-down-fill-color]
                           [up-border-color button-up-border-color]
                           [up-fill-color button-up-fill-color]))
                
                (send year-up-button draw my-dc)
                (send my-dc draw-rectangle year-rec-x year-rec-y year-rec-width year-rec-height)
                (send my-dc draw-text (get-year) year-x year-y (get-year))
                (send year-down-button draw my-dc)

                (send month-up-button draw my-dc)
                (send my-dc draw-rectangle month-rec-x month-rec-y month-rec-width month-rec-height)
                (send my-dc draw-text (get-month) month-x month-y (get-month))
                (send month-down-button draw my-dc)

                (send day-up-button draw my-dc)
                (send my-dc draw-rectangle day-rec-x day-rec-y day-rec-width day-rec-height)
                (send my-dc draw-text (get-day) day-x day-y (get-day))
                (send day-down-button draw my-dc)
              ))))
        
        (define/override (on-event mouse-event)
          (let ([event-type (send mouse-event get-event-type)]
                [button-list
                 (list year-up-button year-down-button month-up-button month-down-button day-up-button day-down-button)]
                [changed? #f])
            (case event-type
              [(motion)
               (for-each
                (λ (triangle)
                   (if (send triangle point-in? (send mouse-event get-x) (send mouse-event get-y))
                       (when (not (eq? (send triangle get-status) 'enter))
                         (set! changed? #t)
                         (send triangle set-status 'enter))
                       (when (not (eq? (send triangle get-status) 'leave))
                         (set! changed? #t)
                         (send triangle set-status 'leave)))
                   (when changed?
                     (send triangle draw (get-dc))
                     (set! changed? #f)))
                button-list)]
              [(left-down)
               (let loop ([btn-list button-list])
                 (when (not (null? btn-list))
                   (let ([triangle (car btn-list)])
                     (if (send triangle point-in? (send mouse-event get-x) (send mouse-event get-y))
                         (begin
                           (send triangle set-status 'down)
                           (send triangle draw (get-dc)))
                         (loop (cdr btn-list))))))]
              [(left-up)
               (let loop ([btn-list button-list])
                 (when (not (null? btn-list))
                   (let ([triangle (car btn-list)])
                     (if (send triangle point-in? (send mouse-event get-x) (send mouse-event get-y))
                         (begin
                           (send triangle set-status 'up)
                           (set! choosed-date
                                 (case (send triangle get-name)
                                   [(year-up) (add-year choosed-date 1)]
                                   [(year-down) (add-year choosed-date -1)]
                                   [(month-up) (add1-month choosed-date)]
                                   [(month-down) (sub1-month choosed-date)]
                                   [(day-up) (add-day choosed-date 1)]
                                   [(day-down) (add-day choosed-date -1)]))
                           (on-paint)
                           (send triangle draw (get-dc)))
                         (loop (cdr btn-list))))))]
              )))))

    (define target-panel 
      (new horizontal-panel% 
           [parent parent-gui] 
           [min-height height] 
           [min-width width]
           [stretchable-width #f]
           [stretchable-height #f]))

    (new datechooser-canvas% [parent target-panel])))