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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
c Stub functions for using PGAPack with a natve datatype, but user
c defined operators.
c
c In Fortran, we cannot allocate memory, nor can we define a C type
c structure, thus, userdefined data types are rather silly. So,
c PGA_USERFUNCTION_CREATESTRING, and PGA_USERFUNCTION_BUILDDATATYPE are
c not allowed.
include 'pgapackf.h'
external MyInitString
external MyCrossover
external MyMutation
external MyDuplicateString
external MyPrintString
external MyDone
external MyEndOfGen
external MyEvaluate
integer MyMutation
integer MyDuplicateString
integer MyDone
double precision MyEvaluate
integer ctx
ctx = PGACreate(PGA_DATATYPE_INTEGER, 10, PGA_MAXIMIZE)
PGASetUserFunction(ctx, PGA_USERFUNCTION_MUTATION, MyMutation)
PGASetUserFunction(ctx, PGA_USERFUNCTION_CROSSOVER, MyCrossover)
PGASetUserFunction(ctx, PGA_USERFUNCTION_PRINTSTRING, MyPrintString)
PGASetUserFunction(ctx, PGA_USERFUNCTION_DUPLICATE, MyDuplicateString)
PGASetUserFunction(ctx, PGA_USERFUNCTION_INITSTRING, MyInitString)
PGASetUserFunction(ctx, PGA_USERFUNCTION_DONE, MyDone)
PGASetUserFunction(ctx, PGA_USERFUNCTION_ENDOFGEN, MyEndOfGen)
PGASetUp(ctx)
PGARun(ctx, MyEvaluate)
PGADestroy(ctx)
stop
end
c Perform mutation on a "string". It is important to keep count of
c the number of mutations performed and to return that value.
c
integer function MyMutation(ctx, p, pop, mr)
include 'pgapackf.h'
integer ctx, p, pop, count, length
double precision mr
length = PGAGetStringLength(ctx)
do i=1, length
if (PGARandomFlip(ctx, mr) .eq. PGA_TRUE) then
c
c Insert code to mutate an allele here. Remember to count
c the number of mutations that happen, and return that value!
c
endif
enddo
MyMutation = count
return
end
c Perform crossover from two parents to two children.
subroutine MyCrossover(ctx, p1, p2, p_pop, c1, c2, c_pop)
include 'pgapackf.h'
integer ctx, p1, p2, p_pop, c1, c2, c_pop
c Perform crossover from P1 and P2 into C1 and C2 here.
return
end
c Print a "string". The second argument is a C file pointer,
c but we cannot do anything with it,
subroutine MyPrintString(ctx, fp, p, pop)
include 'pgapackf.h'
integer ctx, fp, p, pop
c Print the string
return
end
c Determine if two strings are the same. If so, return non-zero,
c otherwise return zero.
integer function MyDuplicateString(ctx, p1, pop1, p2, pop2)
include 'pgapackf.h'
integer ctx, p1, pop1, p2, pop2, equal
c Compare the strings
MyDuplicateString = equal
return
end
c Randomly initialize a string.
subroutine MyInitString(ctx, p, pop)
include 'pgapackf.h'
integer ctx, p, pop
c Insert code to randomly initialize Data here.
return
end
c Check if a GA has found an acceptable solution.
integer function MyDone(ctx)
include 'pgapackf.h'
integer ctx, done
done = PGA_FALSE
c Check for "doneness".
MyDone = done
return
end
c After each generation, this funciton will get called.
subroutine MyEndOfGen(ctx)
include 'pgapackf.h'
integer ctx
c Do something useful; display the population on a graphics output,
c let the user adjust the population, etc.
return
end
c The evaluation function.
double precision function MyEvaluate(ctx, p, pop)
include 'pgapackf.h'
integer ctx, p, pop
c Evaluate the string
MyEvaluate = evaluation
return
end
|
