PasteRack.org
Paste # 81100
2020-11-17 21:30:22

Forked from paste # 7435.

Fork as a new paste.

Paste viewed 389 times.


Embed:

2htdp/image

  1. #lang htdp/bsl
  2. (require 2htdp/image)
  3.  
  4. (require 2htdp/universe)
  5.  
  6. (define WIDTH 500)
  7. (define HEIGHT 500)
  8. (define STARS# 500)
  9. (define PLANET# 5)
  10.  
  11. (struct star (x y size) #:transparent)
  12.  
  13. (struct sun (radius center-x center-y) #:transparent)
  14.  
  15. (struct planet (size color ring-color orbit-center-x orbit-center-y
  16.                      orbit-radius orbit-angle orbit-angular-velocity) #:transparent)
  17.  
  18. (struct solar-system (stars sun planets))
  19.  
  20. (define (initialize-stars)
  21.   (for/list ([i STARS#])
  22.     (star (random WIDTH)
  23.           (random HEIGHT)
  24.           (random 1 3))))
  25.  
  26. (define (initialize-planets)
  27.   (for/list ([i (in-range 1 (add1 PLANET#))])
  28.     (let ([size (random 5 20)]
  29.           [color (make-color (random 256) (random 256) (random 256))]
  30.           [ring-color (if (> (random 100) 25) ; random chance ror rings
  31.                           #f
  32.                           (make-color (random 256) (random 256) (random 256)))]
  33.           [orbit-center-x (sun-center-x SUN)]
  34.           [orbit-center-y (sun-center-y SUN)]
  35.           [orbit-radius (+ (sun-radius SUN) (* i (quotient WIDTH (* 2 PLANET#))) (random 20))]
  36.           [orbit-angle (/ (* (random 200) pi) 100)]
  37.           [orbit-angular-velocity (/ (random 10 20) 200 i)])
  38.       (planet size color ring-color orbit-center-x orbit-center-y
  39.               orbit-radius orbit-angle orbit-angular-velocity))))
  40.  
  41.  
  42. (define STARS (initialize-stars))
  43. (define SUN (sun 25 (quotient WIDTH 2) (quotient HEIGHT 2)))
  44. (define PLANETS (initialize-planets))
  45. (define SOLAR-SYSTEM
  46.   (solar-system STARS SUN PLANETS))
  47.  
  48. ;;; Image Constants and Rendering
  49.  
  50. (define BACKGROUND-IMG (rectangle WIDTH HEIGHT "solid" "black"))
  51. (define SUN-IMG (circle (sun-radius SUN) "solid" "yellow"))
  52.  
  53. (define (add-star-to-scene star scene)
  54.   (place-image (ellipse (star-size star) (star-size star) "solid" "white")
  55.                (star-x star) (star-y star)
  56.                scene))
  57.  
  58. (define STAR-FIELD-IMG
  59.   (foldl add-star-to-scene BACKGROUND-IMG STARS))
  60.  
  61. (define (render-planet p)
  62.   (define ring-color (planet-ring-color p))
  63.   (define size (planet-size p))
  64.   (define planet-img (circle size "solid" (planet-color p)))
  65.   (if ring-color
  66.       (rotate size (overlay/align "center" "center"
  67.                      (ellipse (* 4 size) (quotient size 2) "solid" ring-color)
  68.                      planet-img))
  69.       planet-img))
  70.  
  71. (define (add-planet-to-scene planet scene)
  72.   (define-values (x y) (get-position planet))
  73.   (place-image (render-planet planet)
  74.                x y
  75.                scene))
  76.  
  77. (define (render ss)
  78.   (define stars-and-sun ; use static images for stars and sun
  79.     (place-image
  80.      SUN-IMG
  81.      (sun-center-x SUN) (sun-center-y SUN)
  82.      STAR-FIELD-IMG))
  83.   (foldl add-planet-to-scene stars-and-sun (solar-system-planets ss)))
  84.  
  85. ;;; Circular Motion
  86.  
  87. (define (get-position body)
  88.   (match-define (planet size color ring-color orbit-center-x orbit-center-y
  89.                         orbit-radius orbit-angle orbit-angular-velocity) body)
  90.   (define x (+ orbit-center-x (* orbit-radius (cos orbit-angle))))
  91.   (define y (+ orbit-center-y (* orbit-radius (sin orbit-angle))))
  92.   (values x y))
  93.  
  94. (define (update-orbit body)
  95.   (struct-copy planet body [orbit-angle (+ (planet-orbit-angle body)
  96.                                            (planet-orbit-angular-velocity body))]))
  97.  
  98. (define (update ss)
  99.   (struct-copy solar-system ss [planets (map update-orbit (solar-system-planets ss))]))
  100.  
  101. (define (load-new-planets ss key-event)
  102.   (solar-system STARS SUN (initialize-planets)))
  103.  
  104. ;;; Start Animation
  105.  
  106. (big-bang SOLAR-SYSTEM
  107.   [on-tick update]
  108.   [to-draw render]
  109.   [on-key load-new-planets])

=>