cl-dudga.lisp

;;; -*- coding:utf-8; mode:lisp -*-

(in-package :cl-user)
(defpackage cl-dudga
  (:use :cl :lparallel))
(in-package :cl-dudga)

;;; Setting for lparallel
(defparameter *kernel* (make-kernel 4))

;;; Structures

(defstruct individual
  (chromosome-size 4 :type integer)
  (chromosome #*0000 :type simple-bit-vector)
  (evaluated-value most-negative-double-float :type double-float))

(defun make-random-individual (chromosome-size direction-of-optimization)
  (check-type chromosome-size integer)
  (let ((bv (make-array chromosome-size :element-type 'bit)))
    ;; initialize bit vector random
    (loop for i from 0 to (1- chromosome-size) do
      (setf (aref bv i) (random 2)))
    (make-individual :chromosome-size chromosome-size
		     :chromosome bv
		     :evaluated-value (ecase direction-of-optimization
					(maximize most-negative-double-float)
					(minimize most-positive-double-float)))))

(defun make-zero-individual (chromosome-size direction-of-optimization)
  (check-type chromosome-size integer)
  (let ((bv (make-array chromosome-size :element-type 'bit :initial-element 0)))
    (make-individual :chromosome-size chromosome-size
		     :chromosome bv
		     :evaluated-value (ecase direction-of-optimization
					(maximize most-negative-double-float)
					(minimize most-positive-double-float)))))

(defstruct island
  (generation 1 :type integer)
  (population #() :type simple-vector)
  (child-population #() :type simple-vector))

(defun make-random-island (chromosome-size direction-of-optimization)
  (make-island :population (vector (make-random-individual chromosome-size direction-of-optimization)
				   (make-random-individual chromosome-size direction-of-optimization))
	       :child-population (vector (make-zero-individual chromosome-size direction-of-optimization)
					 (make-zero-individual chromosome-size direction-of-optimization))))

(defstruct problem
  (population-size 1 :type integer)
  (migration-interval 1 :type integer)
  islands
  evaluate-function
  end-condition-predicate
  direction-of-optimization
  better-predicate
  worse-predicate)

(defun init-problem (population-size chromosome-size migration-interval
		     evaluate-function end-condition-predicate
		     &key (direction-of-optimization 'maximize))
  (assert (evenp population-size))
  (assert (or (eq direction-of-optimization 'maximize)
	      (eq direction-of-optimization 'minimize)))
  (let* ((n-islands (/ population-size 2))
	 (islands (make-array n-islands)))
    (loop for i from 0 to (1- n-islands) do
      (setf (aref islands i) (make-random-island chromosome-size direction-of-optimization)))
    (make-problem :population-size population-size
		  :migration-interval migration-interval
		  :islands islands
		  :evaluate-function evaluate-function
		  :end-condition-predicate end-condition-predicate
		  :direction-of-optimization direction-of-optimization
		  :better-predicate (if (eq direction-of-optimization 'maximize) #'> #'<)
		  :worse-predicate  (if (eq direction-of-optimization 'maximize) #'< #'>))))
 
;;; Crossover & Mutation

(defun crossover! (island)
  (let* ((size (individual-chromosome-size (aref (island-population island) 0)))
	 (pivot (random (1- size))))
    (loop for i from 0 to pivot do
      (setf (aref (individual-chromosome (aref (island-child-population island) 0)) i)
	    (aref (individual-chromosome (aref (island-population island) 0)) i)
	    (aref (individual-chromosome (aref (island-child-population island) 1)) i)
	    (aref (individual-chromosome (aref (island-population island) 1)) i)))
    (loop for i from (1+ pivot) to (1- size) do
      (setf (aref (individual-chromosome (aref (island-child-population island) 0)) i)
	    (aref (individual-chromosome (aref (island-population island) 1)) i)
	    (aref (individual-chromosome (aref (island-child-population island) 1)) i)
	    (aref (individual-chromosome (aref (island-population island) 0)) i)))))

(defun flip-1bit! (arr posi)
  (setf (aref arr posi)
	(if (= (aref arr posi) 1) 0 1)))

(defun mutation! (island)
  (let* ((size (individual-chromosome-size (aref (island-population island) 0)))
	 (mutation-position (random size))
	 (mutation-position-1bit-shift (if (= mutation-position (1- size))
					 0
					 (1+ mutation-position))))
    (flip-1bit! (individual-chromosome (aref (island-child-population island) 0))
		mutation-position)
    (flip-1bit! (individual-chromosome (aref (island-child-population island) 1))
		mutation-position-1bit-shift)))

(defmacro overwrite-individual! (org1 org2)
  `(progn
     (loop for i from 0 to (1- (individual-chromosome-size ,org1)) do
       (setf (aref (individual-chromosome ,org1) i)
	     (aref (individual-chromosome ,org2) i)))
     (setf (individual-evaluated-value ,org1)
	   (individual-evaluated-value ,org2))))

;;; Main processes

(defun island-one-generation-process! (island problem)
  ;; Generate children
  (crossover! island)
  (mutation! island)
  ;; Evaluate children
  (let ((eval-func (problem-evaluate-function problem)))
    (setf (individual-evaluated-value (aref (island-child-population island) 0))
	  (funcall eval-func (individual-chromosome (aref (island-child-population island) 0))))
    (setf (individual-evaluated-value (aref (island-child-population island) 1))
	  (funcall eval-func (individual-chromosome (aref (island-child-population island) 1)))))
  ;; Selection
  (let ((worse-parent
	 (if (funcall (problem-worse-predicate problem)
		      (individual-evaluated-value (aref (island-population island) 0))
		      (individual-evaluated-value (aref (island-population island) 1)))
	   0 1))
	(better-child
	 (if (funcall (problem-better-predicate problem)
		      (individual-evaluated-value (aref (island-child-population island) 0))
		      (individual-evaluated-value (aref (island-child-population island) 1)))
	   0 1)))
    (overwrite-individual!
     (aref (island-population island) worse-parent)
     (aref (island-child-population island) better-child)))
  (incf (island-generation island)))

(defun island-unit-generation-process-and-select-migrant! (island problem)
  (island-one-generation-process! island problem)
  (if (zerop (mod (island-generation island) (problem-migration-interval problem)))
    (aref (island-population island) (random 2)) ; select migrant
    (island-unit-generation-process-and-select-migrant! island problem)))
  
;; Fisher–Yates shuffle
(defun shuffle-vector! (vec)
  (loop for i from (1- (length vec)) downto 1 do
    (let* ((j (random (1+ i)))
	   (tmp (svref vec i)))
      (setf (svref vec i) (svref vec j))
      (setf (svref vec j) tmp)))
  vec)

(defun import-migrants! (problem migrant-vector)
    (loop for island across (problem-islands problem)
	  for migrant across migrant-vector do
	    (let ((worse-parent
		   (if (funcall (problem-worse-predicate problem)
				(individual-evaluated-value (aref (island-population island) 0))
				(individual-evaluated-value (aref (island-population island) 1)))
		     0 1)))
	      (overwrite-individual! (aref (island-population island) worse-parent) migrant))))
	      
(defun run-problem (problem)
  (if (funcall (problem-end-condition-predicate problem) problem)
    'quit
    (let ((migrant-vector
	   (pmap 'vector #'(lambda (island)
			     (island-unit-generation-process-and-select-migrant! island problem))
		 (problem-islands problem))))
      (shuffle-vector! migrant-vector)
      (import-migrants! problem migrant-vector)
      (run-problem problem))))