Particle Swarm Optimization

Triggered by a (German) C't article, last week I experimented a bit 
with Particle Swarm Optimization. The original C++ code accompanying
the article is *completely unreadable* (64 apparently auto-generated 
files without a clear centre, and providing zero insight), so 
I reimplemented the algorithm from the article description and
Googled references:
  http://www.gamasutra.com/features/20051213/villiers_01.shtml
 
http://cirg.cs.up.ac.za/visitPage.php?pageID=resgroups&groupID=swarms&showContent=publications
.

Unfortunately, I found the results quite unconvincing. The number of
calculations needed for successful completion far exceeds the number
that would be needed by simulated annealing (the method I finally
selected for an HF amplifier optimization job at work). 

However, the appended code may save interested hands-on-type readers 
some digging around. And the pictures are nice too :-)

The display shows the swarm converging to the strongest peak of some
target function. If you make the strongest peak narrower, the swarm
ignores it. This is certainly not what should happen.

For this kind of program OOF could've been useful, but I managed 
splendidly with some ad-hoc constructs.

-marcel

-- ----------------------------------------
( *
  * LANGUAGE    : ANS Forth with extensions
  * PROJECT     : Forth Environments
  * DESCRIPTION : Particle Swarm Optimization
  * CATEGORY    : Optimization 
  * AUTHOR      : Marcel Hendrix 
  * LAST CHANGE : January 27, 2008, Marcel Hendrix 
  * )

	NEEDS -structs
	NEEDS -graphics

( *
  Based on 'Von Tieren Lernen', Dr. Cai Ziegler, C't 208, Heft 3,
  Re****t Schwarmintelligenz.

  The algorithm is too greedy: for very narrow peaks the wrong one is
found.
  * )

TRUE VALUE debug?

STRUCT
  dfloat% FIELD .myBestResult
  dfloat% FIELD .myBestX
  dfloat% FIELD .myBestY
  dfloat% FIELD .myX
  dfloat% FIELD .myY
  CELL%   FIELD .myName
  CELL%   FIELD .bestNeighbor
END-STRUCT node%        

0.3e FVALUE COGNITION	\ go to the best remembered
0.3e FVALUE FOLLOW  	\ go to the best in the swarm

#20 CONSTANT maxix
0 VALUE ix 	          
CREATE particles    maxix CELLS  ALLOT

maxix CONSTANT #nb        
CREATE dneighbors   #nb DFLOATS  ALLOT
CREATE 'neighbors   #nb CELLS    ALLOT

0 VALUE funcs             

\ Boundaries of the target function
 -4e FVALUE fxmin
 +4e FVALUE fxmax
 -4e FVALUE fymin
 +4e FVALUE fymax
0.1e FVALUE noise

\ The target function to MAXIMIZE
: result ( F: x y -- z )  
	FLOCALS| y x |
	1 +TO funcs
	x -2e F- FSQR  y -2e F- FSQR F+ FSQRT FNEGATE 3e   F/ FEXP   5e F* 
	x  2e F- FSQR  y  2e F- FSQR F+ FSQRT FNEGATE 2e   F/ FEXP  15e F* F+
	x  2e F- FSQR  y -2e F- FSQR F+ FSQRT FNEGATE 2e   F/ FEXP  12e F* F+
	x -2e F- FSQR  y  2e F- FSQR F+ FSQRT FNEGATE 2e   F/ FEXP  -4e F* F+ ;
	
: MAP ( xt -- ) >S ix 0 ?DO  particles I CELL[] @[EMAIL PROTECTED]
  S EXECUTE  LOOP -S ;

: (init) ( addr -- )
	LOCALS| me |
	particles @[EMAIL PROTECTED]
  me .bestNeighbor  !
	fxmax fxmin F- 1e F/ 1 FCHOOSE F* fxmin F+   FDUP me .myX DF! FDUP me
.myBestX DF!
	fymax fymin F- 1e F/ 1 FCHOOSE F* fymin F+   FDUP me .myY DF! FDUP me
.myBestY DF!
	result  me .myBestResult  DF! ;

