I'm writing a scheme program that allows a user to create planets that follow gravitational laws. For the assignment, I have to alter the code to avoid busy waiting and also create a new thread for each planet, or every time that the mouse is clicked. I don't have a good understanding of GUIs in scheme, and would be very thankful for some help.
Here is the code:
#lang racket
(require racket/gui)
;; Small 2d vector library for the Newtonian physics
(define (x v) (vector-ref v 0))
(define (y v) (vector-ref v 1))
(define (x! v value) (vector-set! v 0 value))
(define (y! v value) (vector-set! v 1 value))
(define (v* v value) (vector-map (lambda (x) (* x value)) v))
(define (v+ v w) (vector-map + v w))
(define (v- v w) (vector-map - v w))
(define (v-zero! v) (vector-map! (lambda (x) 0) v))
(define (v-dot v w) (let ((vw (vector-map * v w))) (+ (x vw) (y vw))))
(define (v-mag v) (sqrt (v-dot v v)))
;; Planet object
(define planet%
(class object%
(public m p v calculate-force move draw)
(init-field (mass 1)
(position (vector 0 0 ))
(velocity (vector 0 0 ))
(force (vector 0 0 )))
(define (m) mass)
(define (p) position)
(define (v) velocity)
;; Use Newton's law of gravitation.
;; I assume the gravitational constant is one
(define (calculate-force pl)
(v-zero! force)
(for-each (lambda (other-planet)
(when (not (equal? this other-planet))
(let* ((direction (v- (send other-planet p) position))
(dist (max 1 (v-mag direction)))
(other-mass (send other-planet m))
(new-force (v* direction (/ (* mass other-mass) (* dist dist))))
)
(vector-map! + force new-force))))
pl)
)
;; Simple Euler integration of acceleration and velocity
(define (move)
(let ((acc (v* force (/ 1.0 mass))))
(vector-map! + velocity acc)
(vector-map! + position velocity)))
;; Draw a circle
(define (draw dc)
(send dc set-brush brush)
(send dc set-pen pen)
(send dc draw-ellipse (x position) (y position) radius radius ))
;; Initialize to random velocity, mass, and color
(x! velocity (* 2 (random)))
(y! velocity (* 2 (random)))
(set! mass (+ 1 (* 10 (random))))
(define radius (* 5 (sqrt mass)))
(define color
(let* ((r (random))
(b (real->floating-point-bytes r 4)))
(make-object color% (bytes-ref b 0) (bytes-ref b 1) (bytes-ref b 2) )))
(define brush (make-object brush% color))
(define pen (make-object pen% color))
;; Don't forget the super-new!
(super-new)
))
;; Abstract the list-handling for a list of planets
(define planet-container%
(class object%
(public add-planet calculate-force move draw get-planets)
(init-field (planets '()))
(define (get-planets) planets)
(define (add-planet planet)
(set! planets (cons planet planets)))
(define (calculate-force)
(for-each (lambda (planet)
(send planet calculate-force planets))
planets))
(define (move)
(for-each (lambda (planet)
(send planet move))
planets))
(define (draw dc)
(for-each (lambda (planet)
(send planet draw dc))
planets))
(super-new)
)
)
(define planet-container (new planet-container%))
;; The GUI
(define frame (new frame%
(label "Planets")
(min-width 120)
(min-height 80)
))
(send frame create-status-line)
(send frame show #t)
(define h-panel
(new horizontal-panel%
(parent frame)
(stretchable-height #f)
(style '(border))
(border 2)))
(define run-checkbox
(new check-box%
(parent h-panel)
(label "Run animation")
))
(define my-canvas%
(class canvas%
(override on-paint on-event)
(define (on-paint)
(let ((dc (send this get-dc))
(w (send this get-width))
(h (send this get-height)))
(send dc clear)
(send planet-container draw dc)
))
(define (on-event event)
(when (send event button-down?)
(let ((x (send event get-x))
(y (send event get-y)))
(send frame set-status-text (format "Mouse at ~a ~a" x y))
(send planet-container add-planet (new planet% (position (vector x y))))
(send this refresh)))
)
(super-new)
(send (send this get-dc) set-background (make-object color% 8 8 64))
))
(define canvas
(new my-canvas%
(parent frame)
(style '(border))
(min-width 640)
(min-height 480)))
;; Busy loop planet animator
(let loop ()
(sleep/yield .05)
(when (send run-checkbox get-value)
(send planet-container calculate-force)
(send planet-container move)
(send canvas refresh)
)
(loop))
