#lang racket/base

(require racket/class racket/draw
         racket/contract unstable/latent-contract unstable/latent-contract/defthing
         "../private/flomap.rkt"
         "../private/deep-flomap.rkt"
         "../private/utils.rkt"
         "arrow.rkt"
         "style.rkt")

(provide (activate-contract-out
          floppy-disk-icon floppy-disk-flomap
          save-icon save-flomap
          load-icon load-flomap
          small-save-icon small-save-flomap
          small-load-icon small-load-flomap)
         (only-doc-out (all-defined-out)))

(defproc (floppy-disk-flomap [color (or/c string? (is-a?/c color%))]
                             [height (and/c rational? (>=/c 0)) (default-icon-height)]
                             [material deep-flomap-material-value? (default-icon-material)]
                             ) flomap?
  (make-cached-flomap
   [height color material]
   (define scale (/ height 32))
   
   (define metal-fm
     (let* ([fm  (draw-icon-flomap
                  18 11 (λ (dc)
                          (send dc set-background "lightgray")
                          (define outer-path (new dc-path%))
                          (send outer-path rounded-rectangle 0.5 0.5 13 12 1)
                          (define inner-path (new dc-path%))
                          (send inner-path rectangle 2.5 2.5 4 6)
                          (define outer-rgn (new region%))
                          (send outer-rgn set-path outer-path)
                          (define inner-rgn (new region%))
                          (send inner-rgn set-path inner-path)
                          (send outer-rgn subtract inner-rgn)
                          (send dc set-clipping-region outer-rgn)
                          (send dc clear))
                  scale)]
            [dfm  (flomap->deep-flomap fm)]
            [dfm  (deep-flomap-icon-style dfm)]
            [dfm  (deep-flomap-scale-z dfm 1/16)])
       (deep-flomap-render-icon dfm metal-icon-material)))
   
   (define bottom-indent-fm
     (draw-icon-flomap
      20 11 (λ (dc)
              (send dc set-alpha 1/4)
              (send dc set-pen "black" 1 'transparent)
              (send dc set-brush "black" 'solid)
              (send dc draw-rounded-rectangle 1.5 0.5 18 11 1))
      scale))
   
   (define label-fm
     (let* ([fm  (draw-icon-flomap
                  22 20 (λ (dc)
                          (send dc set-pen "black" 1 'transparent)
                          (send dc set-brush "black" 'solid)
                          (send dc draw-rounded-rectangle -0.5 -3.5 22 21 3)
                          (send dc set-brush "lemonchiffon" 'solid)
                          (send dc draw-rounded-rectangle 0.5 -3.5 20 20 2)
                          (send dc set-brush "chocolate" 'solid)
                          (send dc draw-rectangle 0.5 -0.5 20 4)
                          (send dc set-brush "navy" 'solid)
                          (for ([i  (in-range 5.5 15 3)])
                            (send dc draw-rectangle 2.5 i 16 1)))
                  scale)]
            [dfm  (flomap->deep-flomap fm)]
            [dfm  (deep-flomap-bulge-vertical dfm (* 2 scale))])
       (deep-flomap-render-icon dfm matte-material)))
   
   (define top-indent-fm
     (draw-icon-flomap
      22 19 (λ (dc)
              (send dc set-alpha 1)
              (send dc set-pen "black" 1 'transparent)
              (send dc set-brush "black" 'solid)
              (send dc draw-rounded-rectangle -0.5 -2.5 22 20 2.5))
      scale))
   
   (define case-fm
     (draw-icon-flomap
      32 32 (λ (dc)
              (set-icon-pen dc (icon-color->outline-color color) 1 'solid)
              (send dc set-brush color 'solid)
              (send dc draw-polygon (list '(0 . 3) '(3 . 0)
                                          '(28 . 0) '(31 . 3)
                                          '(31 . 28) '(28 . 31)
                                          '(3 . 31) '(0 . 28))))
      scale))
   
   (define disk-fm
     (let* ([dfm  (deep-flomap-ct-superimpose
                   'add
                   (deep-flomap-cb-superimpose
                    'add
                    (flomap->deep-flomap case-fm)
                    (deep-flomap-raise (flomap->deep-flomap bottom-indent-fm) (* -4 scale)))
                   (deep-flomap-raise (flomap->deep-flomap top-indent-fm) (* -1 scale)))]
            [dfm  (deep-flomap-icon-style dfm)])
       (deep-flomap-render-icon dfm material)))
   
   (let* ([fm  (flomap-cb-superimpose disk-fm metal-fm)]
          [fm  (flomap-ct-superimpose fm label-fm)])
     fm)))

(defproc (save-flomap [arrow-color (or/c string? (is-a?/c color%))]
                      [color (or/c string? (is-a?/c color%))]
                      [height (and/c rational? (>=/c 0)) (default-icon-height)]
                      [material deep-flomap-material-value? (default-icon-material)]
                      ) flomap?
  (flomap-hc-append (right-arrow-flomap arrow-color (* 3/4 height) material)
                    (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0)
                    (floppy-disk-flomap color height material))) 

(defproc (load-flomap [arrow-color (or/c string? (is-a?/c color%))]
                      [color (or/c string? (is-a?/c color%))]
                      [height (and/c rational? (>=/c 0)) (default-icon-height)]
                      [material deep-flomap-material-value? (default-icon-material)]
                      ) flomap?
  (flomap-hc-append (floppy-disk-flomap color height material)
                    (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0)
                    (right-arrow-flomap arrow-color (* 3/4 height) material)))

(defproc (small-save-flomap [arrow-color (or/c string? (is-a?/c color%))]
                            [color (or/c string? (is-a?/c color%))]
                            [height (and/c rational? (>=/c 0)) (default-icon-height)]
                            [material deep-flomap-material-value? (default-icon-material)]
                            ) flomap?
  (flomap-pin* 0 0 11/16 0
               (floppy-disk-flomap color height material)
               (right-arrow-flomap arrow-color (* 3/4 height) material)))

(defproc (small-load-flomap [arrow-color (or/c string? (is-a?/c color%))]
                            [color (or/c string? (is-a?/c color%))]
                            [height (and/c rational? (>=/c 0)) (default-icon-height)]
                            [material deep-flomap-material-value? (default-icon-material)]
                            ) flomap?
  (flomap-pin* 1 1 5/16 1
               (floppy-disk-flomap color height material)
               (right-arrow-flomap arrow-color (* 3/4 height) material)))

(define-icon-wrappers
  ([color (or/c string? (is-a?/c color%))]
   [height (and/c rational? (>=/c 0)) (default-icon-height)]
   [material deep-flomap-material-value? (default-icon-material)])
  [floppy-disk-icon floppy-disk-flomap])

(define-icon-wrappers
  ([arrow-color (or/c string? (is-a?/c color%))]
   [color (or/c string? (is-a?/c color%))]
   [height (and/c rational? (>=/c 0)) (default-icon-height)]
   [material deep-flomap-material-value? (default-icon-material)])
  [save-icon save-flomap]
  [load-icon load-flomap]
  [small-save-icon small-save-flomap]
  [small-load-icon small-load-flomap])
