| PasteRack.org | ||
| Paste # 58746 | ||
| 2020-05-22 12:13:06 | ||
Fork as a new paste. | ||
Paste viewed 524 times. | ||
Tweet | ||
Embed: | ||
#lang racket/gui
;;---------------------------------------------------------------------------------------------------
(define eyes-canvas%
(class canvas%
(init-field (eye-diameter 100))
(inherit refresh client->screen screen->client get-top-level-window)
(define pupil-diameter (/ eye-diameter 3))
(define pupil-r (* 1/2 pupil-diameter))
(define r (/ eye-diameter 2))
(define eye-x r)
(define eye-y r)
(define/override (on-paint)
(define dc (send this get-dc))
(define pen (send dc get-pen))
(define brush (send dc get-brush))
(define f (get-top-level-window))
;; now draw the eye
(send dc set-pen "black" 1 'solid)
(send dc set-brush "white" 'solid)
(send dc draw-ellipse 0 0 eye-diameter eye-diameter)
(define-values (csx csy) (send this client->screen 0 0))
(define-values (fsx fsy) (send f client->screen 0 0))
(define osx (- csx fsx))
(define osy (- csy fsy))
;(define values (a b) (screen->client x y))
(begin ; just for indentation
;; get canvas offsets
;(define-values (x-o y-o) (send dc get-origin))
(displayln (~a "osy" this ))
;; get mouse position
(define-values (ms l) (get-current-mouse-state))
(define mouse-sx (round (send ms get-x))) ; screen coords
(define mouse-sy (round (send ms get-y)))
(define-values (mcx mcy) (send this screen->client mouse-sx mouse-sy)); client coords
;;
(define-values (screen-eye-x screen-eye-y) (client->screen eye-x eye-y))
(define Δx (- screen-eye-x mouse-sx ))
(define Δy (- screen-eye-y mouse-sy ))
(define mag (magnitude (make-rectangular Δx Δy)))
;(displayln (~a "magnitude " mag))
(if (< mag (- r pupil-r))
(begin
(send dc set-brush "black" 'solid)
(send dc draw-ellipse (- mcx pupil-r) (- mcy pupil-r) pupil-diameter pupil-diameter)
(send dc set-brush "red" 'solid) (send dc draw-ellipse mcx mcy 5 5))
(let ((direction (atan Δy Δx)))
(define pupilΔx (- (round (* (cos direction) (* r 2/3)))))
(define pupilΔy (- (round (* (sin direction) (* r 2/3)))))
(define (tocentre n) (- (+ r n) pupil-r))
(define px (tocentre pupilΔx)) ; (- (+ r pupilΔx) pupil-r))
(define py (tocentre pupilΔy))
(send dc set-brush "black" 'solid)
(send dc draw-ellipse px py pupil-diameter pupil-diameter))))
(send dc set-pen pen)
(send dc set-brush brush))
(super-new [style (list 'transparent)])))
(module+ main
(define frame (new frame% [label "Eyes"] [width 200] [height 246]))
(define c (new eyes-canvas% [parent frame](eye-diameter 200)))
(send frame show #t)
(send c client->screen 0 0)
(send frame client->screen 0 0)
(define t (new timer%
[notify-callback (λ () (send c refresh))]
[interval 1000]
[just-once? #f])))