ahmed
2024-03-31 09:31:57 UTC
Hi,
Here is my attempt to write a PSO programme and some applications. It is written for gforth.
Save the code for PSO as pso.fs and include it in application files.
=======Here begins the code for PSO: pso.fs
include random.fs
\ : random choose ;
: frand 1000000000000 random s>f 1e-12 f* ;
: frandom ( f: xmin xmax -- ) fover f- frand f* f+ ;
20 value nvars_max
0 value nvars
0 value Cost
0 value particle_size
0 value population_size
0 value population
0 value print_iter
10 value iter_max
10 value max_iter_without_change
0 value num_iter_without_change
2.05e fvalue c1
2.05e fvalue c2
0.7298e fvalue ki
fvariable Jgb
1e9 Jgb f!
fvariable Jgb_pre
1e9 Jgb_pre f!
1e-5 fvalue ftol
create X nvars_max floats allot
create Xgb nvars_max floats allot
create (r1) nvars_max floats allot
create (r2) nvars_max floats allot
create xmin nvars_max floats allot
create xmax nvars_max floats allot
: r1 nvars 0 do frand i (r1) swap floats + f! loop ;
: r2 nvars 0 do frand i (r2) swap floats + f! loop ;
: >xmin ( f: x1min ... -- ) nvars 0 do nvars 1- i - floats xmin + f! loop ;
: >xmax ( f: x1max ... -- ) nvars 0 do nvars 1- i - floats xmax + f! loop ;
: cr1th (r1) swap floats + f@ c1 f* ;
: cr2th (r2) swap floats + f@ c2 f* ;
: problem: dup to nvars 3 * 2 + floats to particle_size ' to Cost ;
: >options to print_iter to ftol to max_iter_without_change to iter_max ;
: particle_swarm: to population_size create population_size particle_size * allot does> to population ;
: (particle) ( n -- p) particle_size * + ;
: xth ( i -- ) floats + ;
: vth ( i -- ) nvars + xth ;
: J nvars 2* xth ;
: Xlbth ( i -- ) nvars 2* 1+ + xth ;
: Jlb nvars 3 * 1+ xth ;
: Xgbth ( i -- Xgbtha) floats Xgb + ;
: particle ( n -- p ) population swap (particle) ;
: particleXth ( i n -- xtha ) particle swap xth ;
: particleVth ( i n -- vtha ) particle swap vth ;
: particleJ ( n -- Ja ) particle J ;
: particleXlbth ( i n -- Xlbtha ) particle swap Xlbth ;
: particleJlb ( n -- Jlba ) particle Jlb ;
: updateXth ( i n -- ) 2dup particleXth f@ 2dup particleVth f@ f+ particleXth f! ;
: updateX ( n -- ) nvars 0 do i over updateXth loop drop ;
: updateVth ( i n -- )
2dup particleVth f@
over Xgbth f@ 2dup particleXth f@ f- over cr1th f* f+
2dup particleXlbth f@ 2dup particleXth f@ f- over cr2th f* f+
ki f*
particleVth f! ;
: updateV ( n -- )
nvars 0
do
r1 r2
i over updateVth
loop
drop ;
: updateJ ( n --)
dup
particle x nvars floats move
x Cost execute particleJ f! ;
: updateJlbXlb ( n --)
dup particleJlb f@
dup particleJ f@ f>
if
dup particleJ f@ dup particleJlb f!
nvars 0
do
i over particleXth f@ i over particleXlbth f!
loop
then
drop ;
: update_particle ( n --) dup updateV dup updateX dup updateJ updateJlbXlb ;
: update_population
population_size 0
do
i update_particle
loop ;
: init_population
population_size 0
do
i
nvars 0
do
0e i over particleVth f!
i floats xmin + f@
i floats xmax + f@
frandom
fdup i over particleXth f!
i over particleXlbth f!
loop
i particle x nvars floats move
x Cost execute fdup
particleJ f!
i particleJlb f!
loop ;
: updateJgbXgb
population_size 0
do
i particleJlb f@ fdup Jgb f@ f<
if
Jgb f!
i
nvars 0
do
i over particleXlbth f@ i Xgbth f!
loop
drop
else
fdrop
then
loop ;
: solve
1e9 Jgb f!
0 to num_iter_without_change
init_population
updateJgbXgb
iter_max 0
do
update_population
updateJgbXgb
Jgb f@ Jgb_pre f@ f- fabs ftol f<
if
num_iter_without_change 1+ to num_iter_without_change
else
0 to num_iter_without_change
then
num_iter_without_change max_iter_without_change =
if
leave ( unloop)
then
Jgb f@ Jgb_pre f!
print_iter
if
cr i . ." iteration: "
nvars 0
do
3 spaces
i xgbth f@ f.
loop
3 spaces Jgb f@ f.
then
loop
cr cr cr ." The solution is : "
nvars 0
do
i xgbth f@ f. 3 spaces
loop
cr ." The correspondant Cost is : "
Jgb f@ f.
cr cr cr ;
=======Here the code ends
Some applications (tests) are given below:
========1st application: pso_test1.fs
include pso.fs
\ The true solution is x1 = 0.5e, x2 = 8.3e, x3 = 5.8e and x4 = 2.6e and the minimal cost is 0.5e
: Cost1 ( x -- ) ( f: -- C) dup 3 xth f@ 2.6e f- fdup f* dup 2 xth f@ 5.8e f- fdup f* f+ dup 1 xth f@ 8.3e f- fdup f* f+ f@ 0.5e f- fdup f* f+ 0.5e f+ ;
4 problem: Cost1
1000 particle_swarm: PS1
50 10 1e-2 true >options
-10e -10e -10e -10e >xmin
10e 10e 10e 10e >xmax
PS1 solve
\ cr ." Done. Bye
========2nd application: pso_test2.fs
include pso.fs
\ The true solution is x1 = 8.3e, x2 = 5.8e and x3 = 2.6e and the minimal cost is 0.5e
: Cost1 ( x -- ) ( f: -- C) dup 2 xth f@ 2.6e f- fdup f* dup 1 xth f@ 5.8e f- fdup f* f+ f@ 8.3e f- fdup f* f+ 0.5e f+ ;
3 problem: Cost1
1000 particle_swarm: PS1
50 10 1e-2 false >options
-10e -10e -10e >xmin
10e 10e 10e >xmax
PS1 solve
\ cr ." Done. Bye"
========3rd application:pso_test3.fs
include pso.fs
\ The true solution is x1 = 5.8e and x2 = 2.6e and the minimal cost is 0.5e
: Cost1 ( x -- ) ( f: -- C) dup 1 xth f@ 2.6e f- fdup f* f@ 5.8e f- fdup f* f+ 0.5e f+ ;
2 problem: Cost1
1000 particle_swarm: PS1
50 10 1e-2 false >options
-10e -10e >xmin
10e 10e >xmax
PS1 solve
\ cr ." Done. Bye"
========4th application: pso_test4.fs
include pso.fs
\ The true solution is x1 = 2e and x2 = 2e and the minimal cost is about -16.841358408616
: f3_1() ( f: x1 x2 -- res) fswap -2e f- fdup f* fswap -2e f- fdup f* f+ fsqrt 3e f/ fnegate fexp 5e f* ;
: f3_2() ( f: x1 x2 -- res) fswap 2e f- fdup f* fswap 2e f- fdup f* f+ fsqrt 2e f/ fnegate fexp 15e f* ;
: f3_3() ( f: x1 x2 -- res) fswap 2e f- fdup f* fswap -2e f- fdup f* f+ fsqrt 2e f/ fnegate fexp 12e f* ;
: f3_4() ( f: x1 x2 -- res) fswap -2e f- fdup f* fswap 2e f- fdup f* f+ fsqrt 2e f/ fnegate fexp -4e f* ;
: f3() ( x --) ( f: -- res)
dup f@ 1 xth f@
fover fover f3_1() frot frot
fover fover f3_2() frot frot
fover fover f3_3() frot frot
f3_4() f+ f+ f+ ;
: Cost3 f3() fnegate ; \ here we maximize f3() (the use of fnegate to minimize)
2 problem: Cost3
1000 particle_swarm: PS1
100 10 1e-2 false >options
-4e -4e >xmin
4e 4e >xmax
PS1 solve
\ cr ." Done. Bye"
========5th application: pso_test5.fs
include pso.fs
\ The true solution is x = 0.56714329.. and the minimal cost is 0e, solution of x-exp(-x)=0 (or x*exp(x)=1)
: f1() ( f: x -- y) fdup fnegate fexp f- ;
: Cost1 ( x -- ) ( f: -- C) f@ f1() fabs ;
1 problem: Cost1
1000 particle_swarm: PS1
500 10 1e-3 false >options
1e >xmin
2e >xmax
PS1 solve
\ cr ." Done. Bye"
=======6th application: pso_test6.fs
include pso.fs
\ The true solution is x_i = i^2, i = 3 ... 12
: Cost1 ( x -- )( f: -- c) 0e 10 0 do dup i xth f@ i 3 + dup * s>f f- fabs f+ loop drop ;
10 problem: Cost1
100 particle_swarm: PS1
500 10 1e-3 false >options
0e 0e 0e 0e 0e 0e 0e 0e 0e 0e >xmin
200e 200e 200e 200e 200e 200e 200e 200e 200e 200e >xmax
PS1 solve
\ cr ." Done. Bye"
========= Here, the applications (tests) finish
Any comments and remarks are appreciated
Ahmed
Here is my attempt to write a PSO programme and some applications. It is written for gforth.
Save the code for PSO as pso.fs and include it in application files.
=======Here begins the code for PSO: pso.fs
include random.fs
\ : random choose ;
: frand 1000000000000 random s>f 1e-12 f* ;
: frandom ( f: xmin xmax -- ) fover f- frand f* f+ ;
20 value nvars_max
0 value nvars
0 value Cost
0 value particle_size
0 value population_size
0 value population
0 value print_iter
10 value iter_max
10 value max_iter_without_change
0 value num_iter_without_change
2.05e fvalue c1
2.05e fvalue c2
0.7298e fvalue ki
fvariable Jgb
1e9 Jgb f!
fvariable Jgb_pre
1e9 Jgb_pre f!
1e-5 fvalue ftol
create X nvars_max floats allot
create Xgb nvars_max floats allot
create (r1) nvars_max floats allot
create (r2) nvars_max floats allot
create xmin nvars_max floats allot
create xmax nvars_max floats allot
: r1 nvars 0 do frand i (r1) swap floats + f! loop ;
: r2 nvars 0 do frand i (r2) swap floats + f! loop ;
: >xmin ( f: x1min ... -- ) nvars 0 do nvars 1- i - floats xmin + f! loop ;
: >xmax ( f: x1max ... -- ) nvars 0 do nvars 1- i - floats xmax + f! loop ;
: cr1th (r1) swap floats + f@ c1 f* ;
: cr2th (r2) swap floats + f@ c2 f* ;
: problem: dup to nvars 3 * 2 + floats to particle_size ' to Cost ;
: >options to print_iter to ftol to max_iter_without_change to iter_max ;
: particle_swarm: to population_size create population_size particle_size * allot does> to population ;
: (particle) ( n -- p) particle_size * + ;
: xth ( i -- ) floats + ;
: vth ( i -- ) nvars + xth ;
: J nvars 2* xth ;
: Xlbth ( i -- ) nvars 2* 1+ + xth ;
: Jlb nvars 3 * 1+ xth ;
: Xgbth ( i -- Xgbtha) floats Xgb + ;
: particle ( n -- p ) population swap (particle) ;
: particleXth ( i n -- xtha ) particle swap xth ;
: particleVth ( i n -- vtha ) particle swap vth ;
: particleJ ( n -- Ja ) particle J ;
: particleXlbth ( i n -- Xlbtha ) particle swap Xlbth ;
: particleJlb ( n -- Jlba ) particle Jlb ;
: updateXth ( i n -- ) 2dup particleXth f@ 2dup particleVth f@ f+ particleXth f! ;
: updateX ( n -- ) nvars 0 do i over updateXth loop drop ;
: updateVth ( i n -- )
2dup particleVth f@
over Xgbth f@ 2dup particleXth f@ f- over cr1th f* f+
2dup particleXlbth f@ 2dup particleXth f@ f- over cr2th f* f+
ki f*
particleVth f! ;
: updateV ( n -- )
nvars 0
do
r1 r2
i over updateVth
loop
drop ;
: updateJ ( n --)
dup
particle x nvars floats move
x Cost execute particleJ f! ;
: updateJlbXlb ( n --)
dup particleJlb f@
dup particleJ f@ f>
if
dup particleJ f@ dup particleJlb f!
nvars 0
do
i over particleXth f@ i over particleXlbth f!
loop
then
drop ;
: update_particle ( n --) dup updateV dup updateX dup updateJ updateJlbXlb ;
: update_population
population_size 0
do
i update_particle
loop ;
: init_population
population_size 0
do
i
nvars 0
do
0e i over particleVth f!
i floats xmin + f@
i floats xmax + f@
frandom
fdup i over particleXth f!
i over particleXlbth f!
loop
i particle x nvars floats move
x Cost execute fdup
particleJ f!
i particleJlb f!
loop ;
: updateJgbXgb
population_size 0
do
i particleJlb f@ fdup Jgb f@ f<
if
Jgb f!
i
nvars 0
do
i over particleXlbth f@ i Xgbth f!
loop
drop
else
fdrop
then
loop ;
: solve
1e9 Jgb f!
0 to num_iter_without_change
init_population
updateJgbXgb
iter_max 0
do
update_population
updateJgbXgb
Jgb f@ Jgb_pre f@ f- fabs ftol f<
if
num_iter_without_change 1+ to num_iter_without_change
else
0 to num_iter_without_change
then
num_iter_without_change max_iter_without_change =
if
leave ( unloop)
then
Jgb f@ Jgb_pre f!
print_iter
if
cr i . ." iteration: "
nvars 0
do
3 spaces
i xgbth f@ f.
loop
3 spaces Jgb f@ f.
then
loop
cr cr cr ." The solution is : "
nvars 0
do
i xgbth f@ f. 3 spaces
loop
cr ." The correspondant Cost is : "
Jgb f@ f.
cr cr cr ;
=======Here the code ends
Some applications (tests) are given below:
========1st application: pso_test1.fs
include pso.fs
\ The true solution is x1 = 0.5e, x2 = 8.3e, x3 = 5.8e and x4 = 2.6e and the minimal cost is 0.5e
: Cost1 ( x -- ) ( f: -- C) dup 3 xth f@ 2.6e f- fdup f* dup 2 xth f@ 5.8e f- fdup f* f+ dup 1 xth f@ 8.3e f- fdup f* f+ f@ 0.5e f- fdup f* f+ 0.5e f+ ;
4 problem: Cost1
1000 particle_swarm: PS1
50 10 1e-2 true >options
-10e -10e -10e -10e >xmin
10e 10e 10e 10e >xmax
PS1 solve
\ cr ." Done. Bye
========2nd application: pso_test2.fs
include pso.fs
\ The true solution is x1 = 8.3e, x2 = 5.8e and x3 = 2.6e and the minimal cost is 0.5e
: Cost1 ( x -- ) ( f: -- C) dup 2 xth f@ 2.6e f- fdup f* dup 1 xth f@ 5.8e f- fdup f* f+ f@ 8.3e f- fdup f* f+ 0.5e f+ ;
3 problem: Cost1
1000 particle_swarm: PS1
50 10 1e-2 false >options
-10e -10e -10e >xmin
10e 10e 10e >xmax
PS1 solve
\ cr ." Done. Bye"
========3rd application:pso_test3.fs
include pso.fs
\ The true solution is x1 = 5.8e and x2 = 2.6e and the minimal cost is 0.5e
: Cost1 ( x -- ) ( f: -- C) dup 1 xth f@ 2.6e f- fdup f* f@ 5.8e f- fdup f* f+ 0.5e f+ ;
2 problem: Cost1
1000 particle_swarm: PS1
50 10 1e-2 false >options
-10e -10e >xmin
10e 10e >xmax
PS1 solve
\ cr ." Done. Bye"
========4th application: pso_test4.fs
include pso.fs
\ The true solution is x1 = 2e and x2 = 2e and the minimal cost is about -16.841358408616
: f3_1() ( f: x1 x2 -- res) fswap -2e f- fdup f* fswap -2e f- fdup f* f+ fsqrt 3e f/ fnegate fexp 5e f* ;
: f3_2() ( f: x1 x2 -- res) fswap 2e f- fdup f* fswap 2e f- fdup f* f+ fsqrt 2e f/ fnegate fexp 15e f* ;
: f3_3() ( f: x1 x2 -- res) fswap 2e f- fdup f* fswap -2e f- fdup f* f+ fsqrt 2e f/ fnegate fexp 12e f* ;
: f3_4() ( f: x1 x2 -- res) fswap -2e f- fdup f* fswap 2e f- fdup f* f+ fsqrt 2e f/ fnegate fexp -4e f* ;
: f3() ( x --) ( f: -- res)
dup f@ 1 xth f@
fover fover f3_1() frot frot
fover fover f3_2() frot frot
fover fover f3_3() frot frot
f3_4() f+ f+ f+ ;
: Cost3 f3() fnegate ; \ here we maximize f3() (the use of fnegate to minimize)
2 problem: Cost3
1000 particle_swarm: PS1
100 10 1e-2 false >options
-4e -4e >xmin
4e 4e >xmax
PS1 solve
\ cr ." Done. Bye"
========5th application: pso_test5.fs
include pso.fs
\ The true solution is x = 0.56714329.. and the minimal cost is 0e, solution of x-exp(-x)=0 (or x*exp(x)=1)
: f1() ( f: x -- y) fdup fnegate fexp f- ;
: Cost1 ( x -- ) ( f: -- C) f@ f1() fabs ;
1 problem: Cost1
1000 particle_swarm: PS1
500 10 1e-3 false >options
1e >xmin
2e >xmax
PS1 solve
\ cr ." Done. Bye"
=======6th application: pso_test6.fs
include pso.fs
\ The true solution is x_i = i^2, i = 3 ... 12
: Cost1 ( x -- )( f: -- c) 0e 10 0 do dup i xth f@ i 3 + dup * s>f f- fabs f+ loop drop ;
10 problem: Cost1
100 particle_swarm: PS1
500 10 1e-3 false >options
0e 0e 0e 0e 0e 0e 0e 0e 0e 0e >xmin
200e 200e 200e 200e 200e 200e 200e 200e 200e 200e >xmax
PS1 solve
\ cr ." Done. Bye"
========= Here, the applications (tests) finish
Any comments and remarks are appreciated
Ahmed