Skip to content

Instantly share code, notes, and snippets.

@m039
Last active Jan 28, 2017
Embed
What would you like to do?
Exercise 37.1 form the HtDPv1 book. A little bit overdone though.
#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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment