bld-ode/state.lisp at master · bld/bld-ode · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
#|
Generic state arithmetic for ODE solvers
Includes addition, subtraction, negation, and scalar multiplication
Includes vector & hash table arithmetic
Planned: macro to define methods on custom classes
|#

(in-package :bld-ode)

;;; Infinity norm of an ODE state
(defgeneric norminfx (x)
  (:documentation "Infinity norm of a state"))

;;; Infinity norm of a number
(defmethod norminfx ((x number))
  (abs x))

;;; Vector state arithmetic

(defmeth2 + ((a vector) (b vector))
  (map 'vector #'+ a b))

(defmeth12 - ((a vector) (b vector))
  ((map 'vector #'- a))
  ((map 'vector #'- a b)))

(defmeth2 * ((x vector) (s number))
  (map 'vector #'(lambda (xi) (* xi s)) x))

(defmeth2 * ((s number) (x vector))
  (* x s))

(defmethod norminfx ((x vector))
  (reduce #'max (map 'vector #'norminfx x)))

;;; Hash table state arithmetic

(defmeth2 + ((a hash-table) (b hash-table))
  (let ((result (make-hash-table)))
    (loop for k being the hash-keys in a
       for va being the hash-values in a
       for vb being the hash-values in b
       do (setf (gethash k result) (+ va vb)))
    result))

(defmeth12 - ((a hash-table) (b hash-table))
  ((bld-utils:maphash2 #'(lambda (k v) (- v)) a))
  ((let ((result (make-hash-table)))
     (loop for k being the hash-keys in a
	for va being the hash-values in a
	for vb being the hash-values in b
	do (setf (gethash k result) (- va vb)))
     result)))

(defmeth2 * ((x hash-table) (s number))
  (let ((result (make-hash-table)))
    (loop for k being the hash-keys in x
       for v being the hash-values in x
       do (setf (gethash k result) (* v s)))
    result))

(defmeth2 * ((s number) (x hash-table))
  (* x s))

(defmethod norminfx ((x hash-table))
  (loop for v being the hash-values in x
     maximize (norminfx v)))

;;; Define PRINT-OBJECT method for hash tables
(defmethod print-object ((h hash-table) stream)
  (format stream "#<HASH-TABLE")
  (maphash #'(lambda (k v) (if (keywordp k)
			       (format stream " :~a ~a" k v)
			       (format stream " ~a ~a" k v))) h)
  (format stream ">"))

;;; Macro to define state arithmethic on a custom class
(defmacro defstatearithmetic (class slots &key (initargs (mapcar #'make-keyword slots)) oslots (oinitargs (mapcar #'make-keyword oslots)))
  "Defines state arithmetic for specified class and slots.
Assumes state arithmetic already defined for slot types, including
NORMINFX.  By default, assumes INITARGS of the same name as slots
already defined. Optionally include OSLOTS and OINITARGS for other
slots that are copied over and not used in the state value arithmetic,
e.g. parameters that carry over from state to state."
  `(progn
     ;; Inifinity norm
     (defmethod norminfx ((x ,class))
       (max
	,@(loop for slot in slots
	     collect `(norminfx (slot-value x ',slot)))))
     ;; Addition
     (defmeth2 + ((a ,class) (b ,class))
       (make-instance
	',class
	,@(loop for slot in slots
	     for initarg in initargs
	     collect initarg
	     collect `(+ (slot-value a ',slot) (slot-value b ',slot)))
	,@(loop for oslot in oslots
	     for oinitarg in oinitargs
	     collect oinitarg
	     collect `(slot-value a ',oslot))))
     ;; Negation / Subtraction
     (defmeth12 - ((a ,class) (b ,class))
       ((make-instance
	 ',class
	 ,@(loop for slot in slots
	      for initarg in initargs
	      collect initarg
	      collect `(- (slot-value a ',slot)))
	 ,@(loop for oslot in oslots
	      for oinitarg in oinitargs
	      collect oinitarg
	      collect `(slot-value a ',oslot))))
       ((make-instance
	 ',class
	 ,@(loop for slot in slots
	      for initarg in initargs
	      collect initarg
	      collect `(- (slot-value a ',slot) (slot-value b ',slot)))
	 ,@(loop for oslot in oslots
	      for oinitarg in oinitargs
	      collect oinitarg
	      collect `(slot-value a ',oslot)))))
     ;; Scalar multiplication
     (defmeth2 * ((x ,class) (s number))
       (make-instance
	',class
	,@(loop for slot in slots
	     for initarg in initargs
	     collect initarg
	     collect `(* (slot-value x ',slot) s))
	,@(loop for oslot in oslots
	     for oinitarg in oinitargs
	     collect oinitarg
	     collect `(slot-value x ',oslot))))
     (defmeth2 * ((s number) (x ,class))
       (* x s))))