Genetic Algorithms

Lee Spector
lspector@hampshire.edu


This file contains code for two systems that use genetic algorithms
to solve the Traveling Salesman Problem, each with an example of its
use. The first is Tanimoto's. The second is one that I wrote, based 
on the representation in Dewdney's THE NEW TURING OMNIBUS.

 


;;; GENETIC.CL
;;; A "genetic" algorithm for the Traveling Salesman Problem.

;;; (C) Copyright 1995 by Steven L. Tanimoto.
;;; This program is described in Chapter 5 ("Search") of
;;; "The Elements of Artificial Intelligence Using Common Lisp," 2nd ed.,
;;; published by W. H. Freeman, 41 Madison Ave., New York, NY 10010.
;;; Permission is granted for noncommercial use and modification of
;;; this program, provided that this copyright notice is retained
;;; and followed by a notice of any modifications made to the program.

;;; Note that due to the use of random numbers, the results
;;; vary from run to run.

;;; Our problem uses a graph whose nodes present cities and
;;; whose arcs carry distances, much as for the UNIFORM-COST
;;; search and A* programs.

;;; Here is a hash table to store the distance information:
(let ((distance-info (make-hash-table :size 20)) )
  (defun set-distances (x y)
    (setf (gethash x distance-info) y) )
  (defun get-distances (x)
    (gethash x distance-info) )
  )

;;; Here is the set of cities for this problem:
(defparameter *cities*
              '(seattle portland spokane wenatchee bellingham) )
(defparameter *ncities* (length *cities*))

;;; Here are the distances.
;;; (These were estimated and not from a map)

(set-distances 'seattle
               '((portland . 150)(spokane . 350)
                 (wenatchee . 100)(bellingham . 90) ) )
(set-distances 'portland
               '((seattle . 150)(spokane . 400)
                 (wenatchee . 200)(bellingham . 235) ) )

(set-distances 'spokane
               '((portland . 400)(seattle . 350)
                 (wenatchee . 275)(bellingham . 385) ) )
(set-distances 'wenatchee
               '((portland . 200)(spokane . 275)
                 (seattle . 100)(bellingham . 130) ) )
(set-distances 'bellingham
               '((portland . 235)(seattle . 90)
                 (spokane . 385)(wenatchee . 130) ) )

;;; We represent an individual as a dotted pair whose left part
;;; is a list of cities and whose right part is a strength value.
(defun get-path (individual)
  "Returns the list of cities associated with INDIVIDUAL."
  (first individual) )

(defun get-strength (individual)
  "Returns the strength value associated with INDIVIDUAL."
  (rest individual) )

