syndicate-rkt/syndicate-examples/gl-2d-clock-face.rkt

91 lines
3.4 KiB
Racket
Raw Permalink Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
;; Compare to "ezd" clock-face example from: J. F. Bartlett, “Dont
;; Fidget with Widgets, Draw!,” Palo Alto, California, DEC WRL
;; Research Report 91/6, May 1991.
(require lang/posn)
(require 2htdp/image)
(require (only-in racket/math pi))
(require racket/date)
(require/activate syndicate/drivers/gl-2d)
(define hand
(polygon (list (make-posn 0 0)
(make-posn 30 10)
(make-posn 100 0)
(make-posn 30 -10))
"solid"
"black"))
(define (fmod a b)
(- a (* b (truncate (/ a b)))))
(define (hand-sprite id layer angle-field length)
(sprite #:id id layer `((translate 100 100)
(rotate ,(fmod (- 90 (angle-field)) 360))
(scale ,length ,(/ length 5))
(translate 0 -0.5)
(touchable ,id ,in-unit-square?)
(texture ,hand))))
(define (text-sprite layer x y content)
(define i (text content 24 "green"))
(simple-sprite layer x y (image-width i) (image-height i) i))
(spawn (field [minute-angle 0]
[hour-angle 0]
[start-time (current-inexact-milliseconds)]
[elapsed-seconds 0]
[displacement (let ((now (current-date)))
(* 6 (+ (* 60 (date-hour now))
(date-minute now))))])
(assert (simple-sprite 10 0 0 200 200 (circle 100 "solid" "blue")))
(assert (hand-sprite 'minute 9 minute-angle 95))
(assert (text-sprite 8 40 40 "time"))
(assert (text-sprite 8 110 80 "drifts"))
(assert (text-sprite 8 40 120 "by"))
(assert (hand-sprite 'hour 7 hour-angle 65))
(assert (simple-sprite 6 95 95 10 10 (circle 5 "solid" "black")))
(define (respond-to-drags id scale)
(define/query-value touching? #f (touching id) #t)
(on #:when (touching?) (message (mouse-event 'left-down (mouse-state $mx $my _ _ _)))
(start-time #f)
(elapsed-seconds 0)
(update-displacement! mx my scale)
(react (stop-when (message (mouse-event 'left-up _)))
(stop-when (message (mouse-event 'leave _)))
(on-stop (start-time (current-inexact-milliseconds)))
(on (message (mouse-event 'motion (mouse-state $mx $my _ _ _)))
(update-displacement! mx my scale)))))
(define (update-displacement! mx my scale)
(define angle (- 90 (* (/ 180 pi) (atan (- 100 my) (- mx 100)))))
(define delta0 (fmod (- (* scale angle) (displacement)) 360))
(define delta (if (<= delta0 -180) (+ delta0 360) delta0))
(displacement (+ (displacement) delta)))
(respond-to-drags 'minute 1)
(respond-to-drags 'hour 12)
(begin/dataflow
(define angle (+ (/ (elapsed-seconds) 1000 10) (displacement)))
(minute-angle angle)
(hour-angle (/ angle 12)))
(on (message (frame-event _ _ _ _))
(when (start-time)
(elapsed-seconds (- (current-inexact-milliseconds) (start-time)))))
(on (message (key-event #\q #t _))
(send! (gl-control 'stop))))
(spawn-gl-2d-driver #:label "Syndicate Clock"
#:width 200
#:height 200)