physics simulation system in common lisp.

physics.lisp

(defclass world ()
  ((points :initform (make-hash-table) :accessor points)
   (rules :initform (make-hash-table) :accessor rules)
   (attachments :initform nil :accessor attachments)))

(defclass attachment ()
  ((point-a :initarg :point-a :accessor point-a)
   (point-b :initarg :point-b :accessor point-b)
   (rule :initarg :rule :accessor rule)))
;rule is called with arguments point-a point-b to decide force applied to point-a. force applied to point-b is negation of that

(defclass point ()
  ((pos :initarg :pos :accessor pos)
   (velocity :initarg :velocity :accessor velocity)
   (delta-pos :initform (vector 0.0 0.0) :accessor delta-pos)
   (delta-velocity :initform (vector 0.0 0.0) :accessor delta-velocity)
   (force :initarg :force :accessor force)
   (mass :initarg :mass :accessor mass)))

(defgeneric add-class (world class))
(defmethod add-class ((world world) class)
  (setf (gethash class (points world)) nil)
  (setf (gethash class (rules world)) (make-hash-table)))

(defgeneric add-attachment (world point-a point-b rule))
(defmethod add-attachment ((world world) (point-a point) (point-b point) rule)
  (push (make-instance 'attachment :point-a point-a :point-b point-b :rule rule) (attachments world)))

;;class a interacts with class b using the interaction. This force is applied to instances of class a, couldn't figure out a better way to phrase which class it was applied to and which class it depends on
;;interaction should be a function accepting two arguments, one being the point that belongs to class a, the other being the one that belongs to class b. It should return the force to apply to the point of class a.
(defgeneric add-class-rule (world class-a class-b interaction))
(defmethod add-class-rule ((world world) class-a class-b interaction)
  (setf (gethash class-b (gethash class-a (rules world))) interaction))

(defgeneric add-point (world class point))
(defmethod add-point ((world world) class point)
  (format t "~s, ~s, ~s, ~s
" (force point) (velocity point) (mass point) class)
  (push point (gethash class (points world))))

(defgeneric update-force (world))
(defmethod update-force ((world world))
  (loop for points being the hash-values in (points world) do
	(dolist (point points)
	  (setf (force point) (vector 0.0 0.0))))
  (loop for class-a being the hash-keys in (rules world) using (hash-value class-rules) do
	(loop for class-b being the hash-keys in class-rules using (hash-value rule) do
	      (dolist (a (gethash class-a (points world)))
		(dolist (b (gethash class-b (points world)))
		  (unless (eql a b)
		    (let ((force (funcall rule a b)))
		      (incf (elt (force a) 0) (elt force 0))
		      (incf (elt (force a) 1) (elt force 1))))))))
  (dolist (attachment (attachments world))
    (with-slots (point-a point-b rule) attachment
		(let ((force (funcall rule point-a point-b)))
		  (incf (elt (force point-a) 0) (elt force 0))
		  (incf (elt (force point-a) 1) (elt force 1))
		  (decf (elt (force point-b) 0) (elt force 0))
		  (decf (elt (force point-b) 1) (elt force 1))))))
(defgeneric update-position (world delta-time))
(defmethod update-position ((world world) delta-time)
  (loop for points being the hash-values in (points world) do
	(dolist (point points)
	  (incf (elt (velocity point) 0) (/ (* (elt (delta-velocity point) 0) delta-time) (mass point)))
	  (incf (elt (velocity point) 1) (/ (* (elt (delta-velocity point) 1) delta-time) (mass point)))
	  (incf (elt (pos point) 0)  (* (elt (delta-pos point) 0) delta-time))
	  (incf (elt (pos point) 1) (* (elt (delta-pos point) 1) delta-time))
	  (setf (delta-pos point) (velocity point))))
  (update-force world)
  (loop for points being the hash-values in (points world) do
	(dolist (point points)
	  (setf (delta-velocity point) (force point)))))

physicstest.lisp

(load "physics.lisp")
(ql:quickload "lispbuilder-sdl")

(defun distance (a-x a-y b-x b-y)
  (let ((distance-x (- a-x b-x))
	(distance-y (- a-y b-y)))
    (sqrt (+ (* distance-x distance-x) (* distance-y distance-y)))))

(defun gravity (a b)
  (let ((a-x (elt (pos a) 0))
	(a-y (elt (pos a) 1))
	(b-x (elt (pos b) 0))
	(b-y (elt (pos b) 1)))
    (let ((dist (distance a-x a-y b-x b-y))
	  (dist-x (- b-x a-x))
	  (dist-y (- b-y a-y)))
      (vector
       (* (/ dist-x dist) (/ (* (mass a) (mass b)) (* dist dist)))
       (* (/ dist-y dist) (/ (* (mass a) (mass b)) (* dist dist)))))))




(defun draw-world (world)
  (loop for points being the hash-values in (points world) using (hash-key class) do
	(dolist (point points)
	  (sdl:draw-filled-circle-* (round (elt (pos point) 0)) (round (elt (pos point) 1)) (round (/ (mass point) 50)) :color sdl:*white*))))

(defun simulate ()
  (sdl:with-init ()
		 (let ((physics (make-instance 'world))
		       (counter 0.0))
		   (add-class physics 'blue)
		   (add-class physics 'red)
		   (add-class physics 'massive)
		   (add-class-rule physics 'massive 'massive #'gravity)
		   (add-class-rule physics 'blue 'red #'gravity)
		   (add-class-rule physics 'red 'blue #'gravity)
		   (add-class-rule physics 'red 'red (lambda (a b) (gravity b a)))
		   (add-class-rule physics 'blue 'blue (lambda (a b) (gravity b a)))
		   (sdl:window 600 800 :title-caption "FYSICKS")
		   (setf (sdl:frame-rate) 60)
		   (sdl:with-events ()
				    (:quit-event () t)
				    (:mouse-button-up-event (:x x :y y :button button)
							      (add-point physics 'massive (make-instance 'point :mass (+ counter 0.1) :force (vector 0 0) :velocity (vector 0 0) :pos (vector x y)))
							      (setf counter 0.0))
				    (:idle ()
					   (when (or (sdl:mouse-left-p) (sdl:mouse-right-p))
					     (incf counter 1.0))
					   (update-position physics 0.15)
					   (sdl:clear-display sdl:*black*)
					   (sdl:draw-filled-circle-* (sdl:mouse-x) (sdl:mouse-y) (round (/ counter 50)) :color sdl:*white*)
					   (draw-world physics)
					   (sdl:update-display)))
		   (format t "~s" (gethash 'massive (points physics))))))