(defparameter *initial-population*
  '( ((seattle seattle seattle seattle seattle) . 0) ) )

(defvar *population*)
(defvar *current-min-strength*)
(defvar *current-pop-size*)

(defparameter *population-limit* 15)

(defun distance (a b)
  "Returns the distance between cities A and B."
  (if (eql a b) 0
      (rest (assoc b (get-distances a))) ) )

(defun cycle-cost (path)
  "Returns length of the PATH, including a closing
   arc from the last to the first element of PATH."
   (+ (distance (first path) (first (last path)))
      (path-cost path) ) )

(defun path-cost (path)
  "Returns the length of the PATH."
  (if (<= (length path) 1) 0
      (+ (distance (first path) (second path))
         (path-cost (rest path)) ) ) )

(defun non-tour-penalty (path)
  "Computes how far PATH is from being a tour.
   If PATH is a tour, then the penalty returned is 0."
  (* 100
    (+ (length (set-difference path *cities*))
       (length (set-difference *cities* path)) ) ) )

(defun chromosome-strength (individual)
  "Returns a value that is highest when INDIVIDUAL is a
   mimimum cost tour."
  (/ 10000.0
     (+ (* 2 (cycle-cost (get-path individual)))
        (* 50 (non-tour-penalty (get-path individual))) ) ) )

(defun mutate (individual)
  "Performs either MUTATE1 or MUTATE2, choosing randomly."
  (if (oddp (random 2))
      (mutate1 individual)
      (mutate2 individual) ) )

(defun mutate1 (individual)
  "Returns a slightly altered INDIVIDUAL, with the
   alteration generated randomly. One city is randomly changed."
  (let* ((path (get-path individual))
         (where (random (length path)))
         (new-city (nth (random *ncities*) *cities*)) )
    (cons (replace-nth path where new-city)
          0) ) )


(defun mutate2 (individual)
  "Returns a slightly altered INDIVIDUAL, with the
   alteration generated randomly. Two cities are transposed."
  (let* ((path (get-path individual))
         (where1 (random (length path)))
         (where2 (random (length path)))
         (city1 (nth where1 path))
         (city2 (nth where2 path)) )
    (cons (replace-nth
            (replace-nth path where1 city2)
            where2
            city1)
          0) ) )

(defun replace-nth (lst n elt)
  "Returns result of replacing the N-th element of LST by ELT."
  (cond ((null lst) nil)
        ((zerop n) (cons elt (rest lst)))
        (t (cons (first lst)
                 (replace-nth (rest lst) (1- n) elt) )) ) )


;;; In CROSSOVER we assume that PATH1 and PATH2 are of the
;;; same length.
(defun crossover (individual1 individual2)
  "Returns a new path resulting from
   genetic crossover of PATH1 and PATH2."
  (let* ((path1 (get-path individual1))
         (path2 (get-path individual2))
         (where (random (length path1))) )
    (cons (append (left-part path1 where)
                  (right-part path2 where) )
          0) ) )

(defun left-part (path k)
  "Returns the prefix of PATH having length K."
  (subseq path 0 k) )

(defun right-part (path k)
  "Returns the suffix of PATH starting at position K."
  (subseq path k) )

(defun random-individual ()
  "Returns a randomly selected member of the population."
  (nth (random (length *population*)) *population*) )

(defun another-individual (previous-rand-indiv)
  "Returns a randomly selected member of the population
   but makes an effort to find one that is different
   from PREVIOUS-RAND-INDIV."
  (let ((current-population-size (length *population*))
        (previous-path (get-path previous-rand-indiv))
        candidate)
    (dotimes (i 5 candidate) ; try at most 5 times.
      (setf candidate
            (nth (random current-population-size)
                 *population*) )
      (if (not (equal (get-path candidate) previous-path))
          (return candidate) ) ) ) )

(defun evolve (ngenerations nmutations ncrossovers)
  "Runs the genetic algorithm for NGENERATIONS times."
  (setf *population* *initial-population*)
  (dotimes (i ngenerations)
    (dotimes (j nmutations)
      (let ((mutated-one (mutate (random-individual))))
        (add-individual mutated-one) ) )
    (dotimes (j ncrossovers)
      (let* ((individual1 (random-individual))
             (individual2
               (another-individual individual1) )
             (crossing-result
              (crossover individual1
                         individual2) ) )
        (add-individual crossing-result) ) )
    (format t "~%In generation ~D, population is: ~S.~%"
            (1+ i) *population*)
   ) )


(defun add-individual (individual)
  "Computes and stores the chromosome-strength of INDIVIDUAL.
Then adds the INDIVIDUAL to the population if the population
limit has not yet been reached. Otherwise, if its strength
exceeds that of the weakest member it replaces the weakest member."
  (let ((strength (chromosome-strength individual)))
    ; Here SETF works like RPLACD
    (setf (rest individual) strength) 
    (if (= *current-pop-size* *population-limit*)
      (progn
        (if (> strength *current-min-strength*)
          ;;; Remove weakest current member:
          (progn
            (let ((k (where-strength-occurs
                       *current-min-strength*
                       *population*)))
              (setf *population* (remove-kth k *population*)) )
            ;;; Insert INDIVIDUAL into the population:
            (push individual *population*)
            (update-min-strength) ) ) )

      ;;; Still room in population...
      (progn
        (push individual *population*)
        (setf *current-min-strength*
              (min strength *current-min-strength*) )
        (incf *current-pop-size*) ) ) ) )


(defun update-min-strength ()
  "Computes and saves the minimum of all strengths of
   current members of the population."
  (setf *current-min-strength*
    (apply #'min (mapcar #'get-strength *population*)) ) )

(defun where-strength-occurs (val population-list)
  "Returns the first position in POPULATION-LIST where VAL occurs
   as the strength of that individual."
  (cond ((null population-list) nil)
        ((= val (get-strength (first population-list))) 0)
        (t (1+ (where-strength-occurs
                val (rest population-list)))) ) )

(defun remove-kth (k lst)
  "Returns a list consisting of LST with the Kth element deleted."
  (cond ((null lst) nil)
        ((zerop k) (rest lst))
        (t (cons (first lst)
                 (remove-kth (1- k) (rest lst)) )) ) )

(defun test ()
  "Does a trial run of EVOLVE."
  (setf *population* *initial-population*)
  (setf *current-min-strength* 0)
  (setf *current-pop-size* 1)
  ; these values often lead to convergence at strength 4.78.
  (evolve 10 10 10) 
 )

? (test)


In generation 1, population is:
(((SEATTLE SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.6510416666666666)
 ((PORTLAND SEATTLE SEATTLE SEATTLE SEATTLE) . 0.6410256410256411)
 ((SEATTLE SEATTLE SEATTLE SEATTLE BELLINGHAM) . 0.6510416666666666)
 ((PORTLAND SEATTLE SEATTLE SEATTLE SEATTLE) . 0.6410256410256411)
 ((SEATTLE SEATTLE SEATTLE SEATTLE BELLINGHAM) . 0.6510416666666666)
 ((SEATTLE SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.6510416666666666)
 ((SEATTLE SEATTLE WENATCHEE SEATTLE SEATTLE) . 0.6493506493506493)
 ((PORTLAND SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.9124087591240876)
 ((SEATTLE SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.6510416666666666)
 ((PORTLAND SEATTLE SEATTLE SEATTLE BELLINGHAM) . 0.91324200913242)
 ((SEATTLE SEATTLE SEATTLE SEATTLE SEATTLE) . 0.5) 
 ((SEATTLE SEATTLE SEATTLE SEATTLE SEATTLE) . 0.5)
 ((SEATTLE PORTLAND SEATTLE SEATTLE SEATTLE) . 0.6410256410256411)
 ((PORTLAND SEATTLE SEATTLE SEATTLE SEATTLE) . 0.6410256410256411)
 ((SEATTLE SEATTLE SEATTLE SEATTLE SEATTLE) . 0.5)).

In generation 2, population is: 
(((PORTLAND SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.9124087591240876)
 ((PORTLAND SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.9124087591240876)
 ((SPOKANE SEATTLE SEATTLE BELLINGHAM BELLINGHAM) . 0.8583690987124464)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM SEATTLE) . 1.3966480446927374)
 ((PORTLAND SEATTLE SEATTLE BELLINGHAM BELLINGHAM) . 0.91324200913242)
 ((SPOKANE SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.8503401360544217)
 ((PORTLAND SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.9124087591240876)
 ((SPOKANE SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.8503401360544217)
 ((SPOKANE SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.8503401360544217)
 ((WENATCHEE SEATTLE SEATTLE SEATTLE BELLINGHAM) . 0.9398496240601504)
 ((SPOKANE SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.8503401360544217)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM SEATTLE) . 1.3966480446927374)
 ((PORTLAND SEATTLE SEATTLE SEATTLE BELLINGHAM) . 0.91324200913242)
 ((PORTLAND SEATTLE SEATTLE BELLINGHAM SEATTLE) . 0.9124087591240876)
 ((PORTLAND SEATTLE SEATTLE SEATTLE BELLINGHAM) . 0.91324200913242)).

In generation 3, population is: 
(((PORTLAND SPOKANE SEATTLE SEATTLE BELLINGHAM) . 1.3986013986013985)
 ((PORTLAND SPOKANE SEATTLE SEATTLE BELLINGHAM) . 1.3986013986013985)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM SEATTLE) . 1.3966480446927374)
 ((WENATCHEE SEATTLE BELLINGHAM BELLINGHAM SEATTLE) . 0.929368029739777)
 ((WENATCHEE SEATTLE BELLINGHAM SEATTLE SEATTLE) . 0.929368029739777)
 ((WENATCHEE SEATTLE SEATTLE SEATTLE BELLINGHAM) . 0.9398496240601504)
 ((BELLINGHAM SEATTLE PORTLAND PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((WENATCHEE SEATTLE BELLINGHAM SEATTLE SEATTLE) . 0.929368029739777)
 ((PORTLAND SPOKANE BELLINGHAM BELLINGHAM SEATTLE) . 1.4184397163120568)
 ((WENATCHEE SEATTLE BELLINGHAM SEATTLE SEATTLE) . 0.929368029739777)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM SEATTLE) . 1.3966480446927374)
 ((WENATCHEE SEATTLE SEATTLE SEATTLE BELLINGHAM) . 0.9398496240601504)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM SEATTLE) . 1.3966480446927374)
 ((PORTLAND SEATTLE SEATTLE SEATTLE BELLINGHAM) . 0.91324200913242)).


In generation 4, population is: 
(((PORTLAND SPOKANE SEATTLE BELLINGHAM BELLINGHAM) . 1.3986013986013985)
 ((PORTLAND SPOKANE BELLINGHAM BELLINGHAM SEATTLE) . 1.4184397163120568)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM SEATTLE) . 1.3966480446927374)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((WENATCHEE SEATTLE BELLINGHAM SEATTLE PORTLAND) . 1.597444089456869)
 ((PORTLAND SPOKANE BELLINGHAM BELLINGHAM SEATTLE) . 1.4184397163120568)
 ((SPOKANE PORTLAND SEATTLE SEATTLE BELLINGHAM) . 1.4184397163120568)
 ((PORTLAND SPOKANE SEATTLE SEATTLE BELLINGHAM) . 1.3986013986013985)
 ((PORTLAND SPOKANE SEATTLE SEATTLE BELLINGHAM) . 1.3986013986013985)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM SEATTLE) . 1.3966480446927374)
 ((BELLINGHAM SEATTLE PORTLAND PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((PORTLAND SPOKANE BELLINGHAM BELLINGHAM SEATTLE) . 1.4184397163120568)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM SEATTLE) . 1.3966480446927374)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM SEATTLE) . 1.3966480446927374)).

In generation 5, population is: 
(((WENATCHEE SEATTLE BELLINGHAM SEATTLE PORTLAND) . 1.597444089456869)
 ((BELLINGHAM SEATTLE PORTLAND WENATCHEE SEATTLE) . 1.597444089456869)
 ((BELLINGHAM SEATTLE PORTLAND WENATCHEE PORTLAND) . 1.4814814814814814)
 ((SEATTLE PORTLAND BELLINGHAM WENATCHEE PORTLAND) . 1.485884101040119)
 ((BELLINGHAM PORTLAND SEATTLE SEATTLE WENATCHEE) . 1.6051364365971108)
 ((PORTLAND SPOKANE BELLINGHAM BELLINGHAM SEATTLE) . 1.4184397163120568)
 ((WENATCHEE PORTLAND BELLINGHAM SEATTLE PORTLAND) . 1.4814814814814814)
 ((PORTLAND SPOKANE BELLINGHAM BELLINGHAM SEATTLE) . 1.4184397163120568)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((WENATCHEE SEATTLE BELLINGHAM SEATTLE PORTLAND) . 1.597444089456869)
 ((PORTLAND SPOKANE BELLINGHAM BELLINGHAM SEATTLE) . 1.4184397163120568)
 ((SPOKANE PORTLAND SEATTLE SEATTLE BELLINGHAM) . 1.4184397163120568)
 ((BELLINGHAM SEATTLE PORTLAND PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((PORTLAND SPOKANE BELLINGHAM BELLINGHAM SEATTLE) . 1.4184397163120568)).

In generation 6, population is: 
(((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE PORTLAND PORTLAND WENATCHEE) . 1.6286644951140066)
 ((SEATTLE PORTLAND BELLINGHAM WENATCHEE WENATCHEE) . 1.6051364365971108)
 ((PORTLAND SEATTLE SEATTLE BELLINGHAM WENATCHEE) . 1.6286644951140066)
 ((WENATCHEE WENATCHEE BELLINGHAM SEATTLE PORTLAND) . 1.6286644951140066)
 ((SEATTLE PORTLAND BELLINGHAM WENATCHEE SEATTLE) . 1.6051364365971108)
 ((PORTLAND SPOKANE BELLINGHAM WENATCHEE SEATTLE) . 4.291845493562231)
 ((WENATCHEE SEATTLE BELLINGHAM SEATTLE PORTLAND) . 1.597444089456869)
 ((BELLINGHAM SEATTLE PORTLAND WENATCHEE SEATTLE) . 1.597444089456869)
 ((SEATTLE PORTLAND BELLINGHAM WENATCHEE PORTLAND) . 1.485884101040119)
 ((BELLINGHAM PORTLAND SEATTLE SEATTLE WENATCHEE) . 1.6051364365971108)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((WENATCHEE SEATTLE BELLINGHAM SEATTLE PORTLAND) . 1.597444089456869)
 ((BELLINGHAM SEATTLE PORTLAND PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)).


In generation 7, population is: 
(((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((PORTLAND SEATTLE SEATTLE BELLINGHAM WENATCHEE) . 1.6286644951140066)
 ((SEATTLE PORTLAND WENATCHEE BELLINGHAM SPOKANE) . 4.11522633744856)
 ((PORTLAND SEATTLE SPOKANE BELLINGHAM WENATCHEE) . 4.11522633744856)
 ((SEATTLE PORTLAND WENATCHEE BELLINGHAM SEATTLE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE PORTLAND PORTLAND WENATCHEE) . 1.6286644951140066)
 ((PORTLAND SEATTLE SEATTLE BELLINGHAM WENATCHEE) . 1.6286644951140066)
 ((WENATCHEE WENATCHEE BELLINGHAM SEATTLE PORTLAND) . 1.6286644951140066)
 ((PORTLAND SPOKANE BELLINGHAM WENATCHEE SEATTLE) . 4.291845493562231)
 ((BELLINGHAM PORTLAND SEATTLE SEATTLE WENATCHEE) . 1.6051364365971108)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE PORTLAND PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)).

In generation 8, population is: 
(((PORTLAND SPOKANE SEATTLE BELLINGHAM WENATCHEE) . 4.273504273504273)
 ((PORTLAND SPOKANE BELLINGHAM WENATCHEE SEATTLE) . 4.291845493562231)
 ((SPOKANE SEATTLE PORTLAND BELLINGHAM WENATCHEE) . 4.385964912280702)
 ((PORTLAND SEATTLE SEATTLE BELLINGHAM WENATCHEE) . 1.6286644951140066)
 ((SEATTLE PORTLAND WENATCHEE BELLINGHAM SPOKANE) . 4.11522633744856)
 ((PORTLAND SEATTLE SPOKANE BELLINGHAM WENATCHEE) . 4.11522633744856)
 ((SEATTLE PORTLAND WENATCHEE BELLINGHAM SEATTLE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE PORTLAND PORTLAND WENATCHEE) . 1.6286644951140066)
 ((PORTLAND SEATTLE SEATTLE BELLINGHAM WENATCHEE) . 1.6286644951140066)
 ((WENATCHEE WENATCHEE BELLINGHAM SEATTLE PORTLAND) . 1.6286644951140066)
 ((PORTLAND SPOKANE BELLINGHAM WENATCHEE SEATTLE) . 4.291845493562231)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE PORTLAND PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)).

In generation 9, population is: 
(((PORTLAND SPOKANE BELLINGHAM WENATCHEE SEATTLE) . 4.291845493562231)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM WENATCHEE) . 4.273504273504273)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM WENATCHEE) . 4.273504273504273)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM WENATCHEE) . 4.273504273504273)
 ((PORTLAND SEATTLE SPOKANE BELLINGHAM WENATCHEE) . 4.11522633744856)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM WENATCHEE) . 4.273504273504273)
 ((PORTLAND SPOKANE BELLINGHAM WENATCHEE SEATTLE) . 4.291845493562231)
 ((SPOKANE SEATTLE PORTLAND BELLINGHAM WENATCHEE) . 4.385964912280702)
 ((SEATTLE PORTLAND WENATCHEE BELLINGHAM SPOKANE) . 4.11522633744856)
 ((PORTLAND SEATTLE SPOKANE BELLINGHAM WENATCHEE) . 4.11522633744856)
 ((WENATCHEE WENATCHEE BELLINGHAM SEATTLE PORTLAND) . 1.6286644951140066)
 ((PORTLAND SPOKANE BELLINGHAM WENATCHEE SEATTLE) . 4.291845493562231)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE PORTLAND PORTLAND WENATCHEE) . 1.6286644951140066)
 ((BELLINGHAM SEATTLE SEATTLE PORTLAND WENATCHEE) . 1.6286644951140066)).


In generation 10, population is: 
(((PORTLAND WENATCHEE SPOKANE BELLINGHAM SEATTLE) . 4.545454545454546)
 ((PORTLAND SPOKANE WENATCHEE BELLINGHAM SEATTLE) . 4.784688995215311)
 ((PORTLAND WENATCHEE SPOKANE BELLINGHAM SEATTLE) . 4.545454545454546)
 ((PORTLAND SEATTLE BELLINGHAM WENATCHEE SPOKANE) . 4.784688995215311)
 ((SEATTLE PORTLAND BELLINGHAM WENATCHEE SPOKANE) . 4.385964912280702)
 ((BELLINGHAM SEATTLE SPOKANE WENATCHEE PORTLAND) . 4.3478260869565215)
 ((PORTLAND WENATCHEE SPOKANE BELLINGHAM SEATTLE) . 4.545454545454546)
 ((PORTLAND SPOKANE WENATCHEE BELLINGHAM SEATTLE) . 4.784688995215311)
 ((PORTLAND SPOKANE BELLINGHAM WENATCHEE SEATTLE) . 4.291845493562231)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM WENATCHEE) . 4.273504273504273)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM WENATCHEE) . 4.273504273504273)
 ((PORTLAND SPOKANE SEATTLE BELLINGHAM WENATCHEE) . 4.273504273504273)
 ((PORTLAND SPOKANE BELLINGHAM WENATCHEE SEATTLE) . 4.291845493562231)
 ((SPOKANE SEATTLE PORTLAND BELLINGHAM WENATCHEE) . 4.385964912280702)
 ((PORTLAND SPOKANE BELLINGHAM WENATCHEE SEATTLE) . 4.291845493562231)).
