7fe5c786817c5daf5fc8627dc6ea33c06c615cfb-PR-

Committed 21 Apr 2026 11:10PM UTC coverage: 62.11% (-0.8%) 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.

1036 of 1668 relevant lines covered (62.11%)

0.62 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	1✔
46	"The representation of a linear programming problem."	1✔
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)	1✔
74	"Parses the list of constraints and returns a list containing a list of simple	1✔
75	inequalities and a list of integer variables."	1✔
76	(iter expressions-loop	1✔
77	(with bound-table = (make-hash-table))	1✔
78	(for expr in exprs)	1✔
79	(case (first expr)	1✔
80	((<= <)	1✔
81	(when (eq (first expr) '<)	1✔
82	(warn "< constraints are deprecated in favor of <= ones due to misleading semantics."))	1✔
83	(collect (cons '<= (mapcar 'parse-linear-expression (rest expr)))	1✔
84	into equalities))	1✔
85	((>= >)	1✔
86	(when (eq (first expr) '>)	1✔
87	(warn "> constraints are deprecated in favor of >= ones due to misleading semantics."))	1✔
88	(collect (cons '<= (reverse (mapcar 'parse-linear-expression (rest expr))))	1✔
89	into equalities))	1✔
90	((=)	1✔
91	(collect (cons '= (mapcar 'parse-linear-expression (rest expr)))	1✔
92	into equalities))	1✔
93	((integer)	1✔
94	(unioning (rest expr)	1✔
95	into integer))	1✔
96	((bounds)	1✔
97	(dolist (entry (rest expr))	1✔
98	(cond	1✔
99	((symbolp (first entry))	1✔
100	(unless (and (<= (length entry) 2)	1✔
101	(or (null (second entry))	1✔
102	(numberp (second entry))))	1✔
103	(error 'parsing-error :description (format nil "Invalid bounds entry ~S" entry)))	1✔
104	(add-bound bound-table (first entry) (cons nil (second entry))))	1✔
105	(t	1✔
106	(unless (and (numberp (first entry))	1✔
107	(symbolp (second entry))	1✔
108	(or (null (third entry))	1✔
109	(numberp (third entry))))	1✔
110	(error 'parsing-error :description (format nil "Invalid bounds entry ~S" entry)))	1✔
111	(add-bound bound-table (second entry) (cons (first entry) (third entry)))))))	1✔
112	((binary)	1✔
113	(unioning (rest expr)	1✔
114	into integer)	1✔
115	(dolist (var (rest expr))	1✔
116	(add-bound bound-table var '(0 . 1))))	1✔
117	(t (error 'parsing-error :description (format nil "~A is not a valid constraint" expr))))	1✔
118	(finally	1✔
119	(iter equalities-loop	1✔
120	(for constraint in equalities)	1✔
121	(for op = (first constraint))	1✔
122	(iter (for rhs in (nthcdr 2 constraint))	1✔
123	(for lhs previous rhs initially (second constraint))	1✔
124	(let* ((lin-exp (sum-linear-expressions	1✔
125	lhs (scale-linear-expression rhs -1)))	1✔
126	(const (- (cdr (or (assoc '+constant+ lin-exp :test 'eq) '(+constant+ . 0)))))	1✔
127	(sum (delete '+constant+ lin-exp :test 'eq :key 'car)))	1✔
128	(unless const	1✔
129	(setf const 0))	1✔
130	(in equalities-loop	1✔
131	(cond	1✔
132	((= 1 (length sum))	1✔
133	(let* ((var (first (first sum)))	1✔
134	(coef (rest (first sum)))	1✔
135	(const (/ const coef))	1✔
136	(new-bound (cond	1✔
UNCOV 137	((eq op '=) (cons const const))	×
138	((<= coef 0) (cons const nil))	1✔
139	(t (cons nil const)))))	1✔
140	;; if there isn't a previous bound, use the implicit bound	1✔
141	(add-bound bound-table var new-bound 0)))	1✔
142	((eq op '=)	1✔
143	(collect (list '= sum const) into simple-constraints))	1✔
144	((<= 0 const)	1✔
145	(collect (list '<= sum const) into simple-constraints))	1✔
146	(t	1✔
147	(collect (list '>= (scale-linear-expression sum -1) (- const))	1✔
148	into simple-constraints))))))	1✔
149	(finally	1✔
150	(maphash (lambda (var bound)	1✔
151	(validate-bounds (car bound) (cdr bound) var))	1✔
152	bound-table)	1✔
153	(return-from expressions-loop	1✔
154	(list simple-constraints	1✔
155	integer	1✔
156	(hash-table-alist bound-table))))))))	1✔
UNCOV 157		×
UNCOV 158		×
UNCOV 159		×
160	(defun parse-linear-problem (objective-exp constraints)	1✔
161	"Parses the expressions into a linear programming problem"	1✔
162	(let* ((objective-var-p (eq (first objective-exp) '=))	1✔
163	(objective (if objective-var-p	1✔
164	(third objective-exp)	1✔
165	objective-exp))	1✔
166	(objective-var (if objective-var-p	1✔
167	(second objective-exp)	1✔
168	(gensym "Z"))))	1✔
169	(when (and (not objective-var-p)	1✔
170	(listp (second objective))	1✔
171	(eq (first (second objective)) '=))	1✔
172	(setf objective-var (second (second objective)))	1✔
173	(setf objective (list (first objective) (third (second objective))))	1✔
174	(setf objective-var-p t))	1✔
175	(unless (member (first objective) '(min max) :test 'eq)	1✔
176	(error 'parsing-error	1✔
177	:description (format nil "~A is neither min nor max in objective function ~A"	1✔
178	(first objective) objective)))	1✔
179	(let* ((type (first objective))	1✔
180	(objective-func (parse-linear-expression (second objective)))	1✔
181	(parsed-constraints (parse-linear-constraints constraints))	1✔
182	(eq-constraints (first parsed-constraints))	1✔
183	(integer-constraints (second parsed-constraints))	1✔
184	(bounds (third parsed-constraints))	1✔
185	;collect all of the variables referenced	1✔
186	(var-set (make-hash-table)))	1✔
187	(dolist (entry objective-func)	1✔
188	(setf (gethash (car entry) var-set) t))	1✔
189	(dolist (var integer-constraints)	1✔
190	(setf (gethash var var-set) t))	1✔
191	(dolist (bound bounds)	1✔
192	(setf (gethash (car bound) var-set) t))	1✔
193	(dolist (constraint eq-constraints)	1✔
194	(dolist (entry (second constraint))	1✔
195	(setf (gethash (car entry) var-set) t)))	1✔
196	(let ((variables (make-array (hash-table-count var-set)	1✔
197	:initial-contents (hash-table-keys var-set)	1✔
198	:element-type 'symbol)))	1✔
199	(make-problem :type type	1✔
200	:vars variables	1✔
201	:objective-var objective-var	1✔
202	:objective-func objective-func	1✔
203	:integer-vars integer-constraints	1✔
204	:var-bounds bounds	1✔
205	:constraints eq-constraints)))))	1✔
UNCOV 206		×
UNCOV 207		×
208	(defmacro make-linear-problem (objective &rest constraints)	1✔
209	"Creates a linear problem from the expressions in the body"	1✔
210	`(parse-linear-problem ',objective ',constraints))	1✔

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