# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1462319949 0
# Node ID 7e868ce7595b80a1cc3bc9d4f28dd8fe24b0b9ad
# Parent  43ee81d9eec08377ba6624db19578cbb9247ea2c
Episode 18: Particle Enhancements

diff -r 43ee81d9eec0 -r 7e868ce7595b package.lisp
--- a/package.lisp	Tue May 03 00:37:05 2016 +0000
+++ b/package.lisp	Tue May 03 23:59:09 2016 +0000
@@ -100,7 +100,13 @@
     #:particle-accelerate!
     #:particle-angle-to
     #:particle-distance-to
-    #:particle-gravitate-to!))
+    #:particle-gravitate-to!
+    #:particle-gravitate-add!
+    #:particle-gravitate-remove!
+    #:particle-spring-to!
+    #:particle-spring-add!
+    #:particle-spring-remove!
+    ))
 
 (defpackage #:coding-math.fps
   (:use
diff -r 43ee81d9eec0 -r 7e868ce7595b src/main.lisp
--- a/src/main.lisp	Tue May 03 00:37:05 2016 +0000
+++ b/src/main.lisp	Tue May 03 23:59:09 2016 +0000
@@ -1,9 +1,5 @@
 (in-package #:coding-math)
 
-(declaim (optimize (speed 3)
-                   (safety 1)
-                   (debug 0)))
-
 ;;;; Config
 (defparameter *width* 600)
 (defparameter *height* 400)
@@ -13,49 +9,105 @@
 
 
 ;;;; Sketch
-(defun draw-grid ()
-  (with-pen (make-pen :stroke (gray 0.8))
-    (loop :for x :from 0 :below *width* :by 40
-          :do (line x 0 x *height*))
-    (loop :for y :from 0 :below *height* :by 40
-          :do (line 0 y *width* y))))
+(defun draw-particle (p pen)
+  (with-pen pen
+    (circle (particle-x p) (particle-y p) (particle-radius p))))
+
 
 (defsketch cm (:width *width*
                :height *height*
                :debug :scancode-d)
-    ((mouse)
-     (k)
-     (separation)
-     (particles)
-     (connections)
+    ((ready)
+     (mouse)
+     (sp)
+     (p)
+     (earth)
+     (sun)
+     (emitter)
+     (ps)
+     (particle-pen (make-pen :stroke (gray 0.5) :fill (gray 0.8)))
+     (sp-pen (make-pen :stroke (gray 0.0) :fill (gray 0.0)))
+     (rope-pen (make-pen :stroke (gray 0.0)))
+     (sun-pen (make-pen :fill (rgb 1.0 1.0 0.0) :stroke (gray 0)))
+     (earth-pen (make-pen :fill (rgb 0.0 1.0 0.0) :stroke (gray 0)))
+     (p-pen (make-pen :fill (rgb 1.0 0.0 0.0)))
      )
   (with-fps
     (background (gray 1))
     ;;
+    (when ready
 
-    (draw-grid)
-    (with-pen (make-pen :stroke (gray 0.5) :fill (gray 0.9))
-      (circle (round-to-nearest (getf mouse :x) 40)
-              (round-to-nearest (getf mouse :y) 40)
-              10))
+      (particle-update! p)
+      (mapcar #'particle-update! ps)
+      (draw-particle sun sun-pen)
+      (draw-particle earth earth-pen)
+      (draw-particle emitter sp-pen)
+      (loop :for p :in ps :do (draw-particle p p-pen))
+
+      (draw-particle p particle-pen)
+      (with-pen rope-pen
+        (line (particle-x p) (particle-y p) (vec-x sp) (vec-y sp))
+        (line (particle-x p) (particle-y p) (vec-x mouse) (vec-y mouse)))
+      (with-pen sp-pen
+        (circle (vec-x sp) (vec-y sp) 3)
+        (circle (vec-x mouse) (vec-y mouse) 3))
+
+      )
 
     ;;
     ))
 
 (defun make-cm ()
   (make-sketch 'cm
-    (mouse (list :x 0 :y 0))
-    (k 0.01)
-    (separation 100)
-    ))
+    (mouse (make-vec))))
+
+
+(defun reset (game)
+  (setf (slot-value game 'ready) nil)
+  (setf (slot-value game 'sp)
+        (make-vec (random *width*)
+                  (random *height*))
+        (slot-value game 'p)
+        (make-particle (random *width*)
+                       (random *height*)
+                       :radius 10
+                       :friction (random-range 0.1 0.2)
+                       :gravity (random-range 0.1 0.5))
+        (slot-value game 'sun) (make-particle *center-x* *center-y*
+                                              :mass 500.0
+                                              :radius 20)
+        (slot-value game 'earth) (make-particle 320 80
+                                                :mass 100.0
+                                                :radius 8)
+        (slot-value game 'emitter) (make-particle 100 100 :radius 5)
+        (slot-value game 'ps) nil
+        )
+  (particle-spring-add! (slot-value game 'p)
+                        (slot-value game 'mouse)
+                        0.05
+                        80)
+  (particle-spring-add! (slot-value game 'p)
+                        (slot-value game 'sp)
+                        0.05
+                        80)
+  (loop :repeat 300
+        :for p = (make-particle 100 100
+                                :speed (random 3.0)
+                                :direction (random tau)
+                                :radius 3)
+        :do
+        (push p (slot-value game 'ps))
+        (particle-gravitate-add! p (slot-value game 'sun))
+        (particle-gravitate-add! p (slot-value game 'earth)))
+  (setf (slot-value game 'ready) t))
 
 
 ;;;; Mouse
 (defmethod kit.sdl2:mousemotion-event ((window cm) ts b x y xrel yrel)
   (declare (ignore ts b xrel yrel))
   (with-slots (mouse) window
-    (setf (getf mouse :x) x)
-    (setf (getf mouse :y) y)
+    (setf (vec-x mouse) x)
+    (setf (vec-y mouse) y)
     ;;
     ;;
     ))
@@ -65,8 +117,7 @@
 (defun keydown (instance scancode)
   (declare (ignorable instance))
   (scancode-case scancode
-    (:scancode-space
-     nil)))
+    (:scancode-space (reset instance))))
 
 (defun keyup (instance scancode)
   (declare (ignorable instance))
diff -r 43ee81d9eec0 -r 7e868ce7595b src/particles.lisp
--- a/src/particles.lisp	Tue May 03 00:37:05 2016 +0000
+++ b/src/particles.lisp	Tue May 03 23:59:09 2016 +0000
@@ -7,7 +7,14 @@
   (grv (make-vec) :type vec)
   (radius 1 :type fixnum)
   (friction 0.0 :type single-float)
-  (mass 1.0 :type single-float))
+  (mass 1.0 :type single-float)
+  (springs nil :type list)
+  (gravitations nil :type list))
+
+(defstruct spring
+  (target (make-vec) :type vec)
+  (constant 0.0 :type single-float)
+  (offset 0.0 :type single-float))
 
 
 (defun make-particle
@@ -74,21 +81,18 @@
                           (particle-pos other-particle))))
 
 
-(defun particle-update! (particle)
-  (with-accessors
-      ((pos particle-pos)
-       (vel particle-vel)
-       (grv particle-grv)
-       (friction particle-friction))
-      particle
-    (vec-add! pos vel)
-    (vec-add! vel grv)
-    (vec-mul! vel (- 1 friction))))
-
 (defun particle-accelerate! (particle acceleration)
   (vec-add! (particle-vel particle)
             acceleration))
 
+
+(defun particle-gravitate-add! (particle target)
+  (push target (particle-gravitations particle)))
+
+(defun particle-gravitate-remove! (particle target)
+  (zap% (particle-gravitations particle)
+        #'remove target %))
+
 (defun particle-gravitate-to! (particle attractor-particle)
   (let ((distance (particle-distance-to particle attractor-particle)))
     (particle-accelerate!
@@ -98,6 +102,42 @@
                    (particle-angle-to particle attractor-particle)))))
 
 
+(defun particle-spring-to! (particle target spring-constant &optional (offset 0))
+  (let ((distance (vec-sub target (particle-pos particle))))
+    (decf (vec-magnitude distance) offset)
+    (vec-add! (particle-vel particle)
+              (vec-mul distance spring-constant))))
+
+(defun particle-spring-add! (particle target spring-constant &optional (offset 0))
+  (push (make-spring :target target
+                     :constant (float spring-constant)
+                     :offset (float offset))
+        (particle-springs particle)))
+
+(defun particle-spring-remove! (particle target)
+  (zap% (particle-springs particle)
+        #'remove target % :key #'spring-target))
+
+
+(defun particle-update! (particle)
+  (with-accessors
+      ((pos particle-pos)
+       (vel particle-vel)
+       (grv particle-grv)
+       (friction particle-friction))
+      particle
+    (vec-add! pos vel)
+    (vec-add! vel grv)
+    (vec-mul! vel (- 1 friction))
+    (loop :for g :in (particle-gravitations particle)
+          :do (particle-gravitate-to! particle g))
+    (loop :for s :in (particle-springs particle)
+          :do (particle-spring-to! particle
+                                   (spring-target s)
+                                   (spring-constant s)
+                                   (spring-offset s)))))
+
+
 (defmethod hitbox-x ((p particle))
   (particle-x p))