NIL
? 

;; Lee Spector, November 1994

#|
Code for a genetic algorithm solution to the
traveling salesman problem, inspired by the
treatment in Dewdney's THE NEW TURING OMNIBUS,
Computer Science Press, W.H. Freeman and Company,
1993, p. 106.

NOTE: The purpose of this code is to demonstrate
genetic algorithms, NOT to make the genetic
solution to the traveling salesman problem as
efficient as possible. Several features of this
code -- e.g. the mapping to city names -- are
real time-wasters if you're looking for
short run-times.

Tours are represented as lists of "removal" 
numbers. For example, if the list of cities
is (a b c d e f) then (2 3 1 3 1 1) represents
the tour (b d a f c e):

                                    TOUR
start w/std sequence: a b c d e f
remove item 2:        a c d e f     b
remove item 3:        a c e f       b d
remove item 1:        c e f         b d a
remove item 3:        c e           b d a f
remove item 1:        e             b d a f c
remove item 1:                      b d a f c e
|#



(defun random-tour (n)
  "Returns a random valid tour of n cities. A tour
is valid as long as the i-th digit never exceeds
n+1-i."
  (let ((tour nil))
    (dotimes (i n)
      (push (1+ (random (- n i))) ; OUR i is 0-based
            tour))
    (reverse tour)))