: (.particle) ( addr -- ) 
	CR ." My name       = " DUP .myName         @[EMAIL PROTECTED]
 .ID
	CR ." Best neighbor = " DUP .bestNeighbor   @[EMAIL PROTECTED]
 .myName @[EMAIL PROTECTED]
 .ID
	CR ."  my   X       = " DUP .myX          DF@[EMAIL PROTECTED]
 F.N1 
	CR ."  my   Y       = " DUP .myY          DF@[EMAIL PROTECTED]
 F.N1
	CR ." best result   = " DUP .myBestResult DF@[EMAIL PROTECTED]
 F.N1 
	CR ."  best X       = " DUP .myBestX      DF@[EMAIL PROTECTED]
 F.N1 
	CR ."  best Y       = "     .myBestY      DF@[EMAIL PROTECTED]
 F.N1 ;        

: PARTICLE ( ix -- )  
	S>D <# #S 'p' HOLD #> ['] CREATE $PROCESS
	node% %allot  DUP particles ix CELL[] !  1 +TO ix  
	ix maxix U> ABORT" too many PARTICLEs" 
	@[EMAIL PROTECTED]
 SWAP 2DUP ( -- nfa addr nfa addr ) .myName ! .bestNeighbor ! ;

: MAKE-PARTICLES  maxix 0 DO  I PARTICLE  LOOP ; MAKE-PARTICLES

\ test all neighbors
: TEST-NB ( F: r1 -- r2 ) ( -- ix )
	#nb DUP 0 ?DO  FDUP dneighbors I DFLOAT[] DF@[EMAIL PROTECTED]
 F<
		       IF  DROP I LEAVE  ENDIF
	         LOOP  ;        

\ insert new neighbor in list of closest neighbors
: INSERT-NEW ( obj ix -- ) ( F: r -- )
	LOCALS| ix |
	'neighbors ix CELLS   + DUP CELL+    #nb 1- ix - CELLS   MOVE  'neighbors
ix CELL[]     !
	dneighbors ix DFLOATS + DUP DFLOAT+  #nb 1- ix - DFLOATS MOVE  dneighbors
ix DFLOAT[] DF! ;        

: (closest) ( addr -- )
	0 LOCALS| him me |
	me .myX DF@[EMAIL PROTECTED]
 me .myY DF@[EMAIL PROTECTED]
 -1e38 FLOCALS| best Y X |

	#nb 0 ?DO  0    'neighbors I CELL[]     !  
		   1e38 dneighbors I DFLOAT[] DF!
	     LOOP

	ix 0 ?DO 
		    particles I CELL[] @[EMAIL PROTECTED]
 TO him
		    him .myX DF@[EMAIL PROTECTED]
  X F- FSQR  him .myY DF@[EMAIL PROTECTED]
  Y F- FSQR  F+
		    TEST-NB DUP #nb <
		       IF  him SWAP INSERT-NEW
		     ELSE  DROP FDROP
		    ENDIF
	     LOOP 

	me #nb 1 DO  
		    'neighbors I CELL[] @[EMAIL PROTECTED]
 TO him 
		    him .myX DF@[EMAIL PROTECTED]
  him .myY DF@[EMAIL PROTECTED]
  
		    result FDUP best F> IF  TO best DROP him  
		    		      ELSE  FDROP  
				     ENDIF
	       LOOP  
	me .bestNeighbor ! ;        

: (generate) ( addr -- ) 
	LOCALS| me |
	0e FLOCAL cogni
	0e FLOCAL follw
	
	me .myBestResult DF@[EMAIL PROTECTED]
 
	me .bestNeighbor @[EMAIL PROTECTED]
 DUP .myX DF@[EMAIL PROTECTED]
 .myY DF@[EMAIL PROTECTED]
 result
	F2DUP F> IF  FSWAP  ENDIF F/ 
	FDUP F0< IF  FDROP 0.5e  ENDIF FDUP  FOLLOW    F* TO follw	\ my >
neighbor =>  
			         1e FSWAP F- COGNITION F* TO cogni

	me .myBestX             DF@[EMAIL PROTECTED]
  me .myX DF@[EMAIL PROTECTED]
 F- cogni F* 		\ REMEMBER *
(myBestX-X)
	me .bestNeighbor @[EMAIL PROTECTED]
 .myX DF@[EMAIL PROTECTED]
  me .myX DF@[EMAIL PROTECTED]
 F- follw F* F+  	\ FOLLOW *
