1 ;;; -*- Mode: Lisp -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
6 ;; ;;; ~*~ SIMPLEX ~*~ ;;; ;;
8 ;; ;;; A simple implementation of the simplex ;;; ;;
9 ;; ;;; algorithm for Linear Programming for Maxima. ;;; ;;
12 ;; ;;; Copyright: Andrej Vodopivec <andrejv@users.sourceforge.net> ;;; ;;
13 ;; ;;; Version: 1.02 ;;; ;;
14 ;; ;;; License: GPL ;;; ;;
16 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
22 ;; To get optimal speed this file should be compiled. ;;
24 ;; linear_program(A, b, c): ;;
26 ;; - problem: - find x which minimizes c'.x with constraints A.x=b and x>=0 ;;
28 ;; - input: - matrix A of size mxn, ;;
29 ;; - vector (list) b of length m, ;;
30 ;; - vector (list) c of length n ;;
32 ;; - output: - [x, val] if the problem is solvable; ;;
33 ;; x is the optimal vector, val=c'.x ;;
34 ;; - "Problem not bounded" if the problem is not bounded ;;
35 ;; - "Problem not feasible" if the problem is not feasible ;;
37 ;; - algorithm: a simple implementation of the two-phase simplex algorithm ;;
43 ;; We would like to minimize x-2*y subject to: ;;
50 ;; We have to introduce two slack variables for inequalities to get a ;;
51 ;; linear program in the standard form: ;;
54 ;; 2*x - 3*y - s2 = 1 ;;
56 ;; x, y, s1, s2 >= 0 ;;
58 ;; Construct parameters: ;;
60 ;; A : matrix([1,1,-1,0],[2,-3,0,-1], [4,-5,0,0]); ;;
66 ;; linear_program(A, b, c); ;;
67 ;; => [[13/2, 4, 19/2, 0], -3/2] ;;
69 ;; The solution is: x=13/2 and y=4 (s1=19/2, s2=0), and the value of the ;;
70 ;; minimum is x-2*y=-3/2. ;;
76 ;; - pivot_count_sx: the number of pivots in last computation ;;
77 ;; - pivot_max_sx: the maximum number of pivots in computation ;;
78 ;; - epsilon_lp: epsilon for numeric computation (default: 1e-8) ;;
79 ;; - scale_lp: should maxima scale the problem: can be used in ;;
80 ;; Klee-Minty problem to speed-up computation or in some ;;
81 ;; cases to improve numerical stability (default: false); ;;
82 ;; uses equilibratium scaling ;;
84 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
87 (macsyma-module simplex
)
89 ($put
'$simplex
1.02 '$version
)
91 (defmvar $pivot_count_sx
0 "Number of pivots in last problem." fixnum
)
92 (defmvar $pivot_max_sx
15000 "Maximum number of pivots allowed." fixnum
)
93 (defmvar $epsilon_lp
1e-8 "Epsilon for numerical computation." flonum
)
94 (defmvar $scale_lp nil
"Should we scale the input." boolean
)
95 (defmvar $warn_rank_sx nil
"Print warnings about rank." boolean
)
98 (defun lp-rat-mlist-p (x) (and (listp x
) (every #'$ratnump
(cdr x
))))
99 (defun lp-rat-matrix-p (x) (and ($matrixp x
) (every #'lp-rat-mlist-p
(cdr x
))))
102 (let ((x (mlsp a b
)))
103 (cond ((or (eq x t
) (eq x nil
)) x
)
105 (let ((s ($asksign
(cadr x
))))
106 (cond ((eq s
'$pos
) t
)
108 (defun lp-mgqp (a b
) (or (meqp a b
) (lp-mlsp b a
)))
110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
112 ;; Two-phase standard simplex method for solving linear program in standard ;;
115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
118 (defun $linear_program
(A b c
)
119 (if (not ($matrixp A
))
120 (merror "linear_program: first argument not matrix."))
122 (merror "linear_program: second argument not list."))
124 (merror "linear_program: third argument not list."))
125 (if (not (meqp ($length b
) ($length A
)))
126 (merror "linear_program: second argument not of correct length."))
127 (if (not (meqp ($length c
) ($length
($first A
))))
128 (merror "linear_program: third argument not of correct length."))
130 (let* ((m ($length A
))
131 (n ($length
($first A
)))
132 (Tab (make-array `(,(+ 2 m
) ,(1+ n
)))) ; Tableau
133 (basis ()) ; which columns are in current basis
134 (sc-fac ()) ; scaling factors
135 ($epsilon_lp
(if (and (lp-rat-mlist-p b
) (lp-rat-mlist-p c
) (lp-rat-matrix-p A
))
138 (cond ((lp-mlsp 0 $epsilon_lp
)
139 (mwarning (format nil
"linear_program(A,b,c): non-rat inputs found, epsilon_lp=~e." $epsilon_lp
))
140 (mwarning "Solution may be incorrect.")))
142 (setq $pivot_count_sx
0)
144 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
145 ;; Construct the tableau for phase 1: ;;
148 ;; [ sm(A) sm(b) ] ;;
150 ;; If b[i]<0 multiply b[i] and A[i] by -1 (required for phase 1). ;;
151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
153 (if (lp-mlsp (maref b
(1+ i
)) 0)
156 (setf (aref Tab i j
) (neg (maref A
(1+ i
) (1+ j
)))))
157 (setf (aref Tab i n
) (neg (maref b
(1+ i
)))))
160 (setf (aref Tab i j
) (maref A
(1+ i
) (1+ j
))))
161 (setf (aref Tab i n
) (maref b
(1+ i
))))))
163 (setf (aref Tab m i
) (neg (maref c
(1+ i
)))))
165 (setf (aref Tab
(1+ m
) i
) 0)
167 (setf (aref Tab
(1+ m
) i
) (add (aref Tab
(1+ m
) i
)
169 (setf (aref Tab
(1+ m
) n
) 0)
171 (setf (aref Tab
(1+ m
) n
) (add (aref Tab
(1+ m
) n
)
173 (setf (aref Tab m n
) 0)
175 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
176 ;; At the beginning the artificial variables are in the basis. ;;
177 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
179 (setq basis
(append basis
(list (add n i
)))))
181 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
183 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
185 (setq sc-fac
(append sc-fac
(list 1))))
187 (scale-sx Tab
(+ 2 m
) (1+ n
) sc-fac
))
189 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
193 (simplex-sx Tab basis m
(+ 2 m
) (1+ n
))
195 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
197 (if (lp-mlsp $epsilon_lp
(aref Tab
(1+ m
) n
))
198 "Problem not feasible!"
201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
202 ;; Check for artificial variables in basis. ;;
203 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
206 (if (>= (nth i basis
) n
)
207 (if (and (not (run-out-of-basis-sx Tab m n basis i
))
209 ($print
"Matrix A is not of full rank:"
210 "Row" (1+ i
) "is redundant!"))))
212 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
214 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
216 (setq is-bounded
(simplex-sx Tab basis m
(1+ m
) (1+ n
)))
218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
224 (setq opt-tmp
(append opt-tmp
(list 0))))
226 (setf (nth (nth i basis
) opt-tmp
)
227 (div (aref Tab i n
) ;; undo the
228 (nth (nth i basis
) sc-fac
)))) ;; scaling
230 (setq opt
(append opt
(list 0))))
232 (setf (nth i opt
) (nth i opt-tmp
)))
233 (setq opt
(cons '(mlist simp
) opt
)) ;; build the
234 (setq opt
`((mlist simp
) ,opt
;; the solution
236 "Problem not bounded!")))))
239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
241 ;; Simplex algorithm. ;;
243 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
245 (defun simplex-sx (Tab basis Am m n
)
246 (let ((ip) (jp) (tmp) (is-bounded))
247 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
248 ;; Repeat while we don't have a solution or know that the ;;
249 ;; problem is unbounded. ;;
250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
251 (do ((have-solution nil
))
252 ((not (null have-solution
)))
253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
254 ;; Choose jp so that jp-th column has the biggest reduced cost. ;;
255 ;; If all reduced costs are negative, we have the solution. ;;
256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
257 (setq tmp
(aref Tab
(1- m
) 0))
260 (if (lp-mlsp tmp
(aref Tab
(1- m
) j
))
262 (setq tmp
(aref Tab
(1- m
) j
))
264 (if (lp-mgqp $epsilon_lp tmp
)
267 (setq have-solution t
))
269 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
270 ;; Choose ip so that Tab[ip,n]/Tab[ip,jp] is the smallest ;;
271 ;; possible among those for which Tab[i,n] is positive. If all ;;
272 ;; Tab[i,n] are negative, the problem is unbounded. ;;
273 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
277 (if (lp-mlsp $epsilon_lp
(aref Tab i jp
))
278 (if (or (null tmp
) (lp-mlsp (div (aref Tab i
(1- n
))
282 (setq tmp
(div (aref Tab i
(1- n
))
287 (setq is-bounded nil
)
288 (setq have-solution t
))
290 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
291 ;; Pivot the simplex tableau. ;;
292 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
293 (setf (nth ip basis
) jp
)
294 (pivot-sx Tab ip jp m n
))))))
297 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
299 ;; Pivoting for the Simplex algorithm. ;;
301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
303 (defun pivot-sx (Tab ip jp m n
)
304 (let ((piv (aref Tab ip jp
)))
305 (setq $pivot_count_sx
(1+ $pivot_count_sx
))
306 (if (meqp $pivot_count_sx $pivot_max_sx
)
308 ($print
"Maximum number of pivots reached.")
309 ($print
"Try setting a bigger value for pivot_max_sx.")
310 ($print
"Try setting scale_lp to true.")
312 ($error
"linear_program: maximum number of pivots reached.")))
317 (setf (aref Tab ip i
) (div (aref Tab ip i
) piv
)))
320 (let ((tm (aref Tab i jp
)))
321 (if (not (meqp tm
0))
325 (mul tm
(aref Tab ip j
)))))))))))))
327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
329 ;; Run artificial variable out of basis. ;;
331 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
333 (defun run-out-of-basis-sx (Tab m n basis i
)
336 ((or (= j n
) (not (null jp
))))
337 (if (not (meqp 0 (aref Tab i j
))) ; if Tab[i,j]#0 then column j is not
338 (setq jp j
))) ; in the basis
342 (setf (nth i basis
) jp
)
343 (pivot-sx Tab i jp
(+ 2 m
) (+ 1 n
))
347 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
349 ;; Scaling for the simplex algorithm. (Equilibratium scaling) ;;
351 ;; After scaling, the maximum absolute value in each row/column is 1. ;;
353 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
355 (defun scale-sx (Tab m n sc-fac
)
357 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
358 ;; Scale the rows of A and b. ;;
359 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
363 (let* ((tij (aref Tab i j
))
364 (ta (if (lp-mlsp tij
0) (neg tij
) tij
)))
367 (if (lp-mlsp $epsilon_lp r
)
369 (setf (aref Tab i j
) (div (aref Tab i j
) r
)))))
370 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
371 ;; Scale the columns of A and c. ;;
372 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
376 (let* ((tij (aref Tab i j
))
377 (ta (if (lp-mlsp tij
0) (neg tij
) tij
)))
380 (if (lp-mlsp $epsilon_lp r
)
383 (setf (aref Tab i j
) (div (aref Tab i j
) r
)))
384 (setf (nth j sc-fac
) r
))))))