/
core.clj
245 lines (221 loc) · 8.78 KB
/
core.clj
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
(ns loco.core
(:import (org.chocosolver.solver.variables VF IntVar)
(org.chocosolver.solver.exception SolverException)
(org.chocosolver.solver ResolutionPolicy
Solver)
org.chocosolver.solver.constraints.Constraint
(org.chocosolver.solver.search.strategy ISF
strategy.AbstractStrategy)
(org.chocosolver.solver.search.loop.monitors SMF)
(org.chocosolver.util ESat)))
(defn- namey?
[x]
(try (boolean (name x))
(catch Exception e
false)))
(defn- id
[]
(gensym "id"))
(def ^:dynamic *solver*
"(internal) Bound to the Loco solver object during problem construction / solving"
nil)
(defmulti ->choco*
"(INTERNAL) Given Clojure data generated by the Loco DSL, returns a Choco variable (to be used inside
a constraint), or returns a constraint (to be posted to the solver)."
(fn [data]
(if (and (vector? data)
(keyword? (first data)))
:vector-var-name
(or (:type data) (type data)))))
(defn- intersect-domains
[d1 d2]
(cond
(and (not (map? d1))
(not (map? d2))) (filter (set d1) d2)
(and (not (map? d1))
(map? d2)) (let [{lo :min hi :max} d2]
(filter #(<= lo % hi) d1))
(and (map? d1)
(not (map? d2))) (recur d2 d1)
:else (let [{lo1 :min hi1 :max b1? :bounded} d1
{lo2 :min hi2 :max b2? :bounded} d2
m {:min (max lo1 lo2)
:max (min hi1 hi2)}]
(if (and b1? b2?)
(assoc m :bounded true)
m))))
(defn- top-level-var-declarations
"finds top-level domain declarations, merges them per-variable,
and returns a list of variable declarations"
[data]
(let [domain-decls (filter :can-init-var data)
all-domains (group-by :name domain-decls)]
(for [[var-name decls] all-domains
:let [final-domain (reduce intersect-domains (map :domain decls))]]
(if (if (map? final-domain)
(= final-domain {:min 0 :max 1})
(= #{0 1} (set final-domain)))
{:type :bool-var
:name var-name
:real-name (name (gensym "bool-var"))}
{:type :int-var
:name var-name
:real-name (name (gensym "int-var"))
:domain (reduce intersect-domains (map :domain decls))}))))
(defn- without-top-level-var-declarations
[data]
(remove :can-init-var data))
(defrecord LocoSolver
[csolver memo-table my-vars n-solutions])
(defn- new-solver
[]
(->LocoSolver
(Solver. (str (gensym "solver")))
(atom {})
(atom {})
(atom 0)))
(defn- find-int-var
[solver n]
(or (@(:my-vars solver) n)
(throw (IllegalAccessException. (str "var with name " n
" doesn't have a corresponding "
"\"$in\" call in the top-level"
" of the problem")))))
(defn- get-val
[v]
(.getLB v))
(defn ->choco
"(INTERNAL) Memoized version of ->choco*"
[data]
(let [lookup (when (:id data)
(@(:memo-table *solver*) (:id data)))]
(if lookup
lookup
(let [result (->choco* data)]
(when (:id data)
(swap! (:memo-table *solver*) assoc (:id data) result))
result))))
(defmethod ->choco* java.lang.Number
[data]
data)
(defmethod ->choco* clojure.lang.Keyword
[data]
(find-int-var *solver* data))
(defmethod ->choco* :vector-var-name
[data]
(find-int-var *solver* data))
(defn- return-next-solution
[]
(let [n (dec @(:n-solutions *solver*))]
(into {}
(for [[var-name v] @(:my-vars *solver*)
:when (if (keyword? var-name)
(not= (first (name var-name)) \_)
(not= (first (name (first var-name))) \_))]
[var-name (get-val v)]))))
(defn- Solution->solution-map
[S]
(into {} (for [[var-name v] @(:my-vars *solver*)
:when (if (keyword? var-name)
(not= (first (name var-name)) \_)
(not= (first (name (first var-name))) \_))]
[var-name (.getIntVal S v)])))
(defn- constrain!
[constraint]
(.post (:csolver *solver*) constraint))
(defn- problem->solver
[problem]
(let [problem (concat (top-level-var-declarations problem)
(without-top-level-var-declarations problem)) ; dig for the var declarations and put them at the front
s (new-solver)]
(binding [*solver* s]
(doseq [i problem
:let [i (->choco i)]]
(when (instance? Constraint i)
(constrain! i)))
(let [vars (vals @(:my-vars s))
strategy (ISF/minDom_LB (into-array IntVar vars))]
(.set (:csolver s) (into-array AbstractStrategy [strategy])))
s)))
(defn- feasible?
"After the problem has executed, determines whether the problem was feasible"
[]
(let [f (.isFeasible (:csolver *solver*))]
(condp = f
ESat/TRUE true
ESat/FALSE false
ESat/UNDEFINED (throw (Exception. "Solver has not been run yet")))))
(defn- solve!
[args]
(let [n-atom (:n-solutions *solver*)
csolver (:csolver *solver*)]
(when (:timeout args)
(SMF/limitTime csolver (long (:timeout args))))
(cond
(:maximize args) (do (.findOptimalSolution csolver ResolutionPolicy/MAXIMIZE
(->choco (:maximize args)))
(and (feasible?)
(swap! n-atom inc)
true))
(:minimize args) (do (.findOptimalSolution csolver ResolutionPolicy/MINIMIZE
(->choco (:minimize args)))
(and (feasible?)
(swap! n-atom inc)
true))
:else (if (= @n-atom 0)
(and (.findSolution csolver)
(swap! n-atom inc)
true)
(and (.nextSolution csolver)
(swap! n-atom inc)
true)))))
(defn- solution*
[args]
(when (solve! args)
(return-next-solution)))
(defn solution
"Solves the problem using the specified constraints and returns a map from variable names to their values (or nil if there is no solution).
Keyword arguments:
- :maximize <var> - finds the solution maximizing the given variable.
- :minimize <var> - finds the solution minimizing the given variable.
- :feasible true - optimizes time by guaranteeing that the problem is feasible before trying to maximize/minimize a variable.
- :timeout <number> - stops after a certain amount of milliseconds (returns nil, or best solution so far when min/maxing a variable)
Note: returned solution maps have the metadata {:loco/solution <n>} denoting that it is the nth solution found (starting with 0)."
[problem & args]
(binding [*solver* (problem->solver problem)]
(let [args (apply hash-map args)]
(solution* args))))
(defn solutions
"Solves the solver using the constraints and returns a lazy seq of maps (for each solution) from variable names to their values.
Keyword arguments:
- :timeout <number> - the sequence ends prematurely if the timer exceeds a certain number of milliseconds.
- :maximize <var> - finds all solutions that maximize the given var or expression. NOT lazy.
- :minimize <var> - finds all solutions that minimize the given var or expression. NOT lazy."
[problem & args]
(let [solver (problem->solver problem)
^Solver csolver (:csolver solver)
args (apply hash-map args)
timeout (:timeout args)
maximize (:maximize args)
minimize (:minimize args)
args (dissoc args :timeout :maximize :minimize)]
(when timeout
(SMF/limitTime csolver timeout))
(cond
maximize (binding [*solver* solver]
(do (.findAllOptimalSolutions csolver ResolutionPolicy/MAXIMIZE
(->choco maximize)
false)
(map #(binding [*solver* solver]
(Solution->solution-map %))
(.. csolver (getSolutionRecorder) (getSolutions)))))
minimize (binding [*solver* solver]
(do (.findAllOptimalSolutions csolver ResolutionPolicy/MINIMIZE
(->choco minimize)
false)
(map #(binding [*solver* solver]
(Solution->solution-map %))
(.. csolver (getSolutionRecorder) (getSolutions)))))
:else (take-while identity
(repeatedly #(binding [*solver* solver]
(solution* args)))))))