;; Example genetic algorithm
;; by Ken Hartness
;; The following Lisp code can be used to process genomes represented
;; as bit strings.  If you use a different representation, the genetic
;; operators crossover and mutation will have to be modified.
;; Fitness, start-search, and summary must be modified for different
;; problems.  Start-search refers to the specific size of each genome,
;; and summary is a problem-specific representation of the genome for
;; human readability.  The fitness function, obviously, needs to be
;; designed for the specific problem being solved.

;; A driver for the genetic algorithm is provided which repeatedly tries
;; to evolve better solutions until a specified number of trials has
;; occurred or a minimum fitness value is met.  Use a large value for the
;; minimum fitness if you don't know what a reasonable fitness value should
;; be; this allows the algorithm to stop as soon as it finds a "good enough"
;; solution.  The driver also allows you to specify the population size:
;; too small and there's not enough "genetic diversity" to find a good
;; solution; too large and the little X-Lisp interpreter runs out of memory.

;;     (start-search popsize trials min-fitness)
;;     For example, (start-search 10 100 1.0) creates a population of size
;;     10 which runs for 100 generations or until a perfect fitness of 1.0
;;     is discovered (other problems might allow fitness levels to exceed
;;     this measure).

;; Tracing-support allows you to see what the program is doing.  Change
;; visible to nil if you do not wish the program to generate any output,
;; initially.  The program waits for input after every Pause-Boundary lines,
;; at which time typing 'y' will pause frequently, 'n' will generate a
;; stream of output, only pausing after an extended period, and 'q' will
;; disable output for the same period.  Set the Pause-Boundary to some
;; ridiculously large number if you don't want this option.
;; Using global variables can be dangerous since they can be easily changed.
;; If they are corrupted, simply re-load the program.
(setq Line-Num 0)
(setq visible t)
(setq Pause-Boundary 10)
(defun pause ()
    (setq visible t)
    (princ "\nEnter y, n, or q to continue: ")
    (let ((c (read-char)))
        (cond ((eq c #\n) (read-char) (setq Pause-Boundary 1000))
              ((eq c #\y) (read-char) (setq Pause-Boundary 10))
              ((eq c #\q) (read-char) (setq Pause-Boundary 100000)
                                      (setq visible nil))
              )))
(defun Newline ()
    (setq Line-Num (+ 1 Line-Num))
    (cond ((> Line-Num Pause-Boundary) (pause) (setq Line-Num 0)))
    (cond (visible (terpri))))
(defun myprinc (item)
    (cond (visible (princ item))))
(defun mypprint (item)
    (cond (visible (pprint item)))
    (setq Line-Num (+ Line-Num (Length item))))
(defun distribution (population)
  (let* ((genotypes (noduplicates population))
         (sum (apply #'+ (mapcar #'fitness genotypes))))
    (mapcar #'(lambda (x) (cons (/ (fitness x) sum) x))
            genotypes)))

;; Genetic algorithm support functions

(defun reproduce (population)
  (let ((offspring nil) (d (distribution population)))
    (dotimes (i (/ (length population) 2))
      (let* ((x (select d))
             (y (select d))
             (remember-x (summary x))
             (remember-y (summary y)))
        (crossover x y)
        (myprinc "Reproducing ")
        (myprinc remember-x) (myprinc remember-y) (Newline)
        (myprinc "as ")
        (myprinc (summary x)) (myprinc (summary y)) (Newline)
        (setq offspring (nconc (list x y) offspring))))
    offspring))

(defun select (distribution)
  (let ((random (random 1.0)) (prob 0) genotype)
    (some #'(lambda (pair)
              (setq prob (+ prob (first pair)))
              (if (> random prob) nil
                  (setq genotype (rest pair))))
      distribution)
    (mutate genotype)))

(defun mutate (genotype)
  (mapcar #'(lambda (x)
              (if (> (random 1.0) 0.03) x
                  (if (= x 1) 0 1)))
          genotype))

(defun switch (x y pos)
    (cond ((= pos 0)
              (let ((swap (cdr x)))
                  (setf (cdr x) (cdr y))
                  (setf (cdr y) swap)))
          (t (switch (cdr x) (cdr y) (- pos 1)))))

(defun print-break (g pos)
    (cond ((null g)
              t)
          ((= pos 0)
              (myprinc (car g))
              (myprinc " | ")
              (print-break (cdr g) (- pos 1)))
          (t
              (myprinc (car g))
              (if (consp (cdr g))
                  (myprinc " "))
              (print-break (cdr g) (- pos 1)))))

(defun crossover (x y)
  (if (> (random 1.0) 0.6)
      (list x y)
      (let ((pos (random (- (length x) 1))))
          (myprinc "(")
          (print-break x pos) (myprinc ") (")
          (print-break y pos) (myprinc ")") (Newline)
          (switch x y pos)
          (myprinc "becomes") (Newline)
          (myprinc "(") (print-break x pos)
          (myprinc ") (") (print-break y pos) (myprinc ")")
          (Newline))))

(defun genlist (size)
    (cond ((= size 0) nil)
          (t (cons (if (> (random 1.0) 0.5) 1 0)
                   (genlist (- size 1))))))

(defun genpop (size length)
    (cond ((= size 0) nil)
          (t (cons (genlist length)
                   (genpop (- size 1) length)))))

(defun noduplicates (list)
    (cond ((null list) nil)
          ((member (car list) (cdr list)) (noduplicates (cdr list)))
          (t (cons (car list) (noduplicates (cdr list))))))

(defun member (item list)
    (cond ((null list) nil)
          ((equal (car list) item) t)
          (t (member item (cdr list)))))

;; Convert bit field into an integer
(defun coding (bstr start stop)
    (cond ((= start 1) (b2int bstr stop))
          (t (coding (cdr bstr) (- start 1) (- stop 1)))))

(defun b2int (bstr length)
    (cond ((= length 1) (car bstr))
          (t (+ (b2int (cdr bstr) (- length 1))
                (* (car bstr) (power 2 (- length 1)))))))

(defun power (x y) (if (= y 0) 1 (* x (power x (- y 1)))))

(defun try (trials)
    (setq old-pop pop)
    (do* ((p pop (reproduce p))
          (n 1 (+ 1 n))
          (fitness (apply #'max (mapcar #'fitness pop))
                   (apply #'max (mapcar #'fitness p))))
        ((or (= n trials) (> fitness goal))
            (setq pop p)
            (mapcar #'summary pop))
        (mypprint (mapcar #'summary p))))

;; Functions supporting the sensor sensitive to light and temperature.
;; Both light and temperature are measured as percentages of some maximum
;; with values between 0 and 100 representing intensities between the minimum
;; and maximum, respectively.
(defun extract (row col list-of-lists)
    (car (nthcdr col (car (nthcdr row list-of-lists)))))

(defun square (x) (* x x))

;; Starting with a table of values, interpolate guesses at values in
;; between for all 10,000+ combinations of light and temperature.  In
;; the real world, we would simply measure the sensor's performance.
;; This simulates what we might find.
(defun interpolate (light temp)
    (let ((row (truncate (/ light 20)))
          (col (truncate (/ temp 20)))
          (table '((0.2 0.15 0.1 0.2 0.5 0.75)
                   (0.3 0.4 0.5 0.85 0.6 0.75)
                   (0.4 0.7 0.8 0.75 0.6 0.74)
                   (0.5 0.75 0.95 0.8 0.75 0.73)
                   (0.6 0.65 0.75 0.97 0.8 0.75)
                   (0.75 0.6 0.8 0.79 0.75 0.74))))
        (cond ((< row 0) (setq row 0))
              ((> row 4) (setq row 4)))
        (cond ((< col 0) (setq col 0))
              ((> col 4) (setq col 4)))
        (let ((value (extract row col table))
              (ltval (extract (+ row 1) col table))
              (tval  (extract row (+ col 1) table))
              (bval  (extract (+ row 1) (+ col 1) table)))
            (/ (+ (+ value
                     (* (- ltval value)
                        (/ (- light (* 20 row)) 20.0)))
                  (+ value
                     (* (- tval value)
                        (/ (- temp (* 20 col)) 20.0)))
                  (+ value
                     (* (- bval value)
                        (/ (sqrt (+ (square (- light (* 20 row)))
                                    (square (- temp (* 20 col)))))
                           (sqrt 800.0)))))
               3.0))))

;; The fitness function assumes that bit strings consist of 7 bits for
;; the light intensity, and 7 bits for the temperature level.  This
;; actually allows for percentages up to 127, but the interpolate
;; function can handle "off the edge" values, reasonably.
(defun fitness (x)
    (let ((light (coding x 1 7)) (temp (coding x 8 14)))
        (if (or (< light 0) (> light 100) (< temp 0) (> temp 100))
            (/ (interpolate light temp) 2.0)
            (interpolate light temp))))

(defun start-search (popsize trials min-fitness)
    (setq pop (genpop popsize 14))
    (setq goal min-fitness)
    (try trials))

(defun summary (bs)
    (cons (coding bs 1 7) (cons (coding bs 8 14) (fitness bs))))