-
Notifications
You must be signed in to change notification settings - Fork 0
/
selection.clj
165 lines (134 loc) · 5.13 KB
/
selection.clj
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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
(ns clj-genetic.selection
(:use clj-predicates.core))
(defn feasible?
"Checks if a chromosome represents a feasible solution
chromosome - chromosome to check"
[chromosome]
{:pre [(coll? chromosome)]
:post [(boolean? %)]}
(:feasible (meta chromosome)))
(defn not-feasible?
"Checks if a chromosome represents an infeasible solution
chromosome - chromosome to check"
[chromosome]
{:pre [(coll? chromosome)]
:post [(boolean? %)]}
(:not-feasible (meta chromosome)))
(defn binary-tournament-select
"Selects a chromosome according to the following rules:
1. Any feasible solution is preferred to any infeasible solution.
2. Among two feasible solutions, the one having better objective function value is preferred.
3. Among two infeasible solutions, the one having smaller constraint violation is preferred.
a - first chromosome
b - second chromosome"
[a b]
{:pre [(coll? a)
(contains-meta? a :fitness :feasible :not-feasible)
(coll? b)
(contains-meta? b :fitness :feasible :not-feasible)]
:post [(coll? %)]}
(cond
(and (feasible? a)
(not-feasible? b)) a
(and (not-feasible? a)
(feasible? b)) b
(> (:fitness (meta a))
(:fitness (meta b))) a
:else b))
(defn binary-tournament-with-replacement
"Binary tournament selection with replacement (preserves the population size)
chromosomes - a collection of chromosomes"
[chromosomes]
{:pre [(coll? chromosomes)]
:post [(and
(coll? %)
(= (count %) (count chromosomes)))]}
(map (fn [x]
(binary-tournament-select (rand-nth chromosomes)
(rand-nth chromosomes)))
chromosomes))
(defn binary-tournament-without-replacement
"Binary tournament selection without replacement (preserves the population size)
chromosomes - a collection of chromosomes"
[chromosomes]
{:pre [(coll? chromosomes)]
:post [(and
(coll? %)
(= (count %) (count chromosomes)))]}
(if (even? (count chromosomes))
(map #(apply binary-tournament-select %)
(partition 2 (concat (shuffle chromosomes)
(shuffle chromosomes))))
(let [permutation1 (partition-all 2 (shuffle chromosomes))
permutation2 (partition-all 2 (shuffle chromosomes))
last1 (first (last permutation1))]
(conj (map #(apply binary-tournament-select %)
(concat (butlast permutation1)
(butlast permutation2)))
last1))))
(defn euclidian-distance
"Calculates the Euclidian distance between two chromosomes
limits - limits on gene values
chromosome1 - first chromosome
chromosome2 - second chromosome"
[limits chromosome1 chromosome2]
{:pre [(coll? limits)
(coll? chromosome1)
(coll? chromosome2)]
:post [(number? %)]}
(Math/sqrt
(/ (apply +
(map
(fn [{limit-min :min limit-max :max} a b]
(Math/pow (/ (- a b)
(- limit-max limit-min))
2))
limits chromosome1 chromosome2))
(count limits))))
(defn binary-tournament-without-replacement-with-niching
"Binary tournament selection without replacement with niching (preserves the population size)
limits - limits on gene values
chromosomes - a collection of chromosomes"
([limits chromosomes]
{:pre [(coll? limits)
(coll? chromosomes)]
:post [(and
(coll? %)
(= (count %) (count chromosomes)))]}
(binary-tournament-without-replacement-with-niching
limits
0.1
(* 0.25 (count chromosomes))
chromosomes))
([limits d n chromosomes]
{:pre [(coll? limits)
(posnum? d)
(posnum? n)
(coll? chromosomes)]
:post [(and
(coll? %)
(= (count %) (count chromosomes)))]}
(let [cnt (count chromosomes)]
(loop [selected-chromosomes []
permutation (shuffle chromosomes)]
(if (= cnt (count selected-chromosomes))
selected-chromosomes
(if (< (count permutation) 2)
(recur selected-chromosomes
(shuffle chromosomes))
(let [[selected-chromosomes-new permutation-new]
(let [a (first chromosomes)]
(loop [i 0
pool (rest chromosomes)]
(let [b (first pool)
distance (euclidian-distance limits a b)]
(cond
(< distance d) [(conj selected-chromosomes (binary-tournament-select a b))
(rest pool)]
(= i n) [(conj selected-chromosomes a)
(rest pool)]
(= 1 (count pool)) (recur (inc i)
(shuffle chromosomes))
:else (recur (inc i)
(rest pool))))))]
(recur selected-chromosomes-new permutation-new))))))))