7fe5c786817c5daf5fc8627dc6ea33c06c615cfb-PR-

Committed 21 Apr 2026 11:10PM UTC coverage: 62.89% (+0.02%) from 62.874%

Build # 7fe5c786817c5daf5fc8627dc6ea33c06c615cfb-PR-

Build Type

push

github

Committed by

web-flow

Commit Message

Merge pull request #21 from kchanqvq/master

optimize sum-linear-expressions

Coverage Stats

3 of 6 new or added lines in 1 file covered. (50.0%)

20 existing lines in 1 file now uncovered.

1049 of 1668 relevant lines covered (62.89%)

1.87 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

63.81

/src/problem.lisp


(uiop:define-package :linear-programming/problem
  (:use :cl
         :iterate
         :linear-programming/conditions
         :linear-programming/expressions)
  (:import-from :alexandria
                #:if-let
                #:hash-table-keys
                #:hash-table-alist)
  (:import-from :linear-programming/utils
                #:validate-bounds
                #:lb-max
                #:ub-min)
  (:export #:make-linear-problem
           #:parse-linear-problem

           #:parsing-error

           #:min
           #:max
           #:integer
           #:binary
           #:bounds
           #:<=
           #:>=
           #:<
           #:>
           #:=
           #:+
           #:*

           #:problem
           #:problem-type
           #:problem-vars
           #:problem-objective-var
           #:problem-objective-func
           #:problem-integer-vars
           #:problem-var-bounds
           #:problem-constraints)
  (:documentation "Handles the representation of linear programming problems."))

(in-package :linear-programming/problem)

(defstruct problem
  "The representation of a linear programming problem."
  (type 'max :read-only t :type (member max min))
  (vars #() :read-only t :type (simple-array symbol (*)))
  (objective-var '#:z :read-only t :type symbol)
  (objective-func nil :read-only t :type list)
  (integer-vars nil :read-only t :type list)
  (var-bounds nil :read-only t :type list)
  (constraints nil :read-only t :type list))

(setf (documentation 'problem-type 'function) "Whether the problem is a `min` or `max` problem."
      (documentation 'problem-vars 'function) "An array of the variables specified in the problem."
      (documentation 'problem-objective-var 'function) "The name of the objective function."
      (documentation 'problem-objective-func 'function) "The objective function as a linear expression alist."
      (documentation 'problem-integer-vars 'function) "A list of variables with integer constraints."
      (documentation 'problem-var-bounds 'function) "A list of variable bounds, of the form `(var . (lower-bound . upper-bound))`."
      (documentation 'problem-constraints 'function) "A list of (in)equality constraints.")

(declaim (inline add-bound))
(defun add-bound (bound-table var new-bound &optional implicit-lb)
  (if-let (old-bound (gethash var bound-table))
    (setf (gethash var bound-table)
          (cons (lb-max (car old-bound) (car new-bound))
                (ub-min (cdr old-bound) (cdr new-bound))))
    (setf (gethash var bound-table)
          (cons (or (car new-bound) implicit-lb)
                (cdr new-bound)))))

(defun parse-linear-constraints (exprs)
  "Parses the list of constraints and returns a list containing a list of simple
inequalities and a list of integer variables."
  (iter expressions-loop
        (with bound-table = (make-hash-table))
        (for expr in exprs)
    (case (first expr)
      ((<= <)
       (when (eq (first expr) '<)
         (warn "< constraints are deprecated in favor of <= ones due to misleading semantics."))
       (collect (cons '<= (mapcar 'parse-linear-expression (rest expr)))
                into equalities))
      ((>= >)
       (when (eq (first expr) '>)
         (warn "> constraints are deprecated in favor of >= ones due to misleading semantics."))
       (collect (cons '<= (reverse (mapcar 'parse-linear-expression (rest expr))))
                into equalities))
      ((=)
       (collect (cons '= (mapcar 'parse-linear-expression (rest expr)))
                into equalities))
      ((integer)
       (unioning (rest expr)
                 into integer))
      ((bounds)
       (dolist (entry (rest expr))
         (cond
           ((symbolp (first entry))
            (unless (and (<= (length entry) 2)
                         (or (null (second entry))
                             (numberp (second entry))))
              (error 'parsing-error :description (format nil "Invalid bounds entry ~S" entry)))
            (add-bound bound-table (first entry) (cons nil (second entry))))
           (t
            (unless (and (numberp (first entry))
                         (symbolp (second entry))
                         (or (null (third entry))
                             (numberp (third entry))))
              (error 'parsing-error :description (format nil "Invalid bounds entry ~S" entry)))
            (add-bound bound-table (second entry) (cons (first entry) (third entry)))))))
      ((binary)
       (unioning (rest expr)
                 into integer)
       (dolist (var (rest expr))
         (add-bound bound-table var '(0 . 1))))
      (t (error 'parsing-error :description (format nil "~A is not a valid constraint" expr))))
    (finally
      (iter equalities-loop
            (for constraint in equalities)
            (for op = (first constraint))
        (iter (for rhs in (nthcdr 2 constraint))
              (for lhs previous rhs initially (second constraint))
          (let* ((lin-exp (sum-linear-expressions
                            lhs (scale-linear-expression rhs -1)))
                 (const (- (cdr (or (assoc '+constant+ lin-exp :test 'eq) '(+constant+ . 0)))))
                 (sum (delete '+constant+ lin-exp :test 'eq :key 'car)))
            (unless const
              (setf const 0))
            (in equalities-loop
              (cond
                ((= 1 (length sum))
                 (let* ((var (first (first sum)))
                        (coef (rest (first sum)))
                        (const (/ const coef))
                        (new-bound (cond
                                     ((eq op '=) (cons const const))
                                     ((<= coef 0) (cons const nil))
                                     (t (cons nil const)))))
                   ;; if there isn't a previous bound, use the implicit bound
                   (add-bound bound-table var new-bound 0)))
                ((eq op '=)
                 (collect (list '= sum const) into simple-constraints))
                ((<= 0 const)
                 (collect (list '<= sum const) into simple-constraints))
                (t
                 (collect (list '>= (scale-linear-expression sum -1) (- const))
                          into simple-constraints))))))
        (finally
         (maphash (lambda (var bound)
                    (validate-bounds (car bound) (cdr bound) var))
                  bound-table)
          (return-from expressions-loop
            (list simple-constraints
                  integer
                  (hash-table-alist bound-table))))))))



(defun parse-linear-problem (objective-exp constraints)
  "Parses the expressions into a linear programming problem"
  (let* ((objective-var-p (eq (first objective-exp) '=))
         (objective (if objective-var-p
                      (third objective-exp)
                      objective-exp))
         (objective-var (if objective-var-p
                          (second objective-exp)
                          (gensym "Z"))))
    (when (and (not objective-var-p)
               (listp (second objective))
               (eq (first (second objective)) '=))
      (setf objective-var (second (second objective)))
      (setf objective (list (first objective) (third (second objective))))
      (setf objective-var-p t))
    (unless (member (first objective) '(min max) :test 'eq)
      (error 'parsing-error
             :description (format nil "~A is neither min nor max in objective function ~A"
                                      (first objective) objective)))
    (let* ((type (first objective))
           (objective-func (parse-linear-expression (second objective)))
           (parsed-constraints (parse-linear-constraints constraints))
           (eq-constraints (first parsed-constraints))
           (integer-constraints (second parsed-constraints))
           (bounds (third parsed-constraints))
           ;collect all of the variables referenced
           (var-set (make-hash-table)))
      (dolist (entry objective-func)
        (setf (gethash (car entry) var-set) t))
      (dolist (var integer-constraints)
        (setf (gethash var var-set) t))
      (dolist (bound bounds)
        (setf (gethash (car bound) var-set) t))
      (dolist (constraint eq-constraints)
        (dolist (entry (second constraint))
          (setf (gethash (car entry) var-set) t)))
      (let ((variables (make-array (hash-table-count var-set)
                                   :initial-contents (hash-table-keys var-set)
                                   :element-type 'symbol)))
        (make-problem :type type
                      :vars variables
                      :objective-var objective-var
                      :objective-func objective-func
                      :integer-vars integer-constraints
                      :var-bounds bounds
                      :constraints eq-constraints)))))


(defmacro make-linear-problem (objective &rest constraints)
  "Creates a linear problem from the expressions in the body"
  `(parse-linear-problem ',objective ',constraints))

1		×
2	(uiop:define-package :linear-programming/problem	×
3	(:use :cl	×
4	:iterate	×
5	:linear-programming/conditions	×
6	:linear-programming/expressions)	×
7	(:import-from :alexandria	×
8	#:if-let	×
9	#:hash-table-keys	×
10	#:hash-table-alist)	×
11	(:import-from :linear-programming/utils	×
12	#:validate-bounds	×
13	#:lb-max	×
14	#:ub-min)	×
15	(:export #:make-linear-problem	×
16	#:parse-linear-problem	×
17		×
18	#:parsing-error	×
19		×
20	#:min	×
21	#:max	×
22	#:integer	×
23	#:binary	×
24	#:bounds	×
25	#:<=	×
26	#:>=	×
27	#:<	×
28	#:>	×
29	#:=	×
30	#:+	×
31	#:*	×
32		×
33	#:problem	×
34	#:problem-type	×
35	#:problem-vars	×
36	#:problem-objective-var	×
37	#:problem-objective-func	×
38	#:problem-integer-vars	×
39	#:problem-var-bounds	×
40	#:problem-constraints)	×
41	(:documentation "Handles the representation of linear programming problems."))	×
42		×
UNCOV 43	(in-package :linear-programming/problem)	×
UNCOV 44		×
45	(defstruct problem	3✔
46	"The representation of a linear programming problem."	3✔
47	(type 'max :read-only t :type (member max min))	×
48	(vars #() :read-only t :type (simple-array symbol (*)))	×
49	(objective-var '#:z :read-only t :type symbol)	×
50	(objective-func nil :read-only t :type list)	×
51	(integer-vars nil :read-only t :type list)	×
52	(var-bounds nil :read-only t :type list)	×
53	(constraints nil :read-only t :type list))	×
54		×
55	(setf (documentation 'problem-type 'function) "Whether the problem is a `min` or `max` problem."	×
56	(documentation 'problem-vars 'function) "An array of the variables specified in the problem."	×
57	(documentation 'problem-objective-var 'function) "The name of the objective function."	×
58	(documentation 'problem-objective-func 'function) "The objective function as a linear expression alist."	×
59	(documentation 'problem-integer-vars 'function) "A list of variables with integer constraints."	×
60	(documentation 'problem-var-bounds 'function) "A list of variable bounds, of the form `(var . (lower-bound . upper-bound))`."	×
UNCOV 61	(documentation 'problem-constraints 'function) "A list of (in)equality constraints.")	×
UNCOV 62		×
UNCOV 63	(declaim (inline add-bound))	×
UNCOV 64	(defun add-bound (bound-table var new-bound &optional implicit-lb)	×
UNCOV 65	(if-let (old-bound (gethash var bound-table))	×
UNCOV 66	(setf (gethash var bound-table)	×
UNCOV 67	(cons (lb-max (car old-bound) (car new-bound))	×
UNCOV 68	(ub-min (cdr old-bound) (cdr new-bound))))	×
UNCOV 69	(setf (gethash var bound-table)	×
UNCOV 70	(cons (or (car new-bound) implicit-lb)	×
UNCOV 71	(cdr new-bound)))))	×
UNCOV 72		×
73	(defun parse-linear-constraints (exprs)	3✔
74	"Parses the list of constraints and returns a list containing a list of simple	3✔
75	inequalities and a list of integer variables."	3✔
76	(iter expressions-loop	3✔
77	(with bound-table = (make-hash-table))	3✔
78	(for expr in exprs)	3✔
79	(case (first expr)	3✔
80	((<= <)	3✔
81	(when (eq (first expr) '<)	3✔
82	(warn "< constraints are deprecated in favor of <= ones due to misleading semantics."))	3✔
83	(collect (cons '<= (mapcar 'parse-linear-expression (rest expr)))	3✔
84	into equalities))	3✔
85	((>= >)	3✔
86	(when (eq (first expr) '>)	3✔
87	(warn "> constraints are deprecated in favor of >= ones due to misleading semantics."))	3✔
88	(collect (cons '<= (reverse (mapcar 'parse-linear-expression (rest expr))))	3✔
89	into equalities))	3✔
90	((=)	3✔
91	(collect (cons '= (mapcar 'parse-linear-expression (rest expr)))	3✔
92	into equalities))	3✔
93	((integer)	3✔
94	(unioning (rest expr)	3✔
95	into integer))	3✔
96	((bounds)	3✔
97	(dolist (entry (rest expr))	3✔
98	(cond	3✔
99	((symbolp (first entry))	3✔
100	(unless (and (<= (length entry) 2)	3✔
101	(or (null (second entry))	3✔
102	(numberp (second entry))))	3✔
103	(error 'parsing-error :description (format nil "Invalid bounds entry ~S" entry)))	3✔
104	(add-bound bound-table (first entry) (cons nil (second entry))))	3✔
105	(t	3✔
106	(unless (and (numberp (first entry))	3✔
107	(symbolp (second entry))	3✔
108	(or (null (third entry))	3✔
109	(numberp (third entry))))	3✔
110	(error 'parsing-error :description (format nil "Invalid bounds entry ~S" entry)))	3✔
111	(add-bound bound-table (second entry) (cons (first entry) (third entry)))))))	3✔
112	((binary)	3✔
113	(unioning (rest expr)	3✔
114	into integer)	3✔
115	(dolist (var (rest expr))	3✔
116	(add-bound bound-table var '(0 . 1))))	3✔
117	(t (error 'parsing-error :description (format nil "~A is not a valid constraint" expr))))	3✔
118	(finally	3✔
119	(iter equalities-loop	3✔
120	(for constraint in equalities)	3✔
121	(for op = (first constraint))	3✔
122	(iter (for rhs in (nthcdr 2 constraint))	3✔
123	(for lhs previous rhs initially (second constraint))	3✔
124	(let* ((lin-exp (sum-linear-expressions	3✔
125	lhs (scale-linear-expression rhs -1)))	3✔
126	(const (- (cdr (or (assoc '+constant+ lin-exp :test 'eq) '(+constant+ . 0)))))	3✔
127	(sum (delete '+constant+ lin-exp :test 'eq :key 'car)))	3✔
128	(unless const	3✔
129	(setf const 0))	3✔
130	(in equalities-loop	3✔
131	(cond	3✔
132	((= 1 (length sum))	3✔
133	(let* ((var (first (first sum)))	3✔
134	(coef (rest (first sum)))	3✔
135	(const (/ const coef))	3✔
136	(new-bound (cond	3✔
UNCOV 137	((eq op '=) (cons const const))	×
138	((<= coef 0) (cons const nil))	3✔
139	(t (cons nil const)))))	3✔
140	;; if there isn't a previous bound, use the implicit bound	3✔
141	(add-bound bound-table var new-bound 0)))	3✔
142	((eq op '=)	3✔
143	(collect (list '= sum const) into simple-constraints))	3✔
144	((<= 0 const)	3✔
145	(collect (list '<= sum const) into simple-constraints))	3✔
146	(t	3✔
147	(collect (list '>= (scale-linear-expression sum -1) (- const))	3✔
148	into simple-constraints))))))	3✔
149	(finally	3✔
150	(maphash (lambda (var bound)	3✔
151	(validate-bounds (car bound) (cdr bound) var))	3✔
152	bound-table)	3✔
153	(return-from expressions-loop	3✔
154	(list simple-constraints	3✔
155	integer	3✔
156	(hash-table-alist bound-table))))))))	3✔
UNCOV 157		×
UNCOV 158		×
UNCOV 159		×
160	(defun parse-linear-problem (objective-exp constraints)	3✔
161	"Parses the expressions into a linear programming problem"	3✔
162	(let* ((objective-var-p (eq (first objective-exp) '=))	3✔
163	(objective (if objective-var-p	3✔
164	(third objective-exp)	3✔
165	objective-exp))	3✔
166	(objective-var (if objective-var-p	3✔
167	(second objective-exp)	3✔
168	(gensym "Z"))))	3✔
169	(when (and (not objective-var-p)	3✔
170	(listp (second objective))	3✔
171	(eq (first (second objective)) '=))	3✔
172	(setf objective-var (second (second objective)))	3✔
173	(setf objective (list (first objective) (third (second objective))))	3✔
174	(setf objective-var-p t))	3✔
175	(unless (member (first objective) '(min max) :test 'eq)	3✔
176	(error 'parsing-error	3✔
177	:description (format nil "~A is neither min nor max in objective function ~A"	3✔
178	(first objective) objective)))	3✔
179	(let* ((type (first objective))	3✔
180	(objective-func (parse-linear-expression (second objective)))	3✔
181	(parsed-constraints (parse-linear-constraints constraints))	3✔
182	(eq-constraints (first parsed-constraints))	3✔
183	(integer-constraints (second parsed-constraints))	3✔
184	(bounds (third parsed-constraints))	3✔
185	;collect all of the variables referenced	3✔
186	(var-set (make-hash-table)))	3✔
187	(dolist (entry objective-func)	3✔
188	(setf (gethash (car entry) var-set) t))	3✔
189	(dolist (var integer-constraints)	3✔
190	(setf (gethash var var-set) t))	3✔
191	(dolist (bound bounds)	3✔
192	(setf (gethash (car bound) var-set) t))	3✔
193	(dolist (constraint eq-constraints)	3✔
194	(dolist (entry (second constraint))	3✔
195	(setf (gethash (car entry) var-set) t)))	3✔
196	(let ((variables (make-array (hash-table-count var-set)	3✔
197	:initial-contents (hash-table-keys var-set)	3✔
198	:element-type 'symbol)))	3✔
199	(make-problem :type type	3✔
200	:vars variables	3✔
201	:objective-var objective-var	3✔
202	:objective-func objective-func	3✔
203	:integer-vars integer-constraints	3✔
204	:var-bounds bounds	3✔
205	:constraints eq-constraints)))))	3✔
UNCOV 206		×
UNCOV 207		×
208	(defmacro make-linear-problem (objective &rest constraints)	3✔
209	"Creates a linear problem from the expressions in the body"	3✔
210	`(parse-linear-problem ',objective ',constraints))	3✔

neil-lindquist / linear-programming / 7fe5c786817c5daf5fc8627dc6ea33c06c615cfb-PR-

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous