-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathgenetic.lisp
106 lines (94 loc) · 3.82 KB
/
genetic.lisp
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
(in-package :fluturel.program-synth)
(defparameter *population* nil)
(defvar *global-lock* (bt:make-lock))
(defclass func-object()
((func-tree :initform nil :initarg :func-tree :accessor func-tree)
(fitness-score :initform -1 :accessor fitness)))
(defmethod update-fitness((p func-object))
(with-accessors ((fitness fitness) (func-tree func-tree)) p
(setf fitness
(/ (reduce #'+
(mapcar (lambda (args)
(let ((result (exec-func func-tree (subseq args 0 4))))
(abs (pd (- (nth 4 args) result) (nth 4 args)))))
*constraints*))
(length *constraints*)))))
(defmethod <fitness((p func-object) (q func-object))
(with-accessors ((fitness-p fitness)) p
(with-accessors ((fitness-q fitness)) q
(> fitness-q fitness-p))))
(defmethod mutate((individual func-object))
(with-accessors ((func-tree func-tree)) individual
(if (< (random 100) 25)
(setf func-tree (replace-random-subtree func-tree (generate-random-tree 2))))
individual))
(defmethod crossover((p func-object) (q func-object))
(with-accessors ((p-tree func-tree)) p
(with-accessors ((q-tree func-tree)) q
(make-instance 'func-object
:func-tree (replace-random-subtree p-tree (random-subtree q-tree))))))
(defun init-population(population-size)
(setf *population* (make-array population-size :adjustable t :fill-pointer 0))
(loop :for i :from 0 :below population-size :do
(vector-push-extend
(make-instance 'func-object :func-tree (generate-random-tree 5))
*population*)))
(defun compute-fitness-population()
(let ((threads (loop :for a :from 0 :below 8 :collect
(let* ((thr a)
(start (floor (* (length *population*) 1/8 thr)))
(end (floor (* (length *population*) 1/8 (+ thr 1)))))
(bt:make-thread
(lambda ()
(locally
(declare (sb-ext:muffle-conditions sb-kernel:redefinition-warning))
(handler-bind ((sb-kernel:redefinition-warning #'muffle-warning))
(loop :for i :from start :below end :do
(update-fitness (aref *population* i)))))))))))
(dolist (thread threads)
(bt:join-thread thread))))
(defun check-for-completion()
(let ((results nil))
(loop :for i :from 0 :below (length *population*) :do
(if (= 0 (fitness (aref *population* i)))
(setf results (cons (aref *population* i) results))))
(dolist (res results)
(format t "~a~%" (slot-value res 'func-tree)))))
(defun choose-parents(number)
(let ((parents nil))
(labels ((tournament (n)
(let ((max-fitness -2)
(result nil))
(dotimes (a (- n 1))
(let* ((rand (random (length *population*)))
(p (aref *population* rand)))
(with-accessors ((fitness fitness)) p
(when (<= max-fitness fitness)
(setf result p)))))
result)))
(dotimes (a number)
(setf parents (cons (tournament 10) parents))))
parents))
(defun evolve(generations population-size)
(time
(locally
(declare (sb-ext:muffle-conditions sb-kernel:redefinition-warning))
(handler-bind ((sb-kernel:redefinition-warning #'muffle-warning))
(init-population population-size)
(format t ">> Started evolving. Constraints:~%")
(format t "~{~a~%~}----------~%" *constraints*)
(loop :for i :from 0 :below generations :do
(compute-fitness-population)
(let ((children nil)
(parents nil))
(setf parents (choose-parents (floor (/ population-size 10))))
(setf children (mapcar #'crossover parents (reverse parents)))
(loop :for j :from 0 :below (length children) :do
(vector-push-extend (elt children j) *population*)))
(map 'list #'mutate *population*)
(compute-fitness-population)
(sort *population* #'<fitness)
(setf (fill-pointer *population*) population-size)
(format t "Generation ~a is done, minimum fitness was ~a~%"
i (fitness (aref *population* 0)))
(check-for-completion))))))