;; (random-tour 6)
--> (3 2 3 3 2 1)

(defun tour->cities (removal-list city-list)
  "Returns a tour, expressed as a list of city names,
given a removal-list representation and a list of
all city names."
  (let ((sym-tour nil) city)
    (dolist (n removal-list)
      (setq city (nth (1- n) city-list))
      (push city sym-tour)
      (setq city-list (remove city city-list)))
    (reverse sym-tour)))

;; (tour->cities '(2 3 1 3 1 1) '(a b c d e f))
--> (B D A F C E)



;; We'll represent a traveling salesman problem
;; as a object containing a list of city names
;; and an array of city-to-city distances.

(defclass salesman-problem ()
  ((names :accessor names :initarg :names)
   (distances :accessor distances)))

(defmethod initialize-instance :after
           ((s salesman-problem) &rest init-args)
  "Initializes an instance of a salesman-problem;
creates a distances array for the problem with all
distances set to 1."
  (declare (ignore init-args))
  (let ((num-cities (length (names s))))
    (setf (distances s)
          (make-array (list num-cities num-cities)
                      :initial-element 1))))

(defmethod distance ((s salesman-problem)
                     city-1 city-2)
  "Returns the distance between city-1 and city-2
according to s."
  (let ((index-1 (position city-1 (names s)))
        (index-2 (position city-2 (names s))))
    (aref (distances s) index-1 index-2)))

(defmethod set-distance ((s salesman-problem)
                         city-1 city-2 distance)
  "Sets the distance between city-1 and city-2 in s
to be distance."
  (let ((index-1 (position city-1 (names s)))
        (index-2 (position city-2 (names s))))
    (setf (aref (distances s) index-1 index-2)
          distance)))


(defvar *sp* nil "a salesman problem")

(setq *sp*
      (make-instance 'salesman-problem
        :names '(new-york boston san-francisco
                 chicago dallas phoenix
                 miami seattle)))

;; (distance *sp* 'new-york 'boston)
--> 1

;; Here are some APPROXIMATELY correct distances.
;; Note that we *could* make this asymmetric, but we haven't.

(set-distance *sp* 'new-york 'new-york 0)
(set-distance *sp* 'new-york 'boston 189)
(set-distance *sp* 'new-york 'san-francisco 2505)
(set-distance *sp* 'new-york 'chicago 709)
(set-distance *sp* 'new-york 'dallas 1370)
(set-distance *sp* 'new-york 'phoenix 2079)
(set-distance *sp* 'new-york 'miami 1087)
(set-distance *sp* 'new-york 'seattle 2363)

(set-distance *sp* 'boston 'new-york 189)
(set-distance *sp* 'boston 'boston 0)
(set-distance *sp* 'boston 'san-francisco 2646)
(set-distance *sp* 'boston 'chicago 851)
(set-distance *sp* 'boston 'dallas 1512)
(set-distance *sp* 'boston 'phoenix 2268)
(set-distance *sp* 'boston 'miami 1247)
(set-distance *sp* 'boston 'seattle 2457)

(set-distance *sp* 'san-francisco 'new-york 2505)
(set-distance *sp* 'san-francisco 'boston 2646)
(set-distance *sp* 'san-francisco 'san-francisco 0)
(set-distance *sp* 'san-francisco 'chicago 1843)
(set-distance *sp* 'san-francisco 'dallas 1465)
(set-distance *sp* 'san-francisco 'phoenix 662)
(set-distance *sp* 'san-francisco 'miami 2552)
(set-distance *sp* 'san-francisco 'seattle 680)

(set-distance *sp* 'chicago 'new-york 709)
(set-distance *sp* 'chicago 'boston 851)
(set-distance *sp* 'chicago 'san-francisco 1843)
(set-distance *sp* 'chicago 'chicago 0)
(set-distance *sp* 'chicago 'dallas 756)
(set-distance *sp* 'chicago 'phoenix 1418)
(set-distance *sp* 'chicago 'miami 1181)
(set-distance *sp* 'chicago 'seattle 1701)

