As a side toy project for my Genetic Algorithm, I decided to try to create a macro that lets you use maximize: ... subject to: ... linear problem notation to generate fitness functions. Those fitness functions can then be used in a genetic algorithm to solve linear problems through brute force.

Yes, I'm aware genetic algorithms are the (very) wrong tool for the job here, but it's for kicks, not actual use.

As an example of its use, say you have the following problem:

A calculator company produces a scientific calculator and a graphing calculator. Long-term projections indicate an expected demand of at least 100 scientific and 80 graphing calculators each day. Because of limitations on production capacity, no more than 200 scientific and 170 graphing calculators can be made daily. To satisfy a shipping contract, a total of at least 200 calculators much be shipped each day. If each scientific calculator sold results in a $2 loss, but each graphing calculator produces a $5 profit, how many of each type should be made daily to maximize net profits?

To create a fitness function that can solve this problem, you can write:

(fit-func-for [:s :g]
              :maximize (+ (* :s -2) (* :g 5)) ; Profit function
              :subject-to (<= 100 :s 200) ; Problem constraints
                          (<= 80 :g 170)
                          (<= 200 (+ :s :g) 1e6))))

Where :s is representing scientific calculators, and :g graphing calculators.

This works by, basically, translating the above code into:

(->Linear-Problem (fn [vars] ; Profit
                    (+ (* (:s vars) -2) (* (:g vars) 5)))

                  (fn [vars] ; Constraints
                      [100 (:s vars) 200]
                      [80 (:g vars) 170]
                      [200 (+ (:s vars) (:g vars))])))

Then giving the resulting Linear-Problem to evaluate-problem, and sticking the call in a quoted function that accepts the genes to test.


(def f
  (fit-func-for [:s :g]
                :maximize (+ (* :s -2) (* :g 5))
                :subject-to (<= 100 :s 200)
                            (<= 80 :g 170)
                            (<= 200 (+ :s :g) 1e6)))
=> #'genetic-algorithm.test-fit-funcs.linear-calculator/f

(f [-1 1000]) ; Outright illegal
=> -18273

(f [150 120]) ; Legal, but not optimal
=> 300

(f [100 170]) ; The optimal answer
=> 650

(f [99 171])
=> 607

(f [100 180])
=> 450


  • Can accept either <= or >= in constraints.
  • Can handle an arbitrary number of variables to find for.
  • Not a whole lot else. It's pretty limited currently.

It works actually far better than I expected. It generates fitness functions that can solve the problem perfectly in a couple generations, or less.

This is the most complicated macro I've ever written though, and the code gets a little odd feeling in some places. I'd like advice mainly on how I can write this better/most idiomatically, but also on a few other points:

  • I'm doing some traversing of nested structures to find/modify parts of code (replace-keys-with-call, find-number) using explicit recursion. This works fine, but I'm wondering if there's a better way.

  • If the profit for an illegal result is high enough, it can overcome the constraint penalty, and cause bad results to score highly. To get around this, I'm finding the largest number in the profit function, then multiplying the constraint penalty by it to make sure the error will always "win". This is overly simple though, and causes a couple significant problems:

    • This forces use of only + and *, since - and / aren't commutative, so large number literals being present doesn't necessarily mean large profits.
    • This prevents + and * from being mixed, which limits what it can be used for.
  • Anything else. I don't mind minor suggestions.

If the above limitations are too great, you can just bypass the macro by constructing a Linear-Problem manually and specifying the error multiplier you want to use, but where's the fun in that?

(ns genetic-algorithm.text-ui.linear-generator)

(defrecord Linear-Problem [profit-f constraint-f])

(defn range-error
  "Returns how out of bounds n is from [c-min c-max]. Bounds are inclusive.
c-min defaults to 0 if not supplied."
  ([c-min n c-max]
     (<= c-min n c-max) 0
     (> c-min n) (- c-min n)
     :else (- n c-max)))

  ([n c-max]
   (range-error 0 n c-max)))

