(module gui-color-selection 
        mzscheme

(require (lib "class.ss") 
         (lib "mred.ss" "mred")
         (lib "framework.ss" "framework")
         (lib "defmacro.ss")
)

(provide gui-color-selection
         gui-color-list
)

; -------------------------------------------------------------------

(define gui-color-list
  '#(
    (255 0 0) ; 1
    (255 255 0) ; 2
    (0 255 0) ; 3
    (0 255 255) ; 4
    (0 0 255) ; 5
    (255 0 255) ; 6
    (255 255 255) ; 7
    (128 128 128) ; 8
    (192 192 192) ; 9

    (255 0 0) ; 10
    (255 127 127) ; 11
    (204 0 0) ; 12
    (204 102 102) ; 13
    (153 0 0) ; 14
    (153 76 76) ; 15
    (127 0 0) ; 16
    (127 63 63) ; 17
    (76 0 0) ; 18
    (76 38 38) ; 19


    (255 63 0) ; 20
    (255 159 127) ; 21
    (204 51 0) ; 22
    (204 127 102) ; 23
    (153 38 0) ; 24
    (153 95 76) ; 25
    (127 31 0) ; 26
    (127 79 63) ; 27
    (76 19 0) ; 28
    (76 47 38) ; 29

    (255 127 0) ; 30
    (255 191 127) ; 31
    (204 102 0) ; 32
    (204 153 102) ; 33
    (153 76 0) ; 34
    (153 114 76) ; 35
    (127 63 0) ; 36
    (127 95 63) ; 37
    (76 38 0) ; 38
    (76 57 38) ; 39

    (255 191 0) ; 40
    (255 223 127) ; 41
    (204 153 0) ; 42
    (204 178 102) ; 43
    (153 114 0) ; 44
    (153 133 76) ; 45
    (127 95 0) ; 46
    (127 111 63) ; 47
    (76 57 0) ; 48
    (76 66 38) ; 49

    (255 255 0) ; 50
    (255 255 127) ; 51
    (204 204 0) ; 52
    (204 204 102) ; 53
    (153 153 0) ; 54
    (153 153 76) ; 55
    (127 127 0) ; 56
    (127 127 63) ; 57
    (76 76 0) ; 58
    (76 76 38) ; 59

    (191 255 0) ; 60
    (223 255 127) ; 61
    (153 204 0) ; 62
    (178 204 102) ; 63
    (114 153 0) ; 64
    (133 153 76) ; 65
    (95 127 0) ; 66
    (111 127 63) ; 67
    (57 76 0) ; 68
    (66 76 38) ; 69

    (127 255 0) ; 70
    (191 255 127) ; 71
    (102 204 0) ; 72
    (153 204 102) ; 73
    (76 153 0) ; 74
    (114 153 76) ; 75
    (63 127 0) ; 76
    (95 127 63) ; 77
    (38 76 0) ; 78
    (57 76 38) ; 79

    (63 255 0) ; 80
    (159 255 127) ; 81
    (51 204 0) ; 82
    (127 204 102) ; 83
    (38 153 0) ; 84
    (95 153 76) ; 85
    (31 127 0) ; 86
    (79 127 63) ; 87
    (19 76 0) ; 88
    (47 76 38) ; 89

    (0 255 0) ; 90
    (127 255 127) ; 91
    (0 204 0) ; 92
    (102 204 102) ; 93
    (0 153 0) ; 94
    (76 153 76) ; 95
    (0 127 0) ; 96
    (63 127 63) ; 97
    (0 76 0) ; 98
    (38 76 38) ; 99

    (0 255 63) ; 100
    (127 255 159) ; 101
    (0 204 51) ; 102
    (102 204 127) ; 103
    (0 153 38) ; 104
    (76 153 95) ; 105
    (0 127 31) ; 106
    (63 127 79) ; 107
    (0 76 19) ; 108
    (38 76 47) ; 109

    (0 255 127) ; 110
    (127 255 191) ; 111
    (0 204 102) ; 112
    (102 204 153) ; 113
    (0 153 76) ; 114
    (76 153 114) ; 115
    (0 127 63) ; 116
    (63 127 95) ; 117
    (0 76 38) ; 118
    (38 76 57) ; 119

    (0 255 191) ; 120
    (127 255 223) ; 121
    (0 204 153) ; 122
    (102 204 178) ; 123
    (0 153 114) ; 124
    (76 153 133) ; 125
    (0 127 95) ; 126
    (63 127 111) ; 127
    (0 76 57) ; 128
    (38 76 66) ; 129

    (0 255 255) ; 130
    (127 255 255) ; 131
    (0 204 204) ; 132
    (102 204 204) ; 133
    (0 153 153) ; 134
    (76 153 153) ; 135
    (0 127 127) ; 136
    (63 127 127) ; 137
    (0 76 76) ; 138
    (38 76 76) ; 139

    (0 191 255) ; 140
    (127 223 255) ; 141
    (0 153 204) ; 142
    (102 178 204) ; 143
    (0 114 153) ; 144
    (76 133 153) ; 145
    (0 95 127) ; 146
    (63 111 127) ; 147
    (0 57 76) ; 148
    (38 66 76) ; 149

    (0 127 255) ; 150
    (127 191 255) ; 151
    (0 102 204) ; 152
    (102 153 204) ; 153
    (0 76 153) ; 154
    (76 114 153) ; 155
    (0 63 127) ; 156
    (63 95 127) ; 157
    (0 38 76) ; 158
    (38 57 76) ; 159

    (0 63 255) ; 160
    (127 159 255) ; 161
    (0 51 204) ; 162
    (102 127 204) ; 163
    (0 38 153) ; 164
    (76 95 153) ; 165
    (0 31 127) ; 166
    (63 79 127) ; 167
    (0 19 76) ; 168
    (38 47 76) ; 169

    (0 0 255) ; 170
    (127 127 255) ; 171
    (0 0 204) ; 172
    (102 102 204) ; 173
    (0 0 153) ; 174
    (76 76 153) ; 175
    (0 0 127) ; 176
    (63 63 127) ; 177
    (0 0 76) ; 178
    (38 38 76) ; 179

    (63 0 255) ; 180
    (159 127 255) ; 181
    (51 0 204) ; 182
    (127 102 204) ; 183
    (38 0 153) ; 184
    (95 76 153) ; 185
    (31 0 127) ; 186
    (79 63 127) ; 187
    (19 0 76) ; 188
    (47 38 76) ; 189

    (127 0 255) ; 190
    (191 127 255) ; 191
    (102 0 204) ; 192
    (153 102 204) ; 193
    (76 0 153) ; 194
    (114 76 153) ; 195
    (63 0 127) ; 196
    (95 63 127) ; 197
    (38 0 76) ; 198
    (57 38 76) ; 199

    (191 0 255) ; 200
    (223 127 255) ; 201
    (153 0 204) ; 202
    (178 102 204) ; 203
    (114 0 153) ; 204
    (133 76 153) ; 205
    (95 0 127) ; 206
    (111 63 127) ; 207
    (57 0 76) ; 208
    (66 38 76) ; 209

    (255 0 255) ; 210
    (255 127 255) ; 211
    (204 0 204) ; 212
    (204 102 204) ; 213
    (153 0 153) ; 214
    (153 76 153) ; 215
    (127 0 127) ; 216
    (127 63 127) ; 217
    (76 0 76) ; 218
    (76 38 76) ; 219

    (255 0 191) ; 220
    (255 127 223) ; 221
    (204 0 153) ; 222
    (204 102 178) ; 223
    (153 0 114) ; 224
    (153 76 133) ; 225
    (127 0 95) ; 226
    (127 63 111) ; 227
    (76 0 57) ; 228
    (76 38 66) ; 229

    (255 0 127) ; 230
    (255 127 191) ; 231
    (204 0 102) ; 232
    (204 102 153) ; 233
    (153 0 76) ; 234
    (153 76 114) ; 235
    (127 0 63) ; 236
    (127 63 95) ; 237
    (76 0 38) ; 238
    (76 38 57) ; 239

    (255 0 63) ; 240
    (255 127 159) ; 241
    (204 0 51) ; 242
    (204 102 127) ; 243
    (153 0 38) ; 244
    (153 76 95) ; 245
    (127 0 31) ; 246
    (127 63 79) ; 247
    (76 0 19) ; 248
    (76 38 47) ; 249

    (51 51 51) ; 250
    (91 91 91) ; 251
    (132 132 132) ; 252
    (173 173 173) ; 253
    (214 214 214) ; 254
    (255 255 255) ; 255

  )
)


(define color-index-list
  '#(
      #( 18  28  38  48  58  68  78  88  98  108 118 128
         138 148 158 168 178 188 198 208 218 228 238 248
       ) ; 1
      #( 16  26  36  46  56  66  76  86  96  106 116 126
         136 146 156 166 176 186 196 206 216 226 236 246
       ) ; 2
      #( 14  24  34  44  54  64  74  84  94  104 114 124
         134 144 154 164 174 184 194 204 214 224 234 244
       ) ; 3
      #( 12  22  32  42  52  62  72  82  92  102 112 122
         132 142 152 162 172 182 192 202 212 222 232 242
       ) ; 4
      #( 10  20  30  40  50  60  70  80  90  100 110 120
         130 140 150 160 170 180 190 200 210 220 230 240
       ) ; 5
      ; -------------------------------------------------
      #( 11  21  31  41  51  61  71  81  91  101 111 121
         131 141 151 161 171 181 191 201 211 221 231 241
       ) ; 6
      #( 13  23  33  43  53  63  73  83  93  103 113 123
         133 143 153 163 173 183 193 203 213 223 233 243
       ) ; 7
      #( 15  25  35  45  55  65  75  85  95  105 115 125
         135 145 155 165 175 185 195 205 215 225 235 245
       ) ; 8
      #( 17  27  37  47  57  67  77  87  97  107 117 127
         137 147 157 167 177 187 197 207 217 227 237 247
       ) ; 9
      #( 19  29  39  49  59  69  79  89  99  109 119 129
         139 149 159 169 179 189 199 209 219 229 239 249
       ) ; 10
    )
)

; special colors
(define color-list-11
  '(1 2 3 4 5 6 7 8 9)
)
(define color-list-12
  '(250 251 252 253 254 255)
)

; -------------------------------------------------------------------

(define color-canvas%
  (class* canvas% ()
    
    (init-field (callback #f))

    (define size 14)
    (define off  4)
    (define over #f)
    
    ; drawing one row of colors
    (define (color-row y color-vector)
      (let*
        ( (x (/ off 2))
          (n (vector-length color-vector))
        )
        (do ((i 0 (+ i 1))) ((= i n))
          (let*
            ( (index (vector-ref color-vector i))
              (color (vector-ref gui-color-list (- index 1)))
              (r (list-ref color 0))
              (g (list-ref color 1))
              (b (list-ref color 2))
              (bg (make-object color% r g b))
              (dc (send this get-dc))
            )
            (send dc set-pen (send the-pen-list find-or-create-pen
                             bg 1 'solid))
            (send dc set-brush (send the-brush-list find-or-create-brush
                               bg 'solid))
            (send dc draw-rectangle x y size size)
            (set! x (+ x size off))
          )
        )
      )
    )
    
    ; draws a rectangle around the color
    (define (draw-rect ix iy dc color)
      (let*
        ( (lx (* ix (+ size off)))
          (ly (* iy (+ size off)))
          (ux (+ lx size off))
          (uy (+ ly size off))
        )
        (send dc set-pen (send the-pen-list find-or-create-pen
                               color 2 'solid))
        (send dc draw-line lx ly ux ly)
        (send dc draw-line ux ly ux uy)
        (send dc draw-line ux uy lx uy)
        (send dc draw-line lx uy lx ly)
      )
    )
    
    ; drawing the full canvas
    (define/override (on-paint)
      (let*
        ( (y  (/ off 2))
          (w  (send this get-width))
          (h  (send this get-height))
          (dc (send this get-dc))
          (bg (get-panel-background))
        )
        (send dc set-pen (send the-pen-list find-or-create-pen
                         bg 2 'solid))
        (send dc set-brush (send the-brush-list find-or-create-brush
                           bg 'solid))
        (send dc draw-rectangle 0 0 w h)
        ; 10 color rows
        (do ((i 0 (+ i 1))) ((= i 10))
          (color-row y (vector-ref color-index-list i))
          (set! y (+ y size off))
        )
      
      )
    ) ; on-paint
    
    ; if an event happens, deal with it here
    (define/override (on-event e)
      (let*
        ( (mx  (send e get-x)) ; position of the mouse
          (my  (send e get-y))
          ; row and column numbers in the canvas
          (ix  (floor (/ mx (+ size off))))
          (iy  (floor (/ my (+ size off))))
          ; max row number
          (ny  (- (vector-length color-index-list) 1))
          ; color numbers in the row
          (row (if (<= 0 iy ny)
                 (vector-ref color-index-list iy) 
                 #f))
          ; max number of colors in the row
          (nx  (if row (- (vector-length row) 1) 0))
          ; identification number of the color
          (id  (if (and row (<= 0 ix nx)) 
                 (vector-ref row ix)
                 #f))
          (rgb (if id (vector-ref gui-color-list (- id 1)) #f))
          (dc  (send this get-dc))
          (se  (make-object color% 0 0 0))
          (bg  (get-panel-background))
        )
        (cond
          ( (equal? (send e get-event-type) 'motion)
            (if over
              (draw-rect (list-ref over 0) (list-ref over 1) dc bg)
            )
            (draw-rect ix iy dc se)
            (set! over (list ix iy))
          )
          ( (equal? (send e get-event-type) 'leave)
            (if over
              (draw-rect (list-ref over 0) (list-ref over 1) dc bg)
            )
            (set! over #f)
          )
        ) ; end of motion
        ; user defined callback function
        (if callback
          (callback e id rgb)
        )
      )
    ) ; end of on-event

    (super-instantiate () 
      (style '(control-border))
      (stretchable-width #f)
      (stretchable-height #f)
      (min-width (+ 4 (* 24 (+ size off))))
      (min-height (+ 4 (* 10 (+ size off))))
    )
  
  )
)

; -------------------------------------------------------------------

(define color-large-canvas%
  (class* canvas% ()
    
    ; initial fields
    (init-field (red 0) 
                (green 0) 
                (blue 0) 
                (callback #f)
    )

    ; private colors
    (define outline-color (make-object color% "BLACK"))
    (define back-color    (make-object color% red green blue))

    ; this method sets the background color of the canvas
    (define/public (set-color! r g b)
      (set! back-color (make-object color% r g b))
      (queue-callback (lambda () (send this on-paint)) #t)
    )
     
    ; callback when painting the canvas
    (define/override (on-paint)
      (let* ( (dc (send this get-dc))
              (width  (send this get-width))
              (height (send this get-height))
            )
        (send dc set-pen (send the-pen-list find-or-create-pen
                         back-color 3 'solid))
        (send dc set-brush (send the-brush-list find-or-create-brush
                           back-color 'solid))
        (send dc draw-rectangle 0 0 (- width 4) (- height 4))
      )
    ) ; end of on-paint
    
    ; callback for other events
    (define/override (on-event e)
      (cond
        ( (equal? (send e get-event-type) 'enter)
          (let* 
            ( (dc (send this get-dc))
              (width  (send this get-width))
              (height (send this get-height))
            )
            (send dc set-pen (send the-pen-list find-or-create-pen
                             outline-color 3 'solid))
            (send dc set-brush (send the-brush-list find-or-create-brush
                               back-color 'solid))
            (send dc draw-rectangle 0 0 (- width 4) (- height 4))
          )
        )
        ( (equal? (send e get-event-type) 'leave)
          (queue-callback (lambda () (send this on-paint)) #t)
        )
      )
      ; call the users callback function if it exists
      (if callback
        (callback this e)
      )
    ) ; end of on-event

    (super-instantiate () 
      (style '(control-border)) 
      (stretchable-width #f)
      (stretchable-height #f)
    )
    
  )
)

; -------------------------------------------------------------------

(define-macro (color-row size parent color-list)
   `(for-each
      (lambda (index)
        (let*
          ( (rgb (vector-ref gui-color-list (- index 1)) ) )
          (new color-large-canvas%
               (parent ,parent)
               (red   (list-ref rgb 0)) 
               (green (list-ref rgb 1)) 
               (blue  (list-ref rgb 2))
               (min-width  ,size) 
               (min-height ,size)
               (callback
                 (lambda (w e)
                   (cond
                     ; left mouse button is pressed, select the color
                     ( (equal? (send e get-event-type) 'left-down)
                       (print-color-when-selected index rgb)
                     )
                     ; when the mouse enters the canvas, display information
                     ( (equal? (send e get-event-type) 'enter)
                       (print-color-when-enter index rgb)
                     )
                     ; when the mouse leaves the canvas delete everything
                     ( (equal? (send e get-event-type) 'leave)
                       (print-color-when-leave index rgb)
                     )
                   )
                 )
               ) ; end of callback
          ) ; end of new canvas
        ) ; end of let*
      ) ; end of lambda
      ,color-list
    )
)



(define (gui-color-selection)
  (letrec
    ( (result #f)
      (selected #f)
      (dialog (new dialog% 
                   (label "Color selection")
                   (min-width 20)
                   (min-height 20)
                   (border 5)
                   ))
      (group1 (new group-box-panel% 
                   (parent dialog)
                   (label "Color properties")
      ))
      (proppanel (new horizontal-panel% 
                      (parent group1)
                      (border 3)
      ))
      (color-index (new message%
                        (parent proppanel)
                        (label "")
                        (min-width 150)
      ))
      (color-rgb (new message%
                      (parent proppanel)
                      (label "")
                      (min-width 190)
      ))
      ; ---------------------------------
      (print-color-when-enter
        (lambda (id rgb)
          (if (and id rgb)
            (begin
              (send color-index set-label 
                    (string-append "Color index: "
                                   (number->string id)))
              (send color-rgb set-label 
                    (string-append "Red, Green, Blue: "
                                   (number->string (list-ref rgb 0)) ","
                                   (number->string (list-ref rgb 1)) ","
                                   (number->string (list-ref rgb 2))))
            )
          )
        )
      )
      (print-color-when-leave
        (lambda (id rgb)
          (send color-index set-label "")
          (send color-rgb   set-label "")
        )
      )
      (print-color-when-selected
        (lambda (id rgb)
          (if (and id rgb)
            (begin
              (send indextext set-label (number->string id))
              (send redtext   set-value (number->string (list-ref rgb 0)))
              (send greentext set-value (number->string (list-ref rgb 1)))
              (send bluetext  set-value (number->string (list-ref rgb 2)))
              (send color-canvas set-color!
                                 (list-ref rgb 0)
                                 (list-ref rgb 1)
                                 (list-ref rgb 2))
            )
          )
        )
      )
      ; ---------------------------------
      (group2  (new group-box-panel% (parent dialog) (label "Color list") ))
      (v1 (new vertical-panel% 
               (parent group2) 
               (border 5)
               (stretchable-width #f)
               (stretchable-height #f)
      ))
      (cl (new color-canvas%
               (parent v1)
               (callback 
                 (lambda (e id rgb)
                   (cond
                     ; left mouse button is pressed, select the color
                     ( (equal? (send e get-event-type) 'left-down)
                       ; display the selected color below the list
                       (print-color-when-selected id rgb)
                     )
                     ( (equal? (send e get-event-type) 'motion)
                       (print-color-when-enter id rgb)
                     )
                     ; when the mouse leaves the canvas delete everything
                     ( (equal? (send e get-event-type) 'leave)
                       (print-color-when-leave id rgb)
                     )
                   )
                 )
               )
      ))

      (v3  (new vertical-panel% 
                (parent group2) 
                (border 5)
                (alignment '(left top))
                (stretchable-width #f)
                (stretchable-height #f)
      ))
      (h11 (new horizontal-panel% (parent v3) ))
      (h12 (new horizontal-panel% (parent v3) ))

      ; Selected color group
      (group3  (new group-box-panel% (parent dialog) (label "Selected color") ))
      (indexpanel (new horizontal-panel% (parent group3) (border 3) ))
        (indexlabel (new message% 
                        (label "Index: ")
                        (min-width 50)
                        (parent indexpanel)
        ))
        (indextext (new message% 
                        (label "")
                        (min-width 50)
                        (parent indexpanel)
        ))
      
      (selectedpanel (new horizontal-panel% 
                          (parent group3)
      ))
      ; Red-Green-Blue components of the selected color
      (comppanel  (new vertical-panel% 
                       (parent selectedpanel)
                       (stretchable-width #f)
      ))
      (redpanel (new horizontal-panel% (parent comppanel)))
      (redlabel (new message% 
                     (parent redpanel) 
                     (label "Red:") 
                     (min-width 50) ))
      (redtext  (new text-field% 
                     (parent redpanel) 
                     (label "")
                     (min-width 70)
                     (callback (lambda (w e) (send indextext set-label "")))
      ))
      (greenpanel (new horizontal-panel% (parent comppanel)))
      (greenlabel (new message% 
                       (parent greenpanel) 
                       (label "Green:") 
                       (min-width 50) ))
      (greentext  (new text-field% 
                       (parent greenpanel) 
                       (label "")
                       (min-width 70)
                       (callback (lambda (w e) (send indextext set-label "")))
      ))
      (bluepanel (new horizontal-panel% (parent comppanel)))
      (bluelabel (new message% 
                      (parent bluepanel) 
                      (label "Blue:") 
                      (min-width 50) ))
      (bluetext  (new text-field% 
                     (parent bluepanel) 
                     (label "")
                     (min-width 70)
                     (callback (lambda (w e) (send indextext set-label "")))
      ))
      
      ; Selected color canvas
      (vc (new vertical-panel% (parent selectedpanel)))
      (color-canvas (new color-large-canvas%
                         (parent vc)
                         (red   255) 
                         (green 255) 
                         (blue  255)
                         (min-width  60) 
                         (min-height 60)
      ))
      ; if the red, green, blue components are correct, so the color is valid
      ; delete the index and update the color canvas
      (update-button (new button%
                          (parent vc)
                          (label "Update") 
                          (min-width 80)
                          (callback 
                            (lambda (w e)
                              (let*
                                ( (r (string->number (send redtext   get-value)))
                                  (g (string->number (send greentext get-value)))
                                  (b (string->number (send bluetext  get-value)))
                                )
                                (if (and r g b
                                         (integer? r) (exact? r)
                                         (integer? g) (exact? g)
                                         (integer? b) (exact? b)
                                         (<= 0 r 255)
                                         (<= 0 g 255)
                                         (<= 0 b 255))
                                  (send color-canvas set-color! r g b)
                                )
                              )
                              (send indextext set-label "")
                            )
                          )
      ))

      ; OK and CANCEL button
      (button-group (new horizontal-panel% 
                         (parent dialog) 
                         (alignment '(center bottom))
      ))
      (button-ok 
        (new button% 
             (parent button-group) 
             (label "Ok")
             (min-width 80)
             (callback 
               (lambda (b e)
                 (let*
                   ( (r (string->number (send redtext   get-value)))
                     (g (string->number (send greentext get-value)))
                     (b (string->number (send bluetext  get-value)))
                     (i (string->number (send indextext get-label)))
                   )
                   (if (and r g b
                            (integer? r) (exact? r)
                            (integer? g) (exact? g)
                            (integer? b) (exact? b)
                            (<= 0 r 255)
                            (<= 0 g 255)
                            (<= 0 b 255))
                     (if i
                       (begin
                         (set! result (list (- i 1)))
                         (send dialog show #f)
                       )
                       (begin
                         (set! result 
                               (list (/ r 255.0) 
                                     (/ g 255.0)
                                     (/ b 255.0) 
                                     0.75))
                         (send dialog show #f)
                       )
                     )
                   )
                 )
               )
             )
      ))
      (button-cancel (new button% 
                          (parent button-group) 
                          (label "Cancel")
                          (min-width 80)
                          (callback (lambda (b e) (send dialog show #f)))
      ))
    
    )
    
    ; create the two special color row
    (color-row 25 h11 color-list-11)
    (color-row 25 h12 color-list-12)

    (send dialog show #t)

    result
  )
)

) ; end of module

; (gui-color-selection)