PasteRack.org
Paste # 58746
2020-05-22 12:13:06

Fork as a new paste.

Paste viewed 423 times.


Embed:

eye

#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])))