(bestNeighborX-X)
	2 FCHOOSE F1- noise F* F+					\ add some "noise"
	me .myX DF@[EMAIL PROTECTED]
 F+	fxmin FMAX fxmax FMIN   FDUP me .myX DF!

	me .myBestY             DF@[EMAIL PROTECTED]
  me .myY DF@[EMAIL PROTECTED]
 F- cogni F* 		\ REMEMBER *
(myBestY-Y)
	me .bestNeighbor @[EMAIL PROTECTED]
 .myY DF@[EMAIL PROTECTED]
  me .myY DF@[EMAIL PROTECTED]
 F- follw F* F+  	\ FOLLOW *
(bestNeighborY-Y)
	2 FCHOOSE F1- noise F* F+					\ add some "noise"
	me .myY DF@[EMAIL PROTECTED]
 F+  fymin FMAX fymax FMIN   FDUP me .myY DF!

	F2DUP result  FDUP me .myBestResult DF@[EMAIL PROTECTED]
 
	F> IF  me .myBestResult DF!  me .myBestY DF!  me .myBestX DF!
	 ELSE  F3DROP  
	ENDIF ;

: (plot) ( addr -- ) 
	DUP .myX DF@[EMAIL PROTECTED]
 
	    .myY DF@[EMAIL PROTECTED]
 SCALE #10 red FCIRCLE ;        

: gshow ( -- )
	0 0 Xmax Ymax  fxmin fymin fxmax fymax SET-GWINDOW
	GCLEAR
	VTHICKPUT!
	  ['] (plot) MAP 
	  -2e -2e SCALE #15 green CIRCLE
	  +2e -2e SCALE #15 green CIRCLE
	  +2e +2e SCALE #15 green CIRCLE
	  -2e +2e SCALE #15 green CIRCLE
	PUT! ;

: initialize   ( -- ) ['] (init)      MAP ;	\ Initialize particles
: .particles   ( -- ) ['] (.particle) MAP ;	\ Print all particles
: find-closest ( -- ) ['] (closest)   MAP ;	\ Find #nb-1 particles closest
to point-i
: generate     ( -- ) ['] (generate)  MAP ;	\ generate new results

: best-result  ( -- addr ) ( F: -- r )  
	-1e38 0e FLOCALS| sum mmax | 
	0 LOCALS| addr |
	ix 0 ?DO  particles I CELL[] @[EMAIL PROTECTED]
 DUP .myBestResult DF@[EMAIL PROTECTED]
  FDUP mmax F> IF  TO addr FDUP TO mmax  
		  	     ELSE  DROP 
			    ENDIF  +TO sum
	    LOOP  
	addr sum ix S>F F/ ;        

: SWARM ( F: delta -- )	
	FABS 1e38 FLOCALS| ores delta |
	0 0 0 LOCALS| times iters best-one |
	CLEAR funcs  
	initialize 
	BEGIN  
	  1 +TO iters
	  debug? IF  gshow  ENDIF
	  find-closest generate 
	  best-result TO best-one FDUP ores F- FABS FSWAP TO ores
	  delta F< IF  1 +TO times times 3 > 
	  	 ELSE  CLEAR times FALSE  
	        ENDIF  iters #99 > OR
	UNTIL 
	CR ." Result smaller than " delta F.N1 ."  after " iters DEC. ."
iterations and " funcs DEC. ." evaluations."
	CR ." COGNITION is " COGNITION F.N1 ." , FOLLOW is " FOLLOW F.N1 &. EMIT
	CR ." Best performing particle is " best-one .myName @[EMAIL PROTECTED]
 .ID 
	   ." , result is " best-one .myBestResult DF@[EMAIL PROTECTED]
 F. 
	   ." , at ( " best-one .myX DF@[EMAIL PROTECTED]
 F. best-one .myY DF@[EMAIL PROTECTED]
 F. ." )" ;

: .ABOUT CR ." Try: ( F: r -- ) SWARM      -- r is delta last iteration" 
	 CR ."      TRUE | FALSE TO debug? -- verbose output" ;

		.ABOUT CR

                              ( * End of Source * )