(set-distance *sp* 'dallas 'new-york 1370)
(set-distance *sp* 'dallas 'boston 1512)
(set-distance *sp* 'dallas 'san-francisco 1465)
(set-distance *sp* 'dallas 'chicago 756)
(set-distance *sp* 'dallas 'dallas 0)
(set-distance *sp* 'dallas 'phoenix 869)
(set-distance *sp* 'dallas 'miami 1096)
(set-distance *sp* 'dallas 'seattle 1654)

(set-distance *sp* 'phoenix 'new-york 2079)
(set-distance *sp* 'phoenix 'boston 2268)
(set-distance *sp* 'phoenix 'san-francisco 662)
(set-distance *sp* 'phoenix 'chicago 1418)
(set-distance *sp* 'phoenix 'dallas 869)
(set-distance *sp* 'phoenix 'phoenix 0)
(set-distance *sp* 'phoenix 'miami 1947)
(set-distance *sp* 'phoenix 'seattle 1096)

(set-distance *sp* 'miami 'new-york 1087)
(set-distance *sp* 'miami 'boston 1247)
(set-distance *sp* 'miami 'san-francisco 2552)
(set-distance *sp* 'miami 'chicago 1181)
(set-distance *sp* 'miami 'dallas 1096)
(set-distance *sp* 'miami 'phoenix 1947)
(set-distance *sp* 'miami 'miami 0)
(set-distance *sp* 'miami 'seattle 2646)

(set-distance *sp* 'seattle 'new-york 2363)
(set-distance *sp* 'seattle 'boston 2457)
(set-distance *sp* 'seattle 'san-francisco 680)
(set-distance *sp* 'seattle 'chicago 1701)
(set-distance *sp* 'seattle 'dallas 1654)
(set-distance *sp* 'seattle 'phoenix 1096)
(set-distance *sp* 'seattle 'miami 2646)
(set-distance *sp* 'seattle 'seattle 0)



(defun tour-length (tour sp &optional (debug nil))
  "Returns the total length of tour, which should
be a removal-list, with respect to sp, which should
be a salesman-problem"
  (let ((cities (tour->cities tour (names sp)))
        (total 0))
    (dotimes (n (1- (length cities)))
      (incf total (distance sp
                            (nth n cities)
                            (nth (1+ n) cities))))
    (if debug
      (format t "~%length of tour: ~A is ~A.~%"
              cities total))
    total))

;; (tour-length (random-tour 8) *sp*)
--> 9195
;; (tour-length (random-tour 8) *sp* t)
--> 8383

(defun ga-salesman (sp pop-size gens)
  "Tries to solve the given salesman problem
by running a genetic algorithm with population
size pop-size for gens generations. Returns three
values: the symbolic form of the best tour found,
the total distance of that tour, and the final
population."
  (let ((pop nil)
        (best-fitness 100000) (best-tour nil))
    ;; make the initial population
    (dotimes (n pop-size)
      (push (random-tour (length (names sp))) pop))
    ;; for each generation
    (dotimes (g gens)
      (format t "~%Generation #~A.~%" g)
      (setq pop (sort-by-fitness pop sp))
      (report-on-pop pop sp)
      (when (< (tour-length (first pop) sp)
               best-fitness) ;; save best so far
        (setq best-tour (first pop)
              best-fitness (tour-length best-tour sp)))
      (setq pop (next-generation pop)))
    ;; return the best
    (values (tour->cities best-tour (names sp))
            best-fitness
            (mapcar #'(lambda (tr)
                        (tour->cities tr (names sp)))
                    pop))))

(defun sort-by-fitness (pop sp)
  "Returns a copy of pop, which should be a list
of removal-list tour representations, sorted so that
the shortest tour -- relative to problem sp -- is
first, etc."
  (sort (copy-list pop)
        #'(lambda (t1 t2)
            (< (tour-length t1 sp)
               (tour-length t2 sp)))))

(defun report-on-pop (pop sp)
  "Reports on the best tour on pop, which should be
sorted by fitness, and on the average fitness."
  (format t "Best of generation tour: ~A~%"
          (tour->cities (first pop) (names sp)))
  (format t "Total length of this tour: ~A~%"
          (tour-length (first pop) sp))
  (format t "Average length of tours in population: ~A~%"
          (average (mapcar #'(lambda (tr)
                               (tour-length tr sp))
                           pop)))
  (format t "-----------------------------------"))

(defun average (numbers)
  "Returns the average of the given list of numbers."
  (float (/ (apply #'+ numbers) (length numbers))))

(defun next-generation (pop)
  "Applies genetic operations to produce a new
population from pop, which should be sorted by
fitness. Uses only reproduction -- from the 50%
best -- and crossover -- from the 50% best. Note
that many variations in detail are possible."
  (let ((new-pop nil)
        (half (floor (length pop) 2)))
    ;; reproduction from the top 50% (only a few)
    (do () ((> (length new-pop) (/ half 4)))
      (push (nth (random half) pop) new-pop))
    ;; crossover from the top 50%
    (do () ((>= (length new-pop) (length pop)))
      (push (crossover (nth (random half) pop)
                       (nth (random half) pop))
            new-pop))
    new-pop))


(defun crossover (list1 list2)
  "Returns a random child of the two given lists, the
initial segment will come from list1 and the final
segment will come from list2."
  (let ((cross-pt (random (1+ (length list1)))))
    (append (butlast list1
                     (- (length list1) cross-pt))
            (nthcdr cross-pt list2))))

;; (crossover '(1 2 3 4 5 6) '(a b c d e f))
--> (1 B C D E F)
;; (crossover '(1 2 3 4 5 6) '(a b c d e f))
--> (1 2 3 D E F)



;; (ga-salesman *sp* 10 2)
? 
Generation #0.
Best of generation tour:
(NEW-YORK MIAMI PHOENIX BOSTON CHICAGO DALLAS
          SAN-FRANCISCO SEATTLE)
Total length of this tour: 9054
Average length of tours in population: 10486.1
-----------------------------------
Generation #1.
Best of generation tour:
(NEW-YORK MIAMI PHOENIX BOSTON CHICAGO DALLAS
          SAN-FRANCISCO SEATTLE)
Total length of this tour: 9054
Average length of tours in population: 9689.2
-----------------------------------
--> (NEW-YORK MIAMI PHOENIX BOSTON CHICAGO
              DALLAS SAN-FRANCISCO SEATTLE)


;; (ga-salesman *sp* 20 2)
Generation #0.
Best of generation tour: 
(DALLAS MIAMI CHICAGO NEW-YORK BOSTON SAN-FRANCISCO
        PHOENIX SEATTLE)
Total length of this tour: 7579
Average length of tours in population: 10839.5
-----------------------------------
Generation #1.
Best of generation tour: 
(DALLAS MIAMI CHICAGO NEW-YORK BOSTON PHOENIX SEATTLE
        SAN-FRANCISCO)
Total length of this tour: 7219
Average length of tours in population: 10080.45
-----------------------------------
--> (DALLAS MIAMI CHICAGO NEW-YORK BOSTON 
            PHOENIX SEATTLE SAN-FRANCISCO)


;; (ga-salesman *sp* 20 10)
Generation #0.
Best of generation tour: 
(NEW-YORK BOSTON DALLAS MIAMI CHICAGO SAN-FRANCISCO
          PHOENIX SEATTLE)
Total length of this tour: 7579
Average length of tours in population: 10466.95
-----------------------------------
Generation #1.
Best of generation tour: 
(SAN-FRANCISCO SEATTLE NEW-YORK BOSTON CHICAGO MIAMI
               DALLAS PHOENIX)
Total length of this tour: 7229
Average length of tours in population: 9604.65
-----------------------------------
Generation #2.
Best of generation tour: 
(SAN-FRANCISCO SEATTLE NEW-YORK BOSTON CHICAGO MIAMI
               DALLAS PHOENIX)
Total length of this tour: 7229
Average length of tours in population: 9305.4
-----------------------------------
Generation #3.
Best of generation tour: 
(SAN-FRANCISCO SEATTLE NEW-YORK BOSTON CHICAGO MIAMI
               DALLAS PHOENIX)
Total length of this tour: 7229
Average length of tours in population: 8526.8
-----------------------------------
Generation #4.
Best of generation tour: 
(SAN-FRANCISCO SEATTLE NEW-YORK BOSTON CHICAGO MIAMI
               DALLAS PHOENIX)
Total length of this tour: 7229
Average length of tours in population: 8495.2
-----------------------------------
Generation #5.
Best of generation tour:
(SAN-FRANCISCO SEATTLE NEW-YORK BOSTON CHICAGO MIAMI
               DALLAS PHOENIX)
Total length of this tour: 7229
Average length of tours in population: 8106.0
-----------------------------------
Generation #6.
Best of generation tour: 
(SAN-FRANCISCO SEATTLE NEW-YORK BOSTON CHICAGO MIAMI
               DALLAS PHOENIX)
Total length of this tour: 7229
Average length of tours in population: 7680.3
-----------------------------------
Generation #7.
Best of generation tour: 
(SAN-FRANCISCO SEATTLE NEW-YORK BOSTON CHICAGO MIAMI
               DALLAS PHOENIX)
Total length of this tour: 7229
Average length of tours in population: 7293.2
-----------------------------------
Generation #8.
Best of generation tour: 
(SAN-FRANCISCO SEATTLE NEW-YORK BOSTON CHICAGO MIAMI
               DALLAS PHOENIX)
Total length of this tour: 7229
Average length of tours in population: 7229.0
-----------------------------------
Generation #9.
Best of generation tour: 
(SAN-FRANCISCO SEATTLE NEW-YORK BOSTON CHICAGO MIAMI
               DALLAS PHOENIX)
Total length of this tour: 7229
Average length of tours in population: 7229.0
-----------------------------------
--> (SAN-FRANCISCO SEATTLE NEW-YORK BOSTON CHICAGO 
                   MIAMI DALLAS PHOENIX)




;; (ga-salesman *sp* 20 20)
Generation #0.
Best of generation tour: 
(PHOENIX DALLAS SAN-FRANCISCO SEATTLE MIAMI CHICAGO
         NEW-YORK BOSTON)
Total length of this tour: 7739
Average length of tours in population: 10372.25
-----------------------------------
Generation #1.
Best of generation tour: 
(SEATTLE PHOENIX SAN-FRANCISCO CHICAGO NEW-YORK BOSTON
         DALLAS MIAMI)
Total length of this tour: 7107
Average length of tours in population: 9262.15
-----------------------------------
Generation #2.
Best of generation tour: 
(SEATTLE PHOENIX SAN-FRANCISCO CHICAGO NEW-YORK BOSTON
         DALLAS MIAMI)
Total length of this tour: 7107
Average length of tours in population: 8446.55
-----------------------------------
Generation #3.
Best of generation tour: 
(SEATTLE PHOENIX SAN-FRANCISCO CHICAGO NEW-YORK BOSTON
         DALLAS MIAMI)
Total length of this tour: 7107
Average length of tours in population: 8280.5
-----------------------------------
Generation #4.
Best of generation tour: 
(SEATTLE PHOENIX SAN-FRANCISCO CHICAGO NEW-YORK BOSTON
         DALLAS MIAMI)
Total length of this tour: 7107
Average length of tours in population: 8005.4
-----------------------------------
Generation #5.
Best of generation tour: 
(SEATTLE PHOENIX SAN-FRANCISCO CHICAGO NEW-YORK BOSTON
         DALLAS MIAMI)
Total length of this tour: 7107
Average length of tours in population: 8455.25
-----------------------------------
Generation #6.
Best of generation tour: 
(SEATTLE PHOENIX SAN-FRANCISCO CHICAGO NEW-YORK BOSTON
         DALLAS MIAMI)
Total length of this tour: 7107
Average length of tours in population: 8319.35
-----------------------------------
Generation #7.
Best of generation tour: 
(SEATTLE PHOENIX SAN-FRANCISCO CHICAGO NEW-YORK BOSTON
         DALLAS MIAMI)
Total length of this tour: 7107
Average length of tours in population: 8374.3
-----------------------------------
Generation #8.
Best of generation tour:
(SEATTLE PHOENIX SAN-FRANCISCO CHICAGO NEW-YORK BOSTON
         DALLAS MIAMI)
Total length of this tour: 7107
Average length of tours in population: 7541.45
-----------------------------------
Generation #9.
Best of generation tour: 
(SEATTLE PHOENIX SAN-FRANCISCO CHICAGO NEW-YORK BOSTON
         DALLAS MIAMI)
Total length of this tour: 7107
Average length of tours in population: 7107.0
-----------------------------------

[stuff deleted]

--> (SEATTLE PHOENIX SAN-FRANCISCO CHICAGO 
             NEW-YORK BOSTON DALLAS MIAMI)


PROBLEMS
- hard to predict convergence
- loss of diversity
- representation problem

VARIATIONS
- additional genetic operations (e.g. mutation)
- representation via code (genetic programming)

;; a bigger traveling salesman problem instance

(setq *sp*
      (make-instance 'salesman-problem
        :names '(a b c d e f g h i j k l m n o p
                 q r s t u v w x y z)))

(dotimes (c1 26)
  (dotimes (c2 26)
    (set-distance *sp*
                  (nth c1 (names *sp*))
                  (nth c2 (names *sp*))
                  (random 100))))

(distance *sp* 'a 'z)
--> 92

;; (ga-salesman *sp* 20 20)
Generation #0.
Best of generation tour: 
(P S B K T W M J I F G Q O Y N X U E D H V L A C R Z)
Total length of this tour: 1028
Average length of tours in population: 1247.9
-----------------------------------
Generation #1.
Best of generation tour: 
(A J D B K L G R P Y N W H U Z S I X T M E V Q C F O)
Total length of this tour: 943
Average length of tours in population: 1208.25
-----------------------------------
Generation #2.
Best of generation tour: 
(R M W J C F U Z B X K T G Q Y O H V P I D S N A E L)
Total length of this tour: 916
Average length of tours in population: 1124.85
-----------------------------------
Generation #3.
Best of generation tour: 
(R M W J C F U Z B X K T G Q Y O H V P I D S N A E L)
Total length of this tour: 916
Average length of tours in population: 1081.5
-----------------------------------
Generation #4.
Best of generation tour: 
(R M W J C F U Z B X K T G Q Y O H V P I D S N A L E)
Total length of this tour: 902
Average length of tours in population: 1043.95
-----------------------------------
Generation #5.
Best of generation tour: 
(R N G U P E V Z B Y T H K F M Q D J S L I A X C O W)
Total length of this tour: 876
Average length of tours in population: 997.6
-----------------------------------
Generation #6.
Best of generation tour: 
(R N G U P E V Z B Y T H K F M Q D J S L I A X C O W)
Total length of this tour: 876
Average length of tours in population: 993.65
-----------------------------------
Generation #7.
Best of generation tour: 
(R N G U P E V Z B Y T H K F M Q D J S L I A X C W O)
Total length of this tour: 861
Average length of tours in population: 949.5
-----------------------------------
Generation #8.
Best of generation tour: 
(R N G U P E V Z B Y T H K F M Q D J S L I A X C W O)
Total length of this tour: 861
Average length of tours in population: 961.0
-----------------------------------
Generation #9.
Best of generation tour: 
(R N G U P E V Z B Y T H K F M Q D J S L I A X C W O)
Total length of this tour: 861
Average length of tours in population: 915.85
-----------------------------------
Generation #10.
Best of generation tour: 
(R N G U P E V Z B Y T H K F M Q D J S L I A X C W O)
Total length of this tour: 861
Average length of tours in population: 921.8
-----------------------------------
Generation #11.
Best of generation tour:
(R N G U P E V Z B Y T H K F M Q D J S L I A X C W O)
Total length of this tour: 861
Average length of tours in population: 926.8
-----------------------------------
Generation #12.
Best of generation tour: 
(R N G U P E V Z B Y T H K F M Q D J S L I A X C W O)
Total length of this tour: 861
Average length of tours in population: 900.75
-----------------------------------
Generation #13.
Best of generation tour: 
(R N G U P E V Z B Y T H K F M Q D J S L I A X C W O)
Total length of this tour: 861
Average length of tours in population: 861.0
-----------------------------------

[stuff deleted]

--> (R N G U P E V Z B Y T H K F M Q D J S L I A X C W O)