Scheme Gaussian Elimination

gaussian.scm

;####################
;Gaussian Elimination
;Rahul Agarwal
;###################

;#################################################################
;Test if value is a valid linear equation, helper is part 
;of linear-equation? so not testing seperately
;#################################################################
(define (le-helper value)
  (cond ((empty? value) #t)
        ((not (number? (car value))) #f);test if not a number, 
		also takes care of nested lists
        (else (le-helper (cdr value)))
   )
)
(define (linear-equation? value)
  (cond ((not (list? value)) #f)
        ((empty? value) #f)
        ((< (length value) 2) #f);must have atleast 2 or more numbers
        (else (le-helper value))
   )
)

#fShould be(linear-equation? '())Test...
#fShould be(linear-equation? 3)Test...
#fShould be(linear-equation? '(2))Test...
#tShould be(linear-equation? '(3 2.5 8 3.2))Test...
#tShould be(linear-equation? '(1 -1 +1 0))Test...
#fShould be(linear-equation? '(4 (3 2) 3))Test...
#fShould be(linear-equation? '(2 x 3 3))Test...
#fShould be(linear-equation? '(a b (s)))Test...
#fShould be(linear-equation? '(()))Test...
#tShould be(linear-equation? '(5 10))Test...
#tShould be(linear-equation? '(2/3 1/2 4/2))Test...
;#################################################################
;Test if value is a valid augmented matrix
;The length function gives the length, each row should be a linear
;equation and number atoms in each one more than number rows 
;#################################################################
(define (am-helper value len);len is num rows
  (cond 
    ((empty? value) #t);reached end without false
    ((not (and (linear-equation? (car value)) (equal? (+ 1 len) 
		(length (car value))))) #f); linear eq && NxN+1
    (else (am-helper (cdr value) len))
   )
)
(define (augmented-matrix? value)
  (cond 
    ((not (list? value)) #f)
    ((empty? value) #f)
    (else (am-helper value (length value)))
   )
)
#tShould be(augmented-matrix? '((1 1 1 0)(1 -2 2 4)(1 +2 -1 2)))Test...
#fShould be(augmented-matrix? '((1 1 0)(1 -2  2 4)(1 +2 -1 2)))Test...
#fShould be(augmented-matrix? '((1 3 6 1 0)(1 -2  2 4)(1 +2 -1 2)))Test...
#fShould be(augmented-matrix? '((1 1 1 0)(1 -2 x 4)(1 +2 -1 2)))Test...
#fShould be(augmented-matrix? '((1 1 3 0)(1 +2 -1 2)))Test...
#fShould be(augmented-matrix? '((1 1 3 0)(12 1 33 0)(1 8 2 0)(1 +2 -1 2)))Test...
#fShould be(augmented-matrix? '())Test...
#fShould be(augmented-matrix? '((1 1 1 0)(1 -2 2 4)()))Test...
#fShould be(augmented-matrix? '((1 (1 1) 0)(1 (-2) 2 4)(1 +2 -1 (2))))Test...
#fShould be(augmented-matrix? 3)Test...
#fShould be(augmented-matrix? '((2 3 ())(3 2 1)))Test...
#tShould be(augmented-matrix? '((5 10)))Test...
#fShould be(augmented-matrix? '(5 10))Test...
#fShould be(augmented-matrix? '((3 2 1 3) 2 9 2 1 (2 4 2 2)))Test...
;#################################################################
;Find the upper triangualr matrix for the input. It is assumed 
;that the value passed
;to this method is a valid augmented matrix so that is not tested and the
;test cases also
;do not target that.
;#################################################################
;Returns the xth value out of a list, returns empty if x is out of bounds
(define (get-x val x)
  (cond ((empty? val) empty)
        ((> x (length val)) empty)
        ((< x 0) empty)
        ((= x 0) (car val))
        (else (get-x (cdr val) (- x 1)))
   )
)
4Should be(get-x '(1 2 4) 2)Test...
emptyShould be(get-x '(1 2 4) -1)Test...
emptyShould be(get-x '(1 2 4) 3)Test...
;returns the colth value of the rowth row
(define (get-rc mat row col)
  (get-x (get-x mat row) col)
)
2Should be(get-rc '((0 1 2 3)(4 5 6 7)) 0 2)Test...
emptyShould be(get-rc '((0 1 2 3)(4 5 6 7)) 2 2)Test...
emptyShould be(get-rc '((0 1 2 3)(4 5 6 7)) 0 -2)Test...
;returns the matrix till that row
(define (get-mat-till-row mat row)
  (cond ((< row 0) empty)
        ((> row (length mat)) empty)
        (else (cons (car mat)
                    (get-mat-till-row (cdr mat) (- row 1)))
        )
   )
)
'((2 3 2 3)(2 3 2 1))Should be(get-mat-till-row '((2 3 2 3)(2 3 2 1)(2 3 2 1)) 1)Test...
'((2 3 2 3))Should be(get-mat-till-row '((2 3 2 3)(2 3 2 1)(2 3 2 1)) 0)Test...
emptyShould be(get-mat-till-row '((2 3 2 3)(2 3 2 1)(2 3 2 1)) -5)Test...
emptyShould be(get-mat-till-row '((2 3 2 3)(2 3 2 1)(2 3 2 1)) 5)Test...
;scalar multi and substraction (sms)
;applies map using lambda function that cross multiples rows using the pivot col
;so that the value at col can then be zero in toList
(define (do-math-sms subList toList col)
  (map (lambda 
           (x y)
           (- (* x (get-x subList col))
              (* y (get-x toList col)))
        )
        toList
        subList)
)
;NOTE: not tested for boundry cases cos this function can never be called with
;out of bounds values of col
'(0 7 -2)Should be(do-math-sms '(3 5 2) '(4 9 2) 0)Test...
'(-7 0 -8)Should be(do-math-sms '(3 5 2) '(4 9 2) 1)Test...
;makes all the values of the col to zero
;uses the do-math-sms on col in mat
(define (make-zero mat col)
  (letrec(
           (mz-helper (lambda (row newmat)
             (cond ((>= row (length mat)) newmat);prevents make-zero if will 
			 /violate upper triangular
                (else
                 (mz-helper (+ 1 row)
                         (append newmat
                               (list (do-math-sms (get-x mat col)
                                            (get-x mat row)
                                            col)))))
              )
             )
            );end lambda
         )
        (mz-helper (+ 1 col) (get-mat-till-row mat col));letrec body
   )
)
;NOTE: not tested for boundry cases cos this function can never be called with
;out of bounds values of col
'((1 3 2)(0 -20 -14))Should be(make-zero '((1 3 2)(8 4 2)) 0)Test...
'((1 3 2 3)(8 2 4 2)(-6 0 -6 -4))Should be(make-zero '((1 3 2 3)(8 2 4 2)(5 2 1 0)) 1)Test...
;counts numbers of zeros before encountering a non-zero value
(define (count-zeros-at-front mat)
  (cond ((empty? mat) 0)
        ((not (zero? (car mat))) 0)
        (else (+ 1 (count-zeros-at-front (cdr mat))))
   )
)
0Should be(count-zeros-at-front '())Test...
0Should be(count-zeros-at-front '(1 0 0 0))Test...
4Should be(count-zeros-at-front '(0 0 0 0))Test...
2Should be(count-zeros-at-front '(0 0 3 0))Test...
;check top down - the 'row' passed should have 'row' number of zeros
(define (valid-ut-helper mat row totrows)
  (cond ((empty? mat) #t)
        ((not (= row (count-zeros-at-front (car mat)))) #f)
        ((< row totrows) (valid-ut-helper (cdr mat) (+ 1 row) totrows))
        (else #t)
   )
)
;checks whether a valid upper-triangular
;last row should hv atleast two non-zero at end, second last three and so on...
(define (valid-ut? mat)
  (cond ((empty? mat) #f)
        (else (valid-ut-helper mat 0 (length mat)));helper to enable 
		;looping via recursion
   )
)
#fShould be(valid-ut? '())Test...
#tShould be(valid-ut? '((2.5 6.25)))Test...
#tShould be(valid-ut? '((1 1 1 0) (0 -3 1 4) (0 0 5 -10)))Test...
#fShould be(valid-ut? '((1 -1 4) (0 0 -12)))Test...
#fShould be(valid-ut? '((1 1 1 150) (0 1 2 -50) (0 0 0 -50)))Test...
#fShould be(valid-ut? '((0 0 0 0)(0 0 0 0)(0 0 0 0)))Test...
;process by sending each col to zero and creating new matrix
;each col is the pivot value in turn
(define (ut-helper mat col end)
  (cond ((empty? (get-rc mat col col)) mat);base
        ((= col end) mat);base
        (else 
           (ut-helper (make-zero mat col) (+ col 1) end))
   )
)

;creates the upper triangle for the given matrix
;actually helper does but writing cos this prototype required 
(define (upper-triangular value)
  (let ((ut-calculated (ut-helper value 0 (- (length value) 1))));var holding ut found
    (cond ((valid-ut? ut-calculated) ut-calculated)
          (else 'error)
     )
  );end let
)

'((5 10))Should be(upper-triangular '((5 10)))Test...
'((1 1 1 0) (0 -3 1 4) (0 0 5 -10))Should be(upper-triangular '((1 1 1 0) 
	(1 -2 2 4) (1 2 -1 2)))Test...
'((4 8 4 80) (0 -12 -24 -132) (0 0 -624 -1872))Should be(upper-triangular '((4 8 4 80) 
	(2 1 -4 7) (3 -1 2 22)))Test...
'((2.5 6.25))Should be(upper-triangular '((2.5 6.25)))Test...
'((3/2 5/2 1)(0 34/4 13/4))Should be(upper-triangular '((3/2 5/2 1)(-5/2 3/2 1/2)))Test...
'errorShould be(upper-triangular '((1 -1 4) (2 -2 -4)))Test...
'errorShould be(upper-triangular '((1 1 1 150) (1 2 3 100) (2 3 4 200)))Test...
'errorShould be(upper-triangular '((0 0 0 0)(0 0 0 0)(0 0 0 0)))Test...

;#################################################################
;Backsolver when given a upper-triangular. Again test cases assume 
;that since this function is called only after
;upper-triangular is complete the value is a correct augmented matrix
;#################################################################
;my-sum takes the two lists and finds the special sum
;subsitutes values from one list and solves one unknown
(define (my-sum shortList longList ret)
  (cond ((empty? shortList) ret)
        (else (my-sum (rest shortList)
                      (rest longList)
                      (+ ret (* (first shortList)
                                (first longList)))))
   )
)
;helper for backsolver
(define (bs-helper revmat ret col lastcol)
  (cond ((empty? revmat) ret)
        ((zero? (get-x (first revmat) col)) 'error);prevent division by 
		;zero - catches inconsistent matrix
        (else (bs-helper (rest revmat)
                         (cons (/ (- (get-x (first revmat) lastcol)
                                  (my-sum (reverse ret)
                                          (rest
                                           (reverse (first revmat)))
                                          0))
                                  (get-x (first revmat) col))
                               ret)
                         (- col 1)
                         lastcol))
   )
)

;backsolves to get the values
;the reverse is used cos initial values are all zeros and easier
;this way to work at end of list instead of having to write functions to read last
(define (backsolve-upper-triangular value)
  (cond ((not (valid-ut? value)) 'error);check if zeros in correct places else error
        (else (bs-helper (reverse value)
                         empty 
                         (- (length value) 1)
                         (length value)))
   )
)

'(2)Should be(backsolve-upper-triangular '((5 10)))Test...
'(4 -2 -2)Should be(backsolve-upper-triangular '((1 1 1 0) (0 -3 1 4) (0 0 -5 10)))Test...
'(7 5 3)Should be(backsolve-upper-triangular '((4 8 4 80) (0 -6 -12 -66) (0 0 156 468)))Test...
'(2.5)Should be(backsolve-upper-triangular '((2.5 6.25)))Test...
'errorShould be(backsolve-upper-triangular '((1 -1 4) (0 0 -12)))Test...
'errorShould be(backsolve-upper-triangular '((1 1 1 150) (0 1 2 -50) (0 0 0 -50)))Test...
'errorShould be(backsolve-upper-triangular '((0 0 0 0)(0 0 0 0)(0 0 0 0)))Test...
'errorShould be(backsolve-upper-triangular '((0 1 2 5)(0 3 1 3)(0 0 6 4)))Test...
;#############################################################
;Combines all functions above, nothing special
;Test cases are same as upper-triangular and backsolve-upper-triangular 
;hence very few test cases
;#############################################################
(define (solve value)
  (if (augmented-matrix? value) 
      (let ((ut-calculated (upper-triangular value)))
        (if (list? ut-calculated) (backsolve-upper-triangular ut-calculated) 'error)
      )
      'error
   )
)

'(4 -2 -2)Should be(solve '((1 1 1 0) (0 -3 1 4) (0 0 -5 10)))Test...
'errorShould be(solve '((1 -1 4) (0 0 -12)))Test...
'errorShould be(solve '((1 -1 3 4) (0 0 -12)))Test...