#lang racket/base

 

(require racket/gui racket/flonum)

 

 

(define WORLD-W 600.0)

 

(struct Obj ([cx #:mutable]

             [cy #:mutable]

             [v1 #:mutable]

             [v2 #:mutable]

             sz m) #:transparent)

 

 

(define (ball-r b) (/ (Obj-sz b) 2))

(define (ball-x b) (- (Obj-cx b) (ball-r b)))

(define (ball-y b) (- (Obj-cy b) (ball-r b)))

 

(define ball-1 (Obj 30.0 30.0 20.0 0.0 40.0 50.0))

 

(define ((World objects) [obj #f])

  (if obj (set! objects (cons obj objects)) objects))

 

(define world (World (list ball-1)))

 

(define (delta-grav-v2 v2)

  (+ v2 1/6))

 

(define (delta-grav-v1 v1 m)

  ((if (< 0 v1) + -)

   (abs (- v1 (/ v1 m)))))

 

(define (delta-v v m)

  (let ((e (* .5 (* .5 m v v))))

    (sqrt (* 2.0 (/ e m)))))

 

(define (check-dc dc v r s m)

  (cond

    ((> 0.0 (- dc r))

     (values (- dc (- dc r)) (delta-v v m)))

    ((< WORLD-W (+ dc r))

     (values (- WORLD-W (- dc WORLD-W) s) (- (delta-v v m))))

    (else (values dc v))))

 

(define (apply-grav obj)

  (set-Obj-v2! obj (delta-grav-v2 (Obj-v2 obj)))

  (set-Obj-v1! obj (delta-grav-v1 (Obj-v1 obj) (Obj-m obj))))

 

(define (dc-dv coord v r s m)

  (check-dc (+ coord v) v r s m))

 

(define (move obj)

  (let*-values (((m) (Obj-m obj))

                ((r) (ball-r obj))

                ((s) (Obj-sz obj))

                ((dx v1) (dc-dv (Obj-cx obj) (Obj-v1 obj) r s m))

                ((dy v2) (dc-dv (Obj-cy obj) (Obj-v2 obj) r s m)))

    (set-Obj-cx! obj dx)

    (set-Obj-cy! obj dy)

    (set-Obj-v1! obj v1)

    (set-Obj-v2! obj v2)))

 

(define (dravv obj dc)

  (send

   dc draw-ellipse

   (ball-x obj)

   (ball-y obj)

   (Obj-sz obj)

   (Obj-sz obj)))

 

(define (draw-world dc)

  (for ((obj (in-list (world))))

    (apply-grav obj)

    (move obj)

    (dravv obj dc)))

 

 

(define frame

  (new frame%

       [label "pizdec"]

       [width (fl->exact-integer WORLD-W)]

       [height (fl->exact-integer WORLD-W)]))

(define canv

  (new

   (class canvas%

     (inherit get-dc)

     (super-new [parent frame]

                [style '(no-autoclear)]

                [paint-callback

                 (lambda (canvas dc)

                   (send canvas suspend-flush)

                   (send dc clear)

                   (draw-world dc)

                   (send canvas resume-flush))])

     (send* (get-dc)

       (set-background "black")

       (set-pen "black" 0 'transparent))

     (define/override (on-event e)

       (case (send e get-event-type)

         ['left-down

          (world

           (Obj

            (send e get-x) (send e get-y)

            (- 15.0 (random 30))

            (- 5.0 (random 10))

            (random 10 50) (random 1 100)))]

         ['right-down (startstop)])))))

 

 

(define (timeloop)

    (send canv on-paint)

    (sleep/yield 1/60)

    (timeloop))

 

(send frame show #t)

 

(define startstop

  (let ((thr (thread timeloop)))

    (lambda ()

      (if (thread-running? thr)

          (thread-suspend thr)

          (thread-resume thr)))))