(defn total-range-error
  "Sums the total range error defined by each range-vec.
  Each vec must be a seq of 2 or 3 items, representing either [range-min n range-max],
    or [n range-max] which assumes a min of 0.
  Delegates to range-error."
  [& range-vecs]
  (->> range-vecs
       (map #(apply range-error %))
       (apply +)))

(defn evaluate-problem
  "Returns a fitness value based on the profit and constraint functions, and the var values via var-map.
  Constraint-mult multiplies the constarint error to make up for the profit function overcoming constraint error. 
   Should be greater than the largest profit multiplier in the profit function."
  [l-prob var-map constraint-mult]
  (let [{:keys [profit-f constraint-f]} l-prob]
    (+ (profit-f var-map)
       (- (* constraint-mult (constraint-f var-map))))))

; TODO: Generalize the number? part
(defn find-number
  "Searches through a nested coll looking for a number as decided by finder-f.
  finder-f is a function taking a list of numbers, and returning a single number.
  Returns default if no numbers are found."
  [coll default finder-f]
  (let [candidates (->> coll
                        (map (fn [e]
                                 (number? e) e
                                 (coll? e) (find-number e default finder-f))))

                        (filter number?))]

    (if (empty? candidates)
      (finder-f candidates))))

(defn max-number [coll]
  (find-number coll 1 (partial apply max)))

(defn min-number [coll]
  (find-number coll 1 (partial apply min)))

(defn replace-keys-with-call
  "Replaces all keywords in the nested coll with (:keyword map-sym)."
  [coll map-sym]
  (->> coll
       (map (fn [e]
                (keyword? e) (list e map-sym)
                (coll? e) (replace-keys-with-call e map-sym)
                :else e)))

       (apply list)))

(defn process-profit-expr
  "Returns a processed profit function from the given profit expression."
  [profit-expr map-sym]
  `(fn [~map-sym]
     ~(replace-keys-with-call profit-expr map-sym)))

; TODO: Throw parse error for too many args?
; TODO `resolve` both op syms so backticks can be used in testing?
; TODO: Generalize and allow for more ops? Accept a map of symbol->transformations?
(defn standardize-op [constraint-expr]
  (let [correct-op '<=
        [op & args] constraint-expr]
    (if (= op correct-op)
      (apply list correct-op (reverse args)))))

(defn process-constraint-exprs [constraint-exprs map-sym]
  (let [procd (->> constraint-exprs
                   (map #(replace-keys-with-call % map-sym))
                   (map standardize-op)
                   (mapv #(vec (drop 1 %))))]

    `(fn [~map-sym]
       (apply total-range-error ~procd))))

(defn- linear-problem-expr
  "Returns a expression that evaluates to a Linear-Problem object based on the given profit and constraint expressions."
  [profit-expr constraint-exprs]
  (let [map-sym (gensym 'lp-obj-for-map)
        prof-f (process-profit-expr profit-expr map-sym)
        cons-f (process-constraint-exprs constraint-exprs map-sym)]

    `(->Linear-Problem ~prof-f ~cons-f)))

(defn genes+vars->var-map
  "Accepts a gene sequence and a list of keyword vars, and returns a map mapping each gene to a var."
  [genes vars]
  (into {}
    (map vector vars genes)))

(defmacro fit-func-for
  "Accepts a linear porgramming-like syntax, and evaluates to a profit-seeking fitness function that accepts a vector
   of genes, and returns the calculated fitness."
  [vars _ profit _ & constraints]
  (let [; How much more significant errors are than profit. Arbitrary.
        profit-error-mult 5

        ; Find the largest number in the profit expression so we can make sure the
        ; contraint error overcomes any profit from illegal results.
        ; Assumes only * and + will be used, and use of + and * won't be mixed.
        max-prof-mult (max-number profit) ; Find the
        error-mult (* profit-error-mult max-prof-mult)

        lp (linear-problem-expr profit constraints)]

    `(fn [genes#]
       (let [var-map# (genes+vars->var-map genes# ~vars)]
         (evaluate-problem ~lp var-map# ~error-mult)))))
  • 1
    \$\begingroup\$ Since posting this, I've gotten rid of Linear-Problem altogether, and allowed for a :minimize variant that prefixes the profit function with (- ...). This change basically turns a profit function into a cost function. \$\endgroup\$ – Carcigenicate Apr 12 '18 at 3:03

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.