unit1.pas

人工神经网络和人工智能Delphi版语言的源程序（Neural Networks and AI Delphi Sources）。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, Buttons, StdCtrls, Menus, TrayIcon;

const
  wd = 500;
  ht = 300;

type
  TEvolve = class(TForm)
    ScrollBox1: TScrollBox;
    Panel1: TPanel;
    Stat: TLabel;
    SpeedButton2: TSpeedButton;
    SpeedButton4: TSpeedButton;
    clock: TTimer;
    world: TImage;
    countstat: TPanel;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Exit1: TMenuItem;
    N1: TMenuItem;
    PrintSetup1: TMenuItem;
    Print1: TMenuItem;
    N2: TMenuItem;
    SaveAs1: TMenuItem;
    Save1: TMenuItem;
    Open1: TMenuItem;
    View1: TMenuItem;
    BugSet: TMenuItem;
    Help1: TMenuItem;
    About1: TMenuItem;
    TimeShow: TPanel;
    bugstat: TMenuItem;
    SpeedButton1: TSpeedButton;
    TrayIcon1: TTrayIcon;
    Settings1: TMenuItem;
    TaskTray1: TMenuItem;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton4Click(Sender: TObject);
    procedure clockTimer(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure worldMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure BugSetClick(Sender: TObject);
    procedure bugstatClick(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure TrayIcon1DblClick(Sender: TObject);
    procedure TaskTray1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  abug = record
    gene : array[1..6] of integer;
    dir : integer;
    health : integer;
    xpos, ypos : integer;
  end;
  pabug = ^abug;

var
  Evolve: TEvolve;
  bugs : tlist;
  xdir, ydir : array[1..6] of integer;
  worldtime : integer;
  isinit : boolean;

  procedure init;
  function bugnfo(pb : pabug) : string;

implementation

uses Unit2, Unit3;

{$R *.DFM}
function convtime(x : integer) : string;

function adz(z : string) : string;
begin
  if length(z)=1 then
    adz:='0'+z
  else
    adz:=z;
end;

var
  a, b, c : string;
begin
  a:=adz(inttostr(x div 3600));
  b:=adz(inttostr((x div 60) mod 3600));
  c:=adz(inttostr(x mod 60));
  convtime:=a+':'+b+':'+c;
end;

procedure wlog(z : string);
begin
  z:=convtime(worldtime)+'-'+z;
  if status.logflag.checked then
    status.log.lines.add(z);
end;

procedure loct(z : pabug);
begin
  {makes a bounding rectangle}
{  with z do begin
    if xpos<0 then xpos:=0;
    if xpos>(wd-5) then xpos:=(wd-5);
    if ypos<0 then ypos:=0;
    if ypos>(ht-5) then ypos:=(ht-5);
  end;}

  {makes a toroidal (wrapped) space}
  with z^ do begin
    if xpos<0 then xpos:=wd-5;
    if xpos>(wd-5) then xpos:=0;
    if ypos<0 then ypos:=ht-5;
    if ypos>(ht-5) then ypos:=0;
  end;
end;

procedure Init;
var
  t, l : integer;
  p : pabug;
  w, h : integer;
  x, y : integer;
begin
  isinit:=true;
  wlog('Begin initialization.');
  worldtime:=0;
  evolve.stat.caption:='Initializing.';
  bugs:=tlist.create;
  randomize;
  evolve.world.width:=wd;
  evolve.world.height:=ht;

{Create bugs}
  for t:=1 to settings.udspop.position do begin
    new(p);
    {Give bugs random gene pool}
    for l:=1 to 6 do
      p^.gene[l]:=random(10);
    {Place bugs in random locations}
    p^.xpos:=random(wd);
    p^.ypos:=random(ht);
    p^.health:=settings.udinitenergy.position;
    p^.dir:=1; {of 6}
    loct(p);
    bugs.add(p);
  end;

  {prerain}
  for t:=1 to 1000 do
    evolve.world.canvas.pixels[random(wd),random(ht)]:=clBlack;

  {draw bugs}
  evolve.world.canvas.pen.color:=clblue;
  for t:=0 to 99 do begin
    p:=bugs[t];
    x:=p^.xpos;
    y:=p^.ypos;
    evolve.world.canvas.ellipse(x,y,x+5,y+5);
  end;

  {setup xdir and ydir}
  for t:=1 to 18 do begin
    xdir[t]:=round(cos(pi/3*t)*5);
    ydir[t]:=round(sin(pi/3*t)*5);
  end;

  evolve.stat.caption:='Finished initializing.';
  evolve.world.repaint;
  wlog('Initialization completed.');
end;

procedure diebug(bugno : integer);
var
  p : pabug;
  x, y : integer;
begin
  p:=bugs.items[bugno];
  wlog('Bug died: '+bugnfo(p));
  x:=p^.xpos;
  y:=p^.ypos;
  evolve.world.canvas.pen.color:=clWhite;
  evolve.world.canvas.ellipse(x,y,x+5,y+5);
  dispose(p);
  bugs.delete(bugno);
  evolve.stat.caption:='A bug has died.';
end;

procedure mitosis(p : pabug);
var
  l : integer;
  p2 : pabug;
  gn : integer;
  afam : integer;
begin
  new(p2);
  {Give bugs random gene pool}
  afam:=settings.udgnaffamt.position;
  for l:=1 to 6 do
    p2^.gene[l]:=p^.gene[l];
  for l:=1 to settings.udnumgnaff.position do begin
    gn:=random(6)+1;
    p2^.gene[gn]:=p^.gene[gn]+random(afam+1)-(afam div 2);
    if p2^.gene[gn]<0 then p2^.gene[gn]:=0;
  end;
  {Place bugs in random locations}
  p2^.xpos:=p^.xpos;
  p2^.ypos:=p^.ypos;
  p2^.health:=settings.udinitenergy.position;
  p^.health:=settings.udinitenergy.position;
  p2^.dir:=random(6)+1; {1 of 6}
  loct(p2);
  bugs.add(p2);
  wlog('Bug born: '+bugnfo(p)+'(parent)  '+bugnfo(p2)+'(child)');
  evolve.stat.caption:='A bug is born to it''s happy parent!';
end;

procedure killall;
var
  t, l : integer;
  p : ^abug;
begin
  l:=bugs.count;
  for t:=1 to l do begin
    p:=bugs.items[0];
    dispose(p);
    bugs.delete(0)
  end;
  bugs.free;
  isinit:=false;
  evolve.world.canvas.pen.color:=clWhite;
  for t:=0 to evolve.world.height-1 do begin
    evolve.world.canvas.moveto(0,t);
    evolve.world.canvas.lineto(evolve.world.width,t);
  end;
  evolve.world.repaint;
  wlog('Bug world has been reset.');
end;

procedure TEvolve.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if isinit then
    killall;
end;

procedure TEvolve.FormShow(Sender: TObject);
begin
  isinit:=false;
end;

procedure TEvolve.SpeedButton2Click(Sender: TObject);
begin
  if not isinit then
    init;
  stat.caption:='Time has started.';
  clock.enabled:=true;
end;

procedure TEvolve.SpeedButton4Click(Sender: TObject);
begin
  stat.caption:='Time has been suspended.';
  application.title:='Evolve - suspended';
  clock.enabled:=false;
end;

function fixdir (i : integer) : integer;
begin
  if i<1 then i:=i+18;
  if i>18 then i:=i-18;
  fixdir:=i;
end;

function findfood(x, y : integer) : integer;
var
  xx, yy : integer;
  fdcnt : integer;
begin
  fdcnt:=0;

  for xx:=0 to 4 do
    for yy:=0 to 4 do
      if evolve.world.canvas.pixels[x+xx,y+yy]=clBlack then begin
        fdcnt:=fdcnt+1;
        evolve.world.canvas.pixels[x+xx,y+yy]:=clWhite;
      end;
  findfood:=fdcnt;
end;

procedure tick(p : pabug);
var
  totgn : integer;
  mark : integer;
  actgn : integer;
  x, y : integer;
  t : integer;
begin
  {erase}
  x:=p^.xpos;
  y:=p^.ypos;
  evolve.world.canvas.pen.color:=clWhite;
  evolve.world.canvas.ellipse(x,y,x+5,y+5);

  {determine movement from genetic weights}
  totgn:=0;
  for t:=1 to 6 do
    totgn:=totgn+p^.gene[t];

  mark:=random(totgn);

  actgn:=0;
  for t:=1 to 6 do begin
    if mark<p^.gene[t] then begin
      actgn:=t;
      break;
    end;
    mark:=mark-p^.gene[t];
  end;

  if (actgn<1) or (actgn>6) then
    evolve.stat.caption:='Gene activated is out of range!';

  {move bug to new location}
  with p^ do
    case actgn of
      1 : begin  {forward}
            xpos:=xpos+xdir[dir];
            ypos:=ypos+ydir[dir];
          end;

      2 : begin   {backward}
            xpos:=xpos-xdir[dir];
            ypos:=ypos-ydir[dir];
          end;

      3 : dir:=fixdir(dir-1);
      4 : dir:=fixdir(dir+1);
      5 : dir:=fixdir(dir-3);
      6 : dir:=fixdir(dir+3);
    end;

    loct(p);
  {Weights are as follows:
    1 : tendency to move forward
    2 : tendency to move backward
    3 : tendency to turn left 1 notch
    4 : tendency to turn right 1 notch
    5 : tendency to turn left 2 notches
    6 : tendency to turn right 2 notches
    3 notches are 180 degrees, there are 6 in all
    1 notch = 60 }

  {Determine if there is food in the new location}
  with p^ do
    health:=health+findfood(xpos,ypos)*settings.udfoodval.position;

  {draw bug}
  x:=p^.xpos;
  y:=p^.ypos;
  evolve.world.canvas.pen.color:=clBlue;
  evolve.world.canvas.ellipse(x,y,x+5,y+5);

end;

procedure TEvolve.clockTimer(Sender: TObject);
var
  t : integer;
  n : pabug;
begin
  worldtime:=worldtime+1;
  for t:=1 to settings.udDPT.position do
    evolve.world.canvas.pixels[random(wd),random(ht)]:=clBlack;

  for t:=0 to bugs.count-1 do
    tick(bugs[t]);

  t:=0;
  while t<bugs.count do begin
    n:=bugs[t];
    n^.health:=n^.health-1;

    if n^.health>settings.udsplitat.position then
      mitosis(n);

    if n^.health<=0 then
      diebug(t)
    else
      t:=t+1;
  end;

  world.repaint;
  evolve.countstat.caption:=inttostr(bugs.count)+' bugs';
  evolve.timeshow.caption:=convtime(worldtime);
  application.title:='Evolve - '+inttostr(bugs.count)+' - '+convtime(worldtime);
  if bugs.count=0 then begin
    stat.caption:='All the bugs have died. The world is paused.';
    clock.enabled:=false;
    application.title:='Evolve - stopped';
    wlog('All bugs have died - program stopped.')
  end;
end;

procedure TEvolve.Exit1Click(Sender: TObject);
begin
  application.terminate;
end;

function bugnfo(pb : pabug) : string;
var
  l : integer;
  a : string;
begin
  with pb^ do begin
    a:='Genes:';
    for l:=1 to 6 do
      a:=a+' '+inttostr(gene[l]);
    a:=a+' Health: '+inttostr(health);
  end;
  bugnfo:=a;
end;

procedure TEvolve.worldMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  t, l : longint;
  p : pabug;
  a : string;
begin
  for t:=0 to bugs.count-1 do begin
    p:=bugs[t];
    with p^ do
     if (x>=xpos) and (x<=xpos+5) and
     (y>=ypos) and (y<=ypos+5) then begin
      stat.caption:=bugnfo(p);
      break;
    end;
  end;
end;

procedure TEvolve.BugSetClick(Sender: TObject);
begin
  if settings.visible=false then begin
    settings.show;
  end else begin
    settings.hide;
  end;
end;

procedure TEvolve.bugstatClick(Sender: TObject);
begin
  if status.visible=false then begin
    status.show;
  end else begin
    status.hide;
  end;
end;

procedure TEvolve.SpeedButton1Click(Sender: TObject);
begin
  if messagedlg('Are you sure you want to reset?',
   mtConfirmation,[mbYes,mbNo],0)=mrYes then begin
    clock.enabled:=false;
    if isinit then
      killall;
  end;
end;

procedure TEvolve.TrayIcon1DblClick(Sender: TObject);
begin
  application.restore;
end;

procedure TEvolve.TaskTray1Click(Sender: TObject);
begin
  tasktray1.checked:=not tasktray1.checked;
  trayicon1.active:=tasktray1.checked;
end;

end.