home *** CD-ROM | disk | FTP | other *** search
/ Current Shareware 1994 January / SHAR194.ISO / cad_util / v8n7_cad.zip / GAUSS.LSP < prev    next >
Lisp/Scheme  |  1993-07-26  |  3KB  |  104 lines
  1.  (defun M_ELIM (A / T1 T2 X U)
  2.   (cond
  3.     ((= (length (car A)) 2) A) ;;elimination completed
  4.     (t ;;reduce matrix
  5.        ;;find max car of A, switch with front of matrix
  6.        (setq T1 (apply 'max (mapcar '(lambda (X) (abs (car X))) A))
  7.              T1 (if (assoc T1 A) (assoc T1 A) (assoc (* -1 T1) A))
  8.              T2 (car A)
  9.        )
  10.        (if (not (equal T1 T2))
  11.          (setq A (cdr A)
  12.                A (subst T2 T1 A)
  13.                A (cons T1 A)
  14.          )
  15.        )
  16.        ;; eliminate in remaining members.
  17.        (foreach U (cdr A)
  18.          (setq T2 (/ (car U) (car T1))
  19.                T2 (mapcar '(lambda (T3 T4) (- T4 (* T3 T2))) T1 U)
  20.                A (subst T2 U A)
  21.          )
  22.        )
  23.        ;; reduce order and return result of further elimination...
  24.        (cons T1
  25.              (mapcar 
  26.                 '(lambda (T2) 
  27.                    (cons 0.0 T2)) 
  28.                 (M_ELIM (mapcar 'cdr (cdr A)))))
  29.     )
  30.   )
  31. )
  32.   (defun M_BACKSUB (A / U V)
  33.   (cond
  34.     ((= (length (car A)) 2)
  35.        (list (/ (cadr (car A)) (car (car A))))
  36.     )
  37.     (t
  38.        (setq U (car A)
  39.              V (M_BACKSUB (mapcar 'cdr (cdr A)))
  40.              W (/ (- (last U) (apply '+ (mapcar '* V (cdr U)))) (car U))
  41.        )
  42.        (cons W V)
  43.     )
  44.   ))
  45.  
  46. ;;  Test 1 example equation set
  47. s;;  10x1 +  x2 -  5x3 = 1
  48. ;; -20x1 + 3x2 + 20x3 = 2
  49. ;;   5x1 + 3x2 +  5x3 = 6
  50. (setq TEST1 '(( 10.0 1.0 -5.0 1.0)
  51.               (-20.0 3.0 20.0 2.0)
  52.               (  5.0 3.0  5.0 6.0))
  53.  
  54.      ;;Test 2 example equation set
  55.      ;;  8.3x1 -  3.2x2          - 2.7x4 =  15.3293
  56.      ;; -3.2x1 + 13.7x2 -  5.6x3         =  22.4903
  57.      ;;        -  5.6x2 + 10.5x3 - 2.7x4 = -28.53
  58.      ;; -2.7x1          -  2.7x3 + 9.2x4 =   8.1167
  59.           TEST2 '(( 8.3 -3.2  0.0 -2.7  15.3293)
  60.               (-3.2 13.7 -5.6  0.0  22.4903)
  61.               ( 0.0 -5.6 10.5 -2.7 -28.53)
  62.               (-2.7  0.0 -2.7  9.2   8.1167))
  63.      ;; Calculate tension in members of a statically determinate truss
  64.       TEST3 '((0.7071 0.0  0.0 -1.0 -0.866 0.0  0.0  0.0  0.0      0.0)
  65.               (0.7071 0.0  1.0  0.0  0.5   0.0  0.0  0.0  0.0  -1000.0)
  66.               (0.0    1.0  0.0  0.0  0.0  -1.0  0.0  0.0  0.0      0.0)
  67.               (0.0    0.0 -1.0  0.0  0.0   0.0  0.0  0.0  0.0      0.0) 
  68.               (0.0    0.0  0.0  0.0  0.0   0.0  1.0  0.0  0.7071 500.0)
  69.               (0.0    0.0  0.0  1.0  0.0   0.0  0.0  0.0 -0.7071   0.0)
  70.               (0.0    0.0  0.0  0.0  0.866 1.0  0.0 -1.0  0.0      0.0)
  71.               (0.0    0.0  0.0  0.0 -0.5   0.0 -1.0  0.0  0.0   -500.0)
  72.               (0.0    0.0  0.0  0.0  0.0   0.0  0.0  1.0  0.7071   0.0))
  73. )
  74. ;; Typing (GAUSS TEST1) or (GAUSS TEST2) will display
  75. ;; the orginal matrix, the reduced triangular matrix, and the
  76. ;; calculated values of the varialbes x1...xN.
  77. (defun GAUSS (A / B C)
  78.   (foreach TMP A
  79.     (prompt (strcat "\n"
  80.                     (rtos (car TMP))
  81.             ))
  82.     (foreach TMP2 (cdr TMP)
  83.       (prompt (strcat "\t" (rtos TMP2))))
  84.   )
  85.  
  86.   (setq B (M_ELIM A))
  87.  
  88.   (prompt "\n\nElimination matrix result")
  89.   (foreach TMP B
  90.     (prompt (strcat "\n"
  91.                     (rtos (car TMP))
  92.             ))
  93.     (foreach TMP2 (cdr TMP)
  94.       (prompt (strcat "\t" (rtos TMP2))))
  95.   )
  96.  
  97.   (setq C (M_BACKSUB B))
  98.  
  99.   (prompt "\nBack substitution result")
  100.   (print C)
  101.   ;;
  102.   (princ)
  103. )
  104.