Exercise 37.1 form the HtDPv1 book. A little bit overdone though.

37.1.rkt

#lang racket/gui

;;; Exercise 37.1 from the HtDP book. A little bit overdone.

;;;
;;; GUI related functions
;;; 

(define (create-frame title size draw-callback on-event-handler)
  (define custom-canvas%
    (class canvas% 

      (define/override (on-event event)
        (with-handlers [(exn:fail?
                         (lambda (e)
                           (displayln (format "Got error! ~s" e))))]
          (when (on-event-handler this (send this get-dc) event)
            (send this refresh))))
      
      (super-new)))
  
  (let [(frame (new frame%
                    [label title]
                    [width (first size)]
                    [height (second size)]))]
    (new custom-canvas%
       [parent frame]
       [paint-callback
        (lambda (canvas dc)
          (with-handlers [(exn:fail?
                           (lambda (e)
                             (displayln (format "Got error! ~s" e))))]
            (draw-callback canvas dc)))])
    frame))

(define (show-frame frame)
  (send frame show #t))

(define (hide-frame frame)
  (send frame show #f))

;;;
;;; Main
;;;

(define *number-of-columns* 2)

(define *inner-space-size* 1)

(define *border-size* 5)

(define *title-weight* 0.2)

;;; Colors

(define *colors*
  '(black white red blue green gold pink orange purple navy))

(define (color-name color)
  (symbol->string color))

;;; Picked colors

(define *picked-colors*
  '())

(define (is-color-picked? color)
  (if (member color *picked-colors*) #t #f))

;;; pick-color: color => void
;;; it is possible to pick one color several times
(define (pick-color color)
  (set! *picked-colors* (append *picked-colors* (list color))))

(define (unpick-color color)
  (set! *picked-colors* (remv color *picked-colors*)))

(define (clear-picked-colors)
  (set! *picked-colors* '()))

;;; Target colors

(define *target-colors*
  '())

(define (make-target-colors)
  (letrec [(random-pick
            (lambda (lst)
              (list-ref lst (random (length lst)))))]
   (set! *target-colors*
     (list
      (random-pick *colors*)
      (random-pick *colors*)))))

;;; Information Label

(define *information-label* "Try to guess colors!")

(define (update-information-label guess)
  (set! *information-label* (string-append
                             (case guess
                               [(perfect)
                                "You has a perfect guess!"]
                               [(one-color-at-correct-position)
                                "You guessed one color at correct position!"]
                               [(one-color-occurs)
                                "You gueesed one color!"]
                               [(nothing-correct)
                                "You gueesed nothing."])
                             " Try again!")))

;;; Check color function

;;; check-color: (list of colors) (list of colors) => symbol
;;; Checks if picked colors in target colors and returns one of valid symbols.
(define (check-color target-colors picked-colors)
  (let [(t1 (first target-colors))
        (t2 (second target-colors))
        (p1 (first picked-colors))
        (p2 (second picked-colors))]
    (cond
     [(and (equal? t1 p1) (equal? t2 p2)) 'perfect]
     [(or (equal? t1 p1) (equal? t2 p2)) 'one-color-at-correct-position]
     [(or (equal? t1 p2) (equal? t2 p1)) 'one-color-occurs]
     [else 'nothing-correct])))

(define (on-event-handler canvas dc event)
  (when (equal? (send event get-event-type) 'left-up)
    (let [(x (send event get-x))
          (y (send event get-y))]
      (let loop [(i 0)
                 (cs *colors*)]
        
        (when (pair? cs)
          (when (hit-rectangle? dc i x y)
            (pick-color (first cs)))
          (loop (add1 i) (rest cs))))

      (when (>= (length *picked-colors*) 2)
        (let [(guess (check-color *target-colors* *picked-colors*))]
          (update-information-label guess)
          (clear-picked-colors)

          (when (equal? guess 'perfect)
           (make-target-colors)))))
    
    true))

;;; get-rectangle-bounds: dc => x y width height
;;; 'index' is position of color in *colors*
(define (get-rectangle-bounds dc index)
  (let-values [((dc-w dc-h) (send dc get-size))]
    (let* [(colors-length (length *colors*))
           (number-of-columns *number-of-columns*)
           (number-of-rows (let-values [((q r)
                                         (quotient/remainder
                                          colors-length
                                          number-of-columns))]
                             (if (> r 0)
                                 (add1 q)
                                 q)))
           (th (* dc-h *title-weight*))
           (rw (/ dc-w number-of-columns))
           (rh (/ (- dc-h th) number-of-rows))
           (left (* (quotient index number-of-rows) rw))
           (top (+ th (* (remainder index number-of-rows) rh)))]
      (values left top rw rh))))

(define (hit-rectangle? dc index x y)
  (let-values ([(rx ry w h) (get-rectangle-bounds dc index)])
    (and (<= rx x (+ rx w))
         (<= ry y (+ ry h)))))

(define (draw-callback canvas dc)
  (let-values [((dc-w dc-h) (send dc get-size))]
    (letrec [(*title-weight* 0.2)
             (draw-title
              (lambda (text)
                (send dc set-text-foreground "black")
                (send dc set-font (make-font #:size 14))
                (let-values ([(w h _1 _2) (send dc get-text-extent text)])
                  (send dc draw-text text
                        (/ (- dc-w w) 2)
                        (/ (- (* dc-h *title-weight*) h) 2)))))
             
             (draw-color-button
              (lambda (index color selected)
                (let [(th (* dc-h *title-weight*))]
                  (send dc set-pen "" 0 'transparent)

                  (let-values ([(x y w h) (get-rectangle-bounds dc index)])
                    (cond
                     [selected
                      (send dc set-brush "black" 'solid)
                      (send dc draw-rectangle
                            (+ x *inner-space-size*)
                            (+ y *inner-space-size*)
                            (- w (* *inner-space-size* 2))
                            (- h (* *inner-space-size* 2)))
                      (send dc set-brush color 'solid)
                      (send dc draw-rectangle
                            (+ x *border-size*)
                            (+ y *border-size*)
                            (- w (* *border-size* 2))
                            (- h (* *border-size* 2)))]
                     [else
                      (send dc set-brush color 'solid)
                      (send dc draw-rectangle
                            (+ x *border-size*)
                            (+ y *border-size*)
                            (- w (* *border-size* 2))
                            (- h (* *border-size* 2)))])))))]

      (send dc set-background "white")
      (send dc clear)
      (draw-title *information-label*)

      (let loop [(i 0)
                 (cs *colors*)]
        (when (pair? cs)
          (draw-color-button i
                             (color-name (first cs))
                             (is-color-picked? (first cs)))
          (loop (add1 i) (rest cs)))))))


(define frame (create-frame
               "Guessing colors"
               '(400 600)
               (lambda (canvas dc)
                 (draw-callback canvas dc))
               (lambda (canvas dc event)
                 (on-event-handler canvas dc event))))

(clear-picked-colors)
(make-target-colors)

(show-frame frame)