Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Added more generalized term abbreviations – (+ (* 1 x)) can now be wr…

…itten as (* 1 x), (+ x), or just x.
  • Loading branch information...
commit 464d45df28ce1a02027f39efe97f2d6b8b155519 1 parent 40de819
@sellout authored
Showing with 29 additions and 19 deletions.
  1. +29 −19 high-level.lisp
View
48 high-level.lisp
@@ -13,7 +13,8 @@
;;; – coefficients & bounds can be arbitrary lisp forms
;;; - terms in constraints don't have to be in same order as in the objective
;;; function
-;;; - (* 1 x) can be abbreviated as x in constraints
+;;; - (+ (* 4 x)) can be abbreviated as (* 4 x)
+;;; - (* 1 x) can be abbreviated as x
;;; - not all variables need to occur in every constraint
;;; - variables can be left out of bounds list, indicating free variables
;;; - instead of :LOWER and :UPPER, use (<= lb (+ (* 4 x) ...) ub) [if there is
@@ -21,10 +22,19 @@
;;; (>= x lb), not (<= lb x)?]
;;;
;;; TODO:
-;;; - abbreviate (* 1 x) as x in objective function
;;; - integrate bounds with constraints (either discover that it's just as fast
;;; to combine them, or add code to separate out bounds before expansion)
-;;; - abbreviate (+ (* 4 x)) as (* 4 x)
+
+(defun standardize-equation (form)
+ "Converts all equations [(+ (* 4 x) (* 7 y)), x, (* 4 x), etc.] into the form
+ ((4 x) (7 y)) to make our processing simpler."
+ (mapcar (lambda (term)
+ (if (listp term)
+ (cdr term)
+ (list 1 term)))
+ (if (listp form)
+ (cdr form) ; get rid of the +
+ (list form))))
(defun get-specified-bounds (lower upper)
(if lower
@@ -60,16 +70,14 @@
;;; capture, multiple expansion, … need to fix all that.
(defmacro make-linear-program
(direction objective-function &key subject-to bounds)
- `(let* ((variables (mapcar #'third (cdr ',objective-function)))
+ `(let* ((variables ',(mapcar #'second
+ (standardize-equation objective-function)))
(constraint-bounds (list ,@(get-bounds subject-to)))
(bounds-bounds (list ,@(get-bounds bounds)))
(constraint-coefficients
(list ,@(mapcar (lambda (constraint)
- `(list ,@(mapcar (lambda (product)
- (typecase product
- (list (second product))
- (t 1)))
- (cdadr constraint))))
+ `(list ,@(mapcar #'first
+ (standardize-equation (second constraint)))))
subject-to))))
(make-instance
'glpk:linear-problem
@@ -93,15 +101,17 @@
variables)
:constraints (loop for constraint in constraint-bounds
for row from 0
- appending (loop for product in (cdar constraint)
+ appending (loop for product in (standardize-equation (car constraint))
for col from 0
- collecting (typecase product
- (symbol (list (1+ row)
- (1+ (position product variables))
- 1))
- (cons (list (1+ row)
- (1+ (position (third product) variables))
- (elt (elt constraint-coefficients row)
- col))))))
- :objective (list ,@(mapcar #'second (cdr objective-function)))
+ collecting (list (1+ row)
+ (progn
+ (format nil "~a - ~a - ~a~%"
+ (second product)
+ (position (second product) variables)
+ variables)
+ (1+ (position (second product) variables)))
+ (elt (elt constraint-coefficients row)
+ col))))
+ :objective (list ,@(mapcar #'first
+ (standardize-equation objective-function)))
:direction (if (eq ,direction :maximize) :max :min))))
Please sign in to comment.
Something went wrong with that request. Please try again.