colorpicker-graphics.rkt

#lang racket/gui
(require racket/gui/base)
(require "colorpicker.rkt")
(define frame (new frame% [label "Web Safe Colors"]
                   [width 686]
                   [height 490]))

(define my-canvas%
  (class canvas%
    (super-new)))

(define (paint-hexagon canvas dc list-points list-colors)
  (define color (make-object color%
                     (* 51 (car list-colors))
                     (* 51 (car (cdr list-colors)))
                     (* 51 (car (cdr (cdr list-colors))))))

  (send dc set-pen (make-object pen% color 1 'solid))
  (send dc set-brush (make-object brush% color 'solid))
  (send dc draw-polygon list-points))

(define (paint canvas dc all-points x-orig y-orig radius)
  (for-each
   (lambda (point)
     (define hex (car point))
     (define color (car (cdr point)))
     (define hexagonVertices
       (get-hexagon-vertices radius (+ (car hex) x-orig)
                             (+ y-orig (car (cdr hex)))))
     (paint-hexagon canvas dc hexagonVertices color))
   all-points))

(define (get-hexagon-vertices r x-orig y-orig)
  (let
      ((r2 (/ r 2))
       (apothem (/ (* (sqrt 3) r) 2)))
    (list (cons (+ r x-orig) y-orig)
        (cons (+ (/ r 2) x-orig) (+ (/ (* (sqrt 3) r) -2) y-orig))
        (cons (+ (/ r -2) x-orig) (+ (/ (* (sqrt 3) r) -2) y-orig))
        (cons (- x-orig r) y-orig)
        (cons (+ (/ r -2) x-orig) (+ (/ (* (sqrt 3) r) 2) y-orig))
        (cons (+ (/ r 2) x-orig) (+ (/ (* (sqrt 3) r) 2) y-orig)))))

(define (paint-all-points canvas dc)
  (define x-orig (/ (send frame get-width) 2))
  (define y-orig (/ (send frame get-height) 2))
  (define side (* 2 (min x-orig y-orig)))
  (define LARGESIDE (/ side 4.5))
  (define radius (sqrt LARGESIDE))
  (define allLight (points-colors-listLight radius LARGESIDE))
  (define allDark (points-colors-listDark radius LARGESIDE))
  (define s (inexact->exact (round (* LARGESIDE (sqrt 3) 0.5))))
  (paint canvas dc allLight (- x-orig s) y-orig radius)
  (paint canvas dc allDark (+ s x-orig) y-orig radius)
  (display x-orig)
  (display y-orig)
  (newline))

(new my-canvas% [parent frame]
     [paint-callback paint-all-points])

(send frame show true)