Integrate maxima into lisp code to generate update code

.gitignore

@@ -0,0 +1 @@
+maxima-install

ham.asd

@@ -3,12 +3,23 @@
 
 (in-package :asdf-user)
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (let ((base-dir
+		  (make-pathname :directory (pathname-directory *load-pathname*))))
+	(pushnew (merge-pathnames "maxima/src/" base-dir)
+			 asdf:*central-registry*
+			 :test #'equal)
+	(pushnew (merge-pathnames "maxima-interface/" base-dir)
+			 asdf:*central-registry*
+			 :test #'equal)))
+
 (defsystem :ham
   :version "0.1.0"
   :author "Camden Dixie O'Brien"
   :license "AGPL-3.0-only"
   :description "A framework for creating physics simulations"
-  :depends-on (:sdl2)
+  :depends-on (:sdl2 :maxima :maxima-interface)
   :components ((:file "package")
 			   (:file "drawing" :depends-on ("package"))
+			   (:file "physics-compiler" :depends-on ("package"))
 			   (:file "simulation" :depends-on ("package" "drawing"))))

physics-compiler.lisp

@@ -0,0 +1,81 @@
+;; Copyright (c) Camden Dixie O'Brien
+;; SPDX-License-Identifier: AGPL-3.0-only
+
+(in-package :ham)
+
+(eval-when (:load-toplevel :execute)
+  (maxima-interface:maxima-eval
+   `((maxima::$load)
+     ,(namestring (asdf:system-relative-pathname :ham "ham.mac")))))
+
+(defun enmaxima-symbol (sym)
+  (intern (format nil "$~a" (symbol-name sym))
+		  (find-package :maxima)))
+
+(defun enmaxima-lagrangian (expr)
+  (defun prepare (expr)
+	(cond
+	  ((symbolp expr) (enmaxima-symbol expr))
+	  ((and (listp expr) (eq 'dot (car expr)))
+	   (append '(maxima::%derivative)
+			   (mapcar #'prepare (cdr expr))
+			   '(maxima::$t)))
+	  ((and (listp expr) (eq '^ (car expr)))
+	   (cons 'expt
+			 (mapcar #'prepare (cdr expr))))
+	  ((listp expr)
+	   (cons (car expr)
+			 (mapcar #'prepare (cdr expr))))
+	  (t expr)))
+  (maxima-interface::lisp-to-maxima (prepare expr)))
+
+(defun enmaxima-coords (coords)
+  (cons '(maxima::mlist) (mapcar #'enmaxima-symbol coords)))
+
+(defun hamilton-eqns (lagrangian coords)
+  (maxima-interface:maxima-eval
+   `((maxima::$ham)
+	 ,(enmaxima-lagrangian lagrangian)
+	 ,(enmaxima-coords coords))))
+
+(defun momentum-symbol (q)
+  (intern (format nil "P_~a" (symbol-name q))))
+
+(defun flatten (l)
+  (apply #'append l))
+
+(defun unmaxima-expression (expr)
+  (defun unmaxima-symbol (sym)
+	(let ((name (symbol-name sym)))
+	  (if (and (eq (symbol-package sym) (find-package :maxima))
+			   (> (length name) 1)
+			   (char= (char name 0) #\$))
+		  (intern (subseq name 1)) sym)))
+  (cond
+	((symbolp expr) (unmaxima-symbol expr))
+	((listp expr) (mapcar #'unmaxima-expression expr))
+	(t expr)))
+
+(defun update-logic (result coords)
+  (defun coord-updates (exprs q)
+	(let ((p (momentum-symbol q))
+		  (q-dot-expr (cadr exprs))
+		  (p-dot-expr (caddr exprs)))
+	  `((incf ,p (* dt ,(unmaxima-expression p-dot-expr)))
+		(incf ,q (* dt ,(unmaxima-expression q-dot-expr))))))
+  (flatten (loop for coord-expressions
+				   in (cdr (maxima-interface::maxima-to-lisp result))
+				 for q in coords
+				 collect (coord-updates coord-expressions q))))
+
+(defun keys (plist)
+  (loop for key in plist by #'cddr collect key))
+
+(defun update-body (result coords params)
+  (let ((vars (append coords (mapcar #'momentum-symbol coords))))
+	`(let (,@(mapcar (lambda (s) `(,s (getf params ',s))) (keys params))
+		   ,@(mapcar (lambda (s) `(,s (getf state ',s))) vars))
+	   ,@(update-logic result coords)
+	   (list ,@(flatten
+				(mapcar (lambda (s) (list `',s s))
+						vars))))))