82 lines
2.4 KiB
Common Lisp
82 lines
2.4 KiB
Common Lisp
;; 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))))))
|