Data commit

Task/QR-decomposition/Common-Lisp/qr-decomposition-1.lisp

@@ -0,0 +1,54 @@
+(defun sign (x)
+  (if (zerop x)
+      x
+      (/ x (abs x))))
+
+(defun norm (x)
+  (let ((len (car (array-dimensions x))))
+    (sqrt (loop for i from 0 to (1- len) sum (expt (aref x i 0) 2)))))
+
+(defun make-unit-vector (dim)
+  (let ((vec (make-array `(,dim ,1) :initial-element 0.0d0)))
+    (setf (aref vec 0 0) 1.0d0)
+    vec))
+
+;; Return a nxn identity matrix.
+(defun eye (n)
+  (let ((I (make-array `(,n ,n) :initial-element 0)))
+    (loop for j from 0 to (- n 1) do
+          (setf (aref I j j) 1))
+    I))
+
+(defun array-range (A ma mb na nb)
+  (let* ((mm (1+ (- mb ma)))
+         (nn (1+ (- nb na)))
+         (B (make-array `(,mm ,nn) :initial-element 0.0d0)))
+
+    (loop for i from 0 to (1- mm) do
+         (loop for j from 0 to (1- nn) do
+              (setf (aref B i j)
+                    (aref A (+ ma i) (+ na j)))))
+    B))
+
+(defun rows (A) (car  (array-dimensions A)))
+(defun cols (A) (cadr (array-dimensions A)))
+(defun mcol (A n) (array-range A 0 (1- (rows A)) n n))
+(defun mrow (A n) (array-range A n n 0 (1- (cols A))))
+
+(defun array-embed (A B row col)
+  (let* ((ma (rows A))
+         (na (cols A))
+         (mb (rows B))
+         (nb (cols B))
+         (C  (make-array `(,ma ,na) :initial-element 0.0d0)))
+
+    (loop for i from 0 to (1- ma) do
+         (loop for j from 0 to (1- na) do
+              (setf (aref C i j) (aref A i j))))
+
+    (loop for i from 0 to (1- mb) do
+         (loop for j from 0 to (1- nb) do
+              (setf (aref C (+ row i) (+ col j))
+                    (aref B i j))))
+
+    C))

Task/QR-decomposition/Common-Lisp/qr-decomposition-2.lisp

@@ -0,0 +1,34 @@
+(defun make-householder (a)
+  (let* ((m    (car (array-dimensions a)))
+         (s    (sign (aref a 0 0)))
+         (e    (make-unit-vector m))
+         (u    (m+ a (.* (* (norm a) s) e)))
+         (v    (./ u (aref u 0 0)))
+         (beta (/ 2 (aref (mmul (mtp v) v) 0 0))))
+
+    (m- (eye m)
+        (.* beta (mmul v (mtp v))))))
+
+(defun qr (A)
+  (let* ((m (car  (array-dimensions A)))
+         (n (cadr (array-dimensions A)))
+         (Q (eye m)))
+
+    ;; Work on n columns of A.
+    (loop for i from 0 to (if (= m n) (- n 2) (- n 1)) do
+
+         ;; Select the i-th submatrix. For i=0 this means the original matrix A.
+         (let* ((B (array-range A i (1- m) i (1- n)))
+                ;; Take the first column of the current submatrix B.
+                (x (mcol B 0))
+                ;; Create the Householder matrix for the column and embed it into an mxm identity.
+                (H (array-embed (eye m) (make-householder x) i i)))
+
+           ;; The product of all H matrices from the right hand side is the orthogonal matrix Q.
+           (setf Q (mmul Q H))
+
+           ;; The product of all H matrices with A from the LHS is the upper triangular matrix R.
+           (setf A (mmul H A))))
+
+    ;; Return Q and R.
+    (values Q A)))

Task/QR-decomposition/Common-Lisp/qr-decomposition-3.lisp

@@ -0,0 +1,9 @@
+(qr #2A((12 -51 4) (6 167 -68) (-4 24 -41)))
+
+#2A((-0.85  0.39  0.33)
+    (-0.42 -0.90 -0.03)
+    ( 0.28 -0.17  0.94))
+
+#2A((-14.0  -21.0  14.0)
+    (  0.0 -175.0  70.0)
+    (  0.0    0.0 -35.0))

Task/QR-decomposition/Common-Lisp/qr-decomposition-4.lisp

@@ -0,0 +1,29 @@
+(defun polyfit (x y n)
+  (let* ((m (cadr (array-dimensions x)))
+         (A (make-array `(,m ,(+ n 1)) :initial-element 0)))
+    (loop for i from 0 to (- m 1) do
+          (loop for j from 0 to n do
+                (setf (aref A i j)
+                      (expt (aref x 0 i) j))))
+    (lsqr A (mtp y))))
+
+;; Solve a linear least squares problem by QR decomposition.
+(defun lsqr (A b)
+  (multiple-value-bind (Q R) (qr A)
+    (let* ((n (cadr (array-dimensions R))))
+      (solve-upper-triangular (array-range R                0 (- n 1) 0 (- n 1))
+                              (array-range (mmul (mtp Q) b) 0 (- n 1) 0 0)))))
+
+;; Solve an upper triangular system by back substitution.
+(defun solve-upper-triangular (R b)
+  (let* ((n (cadr (array-dimensions R)))
+         (x (make-array `(,n 1) :initial-element 0.0d0)))
+
+    (loop for k from (- n 1) downto 0
+       do (setf (aref x k 0)
+                (/ (- (aref b k 0)
+                      (loop for j from (+ k 1) to (- n 1)
+                         sum (* (aref R k j)
+                                (aref x j 0))))
+                   (aref R k k))))
+    x))

Task/QR-decomposition/Common-Lisp/qr-decomposition-5.lisp

@@ -0,0 +1,6 @@
+;; Finally use the data:
+(let ((x #2A((0 1 2 3 4 5 6 7 8 9 10)))
+      (y #2A((1 6 17 34 57 86 121 162 209 262 321))))
+    (polyfit x y 2))
+
+#2A((0.999999966345088) (2.000000015144699) (2.99999999879804))