Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Паскаль, Turbo Pascal, PascalABC.NET
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 22.05.2012, 21:33   #1
volha_alina
Пользователь
 
Регистрация: 22.05.2012
Сообщений: 13
По умолчанию Спин-стекольная модель эволюции Шеррингтона-Киркпатрика

Вроде с помощью генетического алгоритма, а смотрю и не понимаю как конкретно это реализовать.......(
Имеется популяция состоящая из k особей. Каждая особь представляет собой информационную последовательность из N символов (спинов), принимающих значение 1 или -1. Надо реализовать спин-стекольную эволюцию для заданного числа поколений для данной популяции.
volha_alina вне форума Ответить с цитированием
Старый 22.05.2012, 21:46   #2
volha_alina
Пользователь
 
Регистрация: 22.05.2012
Сообщений: 13
По умолчанию

Что не так?
Код:
uses crt;
const
	xn=2;	xk=7;	N=10; Pm=0.05;
Type
	pp=array[1..2*N] of string;ff=array[1..2*N] of real;
Var
	NR:byte;

Function Fx(a:string):real;
type bb=array[1..N] of real; ee=array[1..N,1..N] of real;
Var
	i,j,k:byte; x,sum,sum1,sum2,R,N0,m,q,b:real; c:ee; d:bb; code:integer;
Begin
sum:=0;sum1:=0;sum2:=0; m:=4; q:=2;
b:=random(101); b:=b/100;
for i:=1 to N do
for j:=1 to N do begin
for k:=1 to 12 do begin
                  R:=random(101)/100;sum1:=sum1+R;
                  end;
                  N0:=sum1-6;
                  c[i,j]:=m+q*N0;
                 end;
for i:=1 to N do
for j:=1 to N do begin
                 val(a[i],d[i],code);
                 sum2:=c[i,j]*d[i]*d[j];
                 Fx:=exp(-b*((-1/2)*sum2)); 
                 end;
End;

Procedure Form(var a:pp; var b:ff; Gen:byte);
Var
	i,j,k:byte;
Begin
for i:=1 to N do begin
                 a[i]:='';
                 for j:=1 to Gen do begin
                                    k:=random(2);
                                    if k=0 then a[i]:=a[i]+'-1'
                                           else a[i]:=a[i]+'1';
                                    end;
            		 b[i]:=Fx(a[i]);
                 end;
End;

Procedure Out (a:pp; b:ff);
var
	i:byte;
Begin
writeln ('Nomer     Kod       Y');
for i:=1 to N do writeln (i:3,'  ',a[i],'   ',b[i]:4:2);
End;

Procedure Otbor(var a:pp; var b:ff);
Var
	New:pp; Q:ff; i,nom:byte; x,Sum,r1,r2:real;
Begin
Sum:=0;
for i:=1 to NR do Sum:=Sum+b[i];
for i:=1 to NR do Q[i]:=b[i]/Sum;
r1:=0; r2:=Q[1]; nom:=1;
for i:=1 to N do begin
                 x:=random(101); x:=x/100;
                 if (x>=r1) and (x<=r2) then New[i]:=a[nom]
                                        else begin
                                             r1:=r2; r2:=r2+Q[i+1];
                                             nom:=nom+1;
                                             end;
                 end;
for i:=1 to N do begin
                 a[i]:=New[i]; b[i]:=Fx(a[i]);
                 end;
NR:=N;
End;

Procedure Mutacia (var a:pp;var b:ff; Gen:byte);
Var
   i,j:byte; x:real;
Begin
for i:=1 to N do begin
                 for j:=1 to Gen do begin
                                    x:=random(101); x:=x/100;
                                    if x<=Pm then
                                    if a[i,j]='-1' then a[i,j]:='1'
                                                   else a[i,j]:='1';
                                    end;
                 b[i]:=Fx(a[i]);
                 end;
End;

Var
	popul:pp; func:ff; i,P,Gen:byte;
Begin
clrscr; randomize;
write('chislo pokoleniy: '); readln(P);
write('chislo spinov: '); readln(Gen);
Form(popul,func,Gen);
writeln('Nachalnaya populyacia');
Out(popul,func); readln;
for i:=1 to P do begin
                 Otbor(popul,func);
                 Mutacia(popul,func,Gen);
                 end;
writeln('Konechnaya populyacia');
Out(popul,func); readln;
End.
Вложения
Тип файла: doc спин1.doc (96.0 Кб, 12 просмотров)

Последний раз редактировалось volha_alina; 23.05.2012 в 18:03.
volha_alina вне форума Ответить с цитированием
Старый 25.05.2012, 15:24   #3
volha_alina
Пользователь
 
Регистрация: 22.05.2012
Сообщений: 13
По умолчанию

Ошибка Type mismatch. Что я не заметила?

Код:
uses crt;
const
	N=10; Pm=0.05; P=10; Gen=5;
Type
	pp=array[1..2*N,1..Gen] of integer;
        ff=array[1..2*N,1..Gen] of real;
        ee=array[1..N,1..N] of real;
Var
	NR:byte; c:ee;

Function Fx(a:pp):real;
Var
	i,j,k:byte;
        x,sum,sum2,b:real;
Begin
sum:=0; sum2:=0; b:=0.5;
for i:=1 to N do begin
                 for j:=1 to N do begin 
                                  for k:=1 to Gen do begin
                                                  sum2:=c[i,j]*a[k,i]*a[k,j];
                                                     end;
                                  end;
                 end;
{writeln(sum2);}
Fx:=exp(0.5*b*sum2);
End;

Procedure Form(var a:pp; var b:ff);
Var
	i,j,k:byte;
Begin
for i:=1 to N do begin
                 for j:=1 to Gen do begin
                                    k:=random(2);
                                    if k=0 then a[i,j]:=-1
                                           else a[i,j]:=1;
                                    end;
                 b[i]:=Fx(a);
                 end;
End;

Procedure Out (a:pp; b:ff);
var
	j,i:byte;
Begin
writeln ('Nomer   Kod       Y');
for i:=1 to N do begin write (i:2,'   ');
for j:=1 to Gen do begin write (a[i,j]:2{,b[i]:6:2});
                   end;writeln;
                 end;
End;
 

Var
	popul:pp; func:ff; i,j,k:byte; sum1,R,N0,m,q:real;
Begin
clrscr;
randomize;
sum1:=0; m:=6; q:=3;
for i:=1 to N do begin
                for j:=1 to N do begin
                                for k:=1 to 12 do begin
                                                  R:=random(101);
                                                  R:=R/100;
                                                  sum1:=sum1+R;
                                                  end;
                                end;
                end;
N0:=sum1-6;
c[i,j]:=m+q*N0;
Form(popul,func);
writeln('Nachalnaya populyacia');
Out(popul,func);
readln;
End.
volha_alina вне форума Ответить с цитированием
Старый 30.05.2012, 14:42   #4
volha_alina
Пользователь
 
Регистрация: 22.05.2012
Сообщений: 13
По умолчанию Рабочая

Код:
uses crt;
const
	N=10; Pm=0.01; P=50; Gen=5;
Type
	pp=array[1..N,1..Gen] of integer;
        ff=array[1..N] of real;
        ee=array[1..N,1..N] of real;

Procedure Form_c (var a:ee);
Const
     m=6;
     q=1;
Var
   i,j,k:byte;
   R,sum:real;
begin
for i:=1 to N do begin
                 for j:=1 to N do begin
                                  sum:=0;
                                  for k:=1 to 20 do begin
                                                    R:=random(101);
                                                    R:=R/100;
                                                    sum:=sum+R;
                                                    end;
                                  a[i,j]:=m+q*0.774596*(sum-10);
                                  end;
                 end;
end;

Function Fx(a:pp;c1:ee;k:byte):real;
Const
     b=0.5;
Var
	i,j:byte;
        sum,E:real;
Begin
sum:=0;
for i:=1 to Gen do
for j:=1 to Gen do
   sum:=sum+c1[i,j]*a[k,i]*a[k,j];
E:=-0.5*sum;
Fx:=exp(-b*E);
End;

Procedure Form(var a:pp; var b:ff;c1:ee);
Var
	i,j,k:byte;
Begin
for i:=1 to N do begin
                 for j:=1 to Gen do begin
                                    k:=random(2);
                                    if k=0 then a[i,j]:=-1
                                           else a[i,j]:=1;
                                    end;
                 b[i]:=Fx(a,c1,i);
                 end;
End;

Procedure Out (a:pp; b:ff);
var
	j,i:byte;
Begin
writeln ('Nomer   Kod                           Y');
for i:=1 to N do begin
                 write (i:2,'   ');
                 for j:=1 to Gen do if a[i,j]=1 then write('+',a[i,j])
                                      else write (a[i,j]);
                 writeln (b[i]:26:2);
                 end;

End;

Procedure Otbor(var a:pp; var b:ff; c1:ee);
Var
	New:pp;
        Q:ff;
        i,j,nom:byte;
        x,Sum,r1,r2:real;
Begin
Sum:=0;
for i:=1 to N do Sum:=Sum+b[i];
for i:=1 to N do Q[i]:=b[i]/Sum;
for i:=1 to N do begin
                 x:=random(101);
                 x:=x/100;
                 r1:=0; r2:=Q[1]; nom:=1;
                 for j:=1 to N do
                    if (x>=r1) and (x<=r2) then begin
                                                New[i]:=a[nom];
                                                break;
                                                end
                        else begin
                             r1:=r2;
                             r2:=r2+Q[j+1];
                             nom:=nom+1;
                             end;
                 end;
for i:=1 to N do begin
                 a[i]:=New[i];
                 b[i]:=Fx(a,c1,i);
                 end;
End;

Procedure Mutacia (var a:pp;var b:ff; c1:ee);
Var
   i,j:byte; x:real;
Begin
for i:=1 to N do begin
                 for j:=1 to Gen do begin
                                    x:=random(101); x:=x/100;
                                    if x<=Pm then
                                    if a[i,j]=-1 then a[i,j]:=1
                                                   else a[i,j]:=-1;
                                    end;
                 b[i]:=Fx(a,c1,i);
                 end;
End;


Var
   popul:pp;
   func:ff;
   c:ee;
   i:byte;
Begin
clrscr;
randomize;
Form_c(c);
Form(popul,func,c);
writeln('Nachalnaya populyacia');
writeln;
Out(popul,func);
for i:=1 to P do begin
                 Otbor(popul,func,c);
                 Mutacia(popul,func,c);
                 end;
writeln;
writeln('Konechnaya populyacia');
Out(popul,func);
readln;
End.

Последний раз редактировалось volha_alina; 31.05.2012 в 12:12.
volha_alina вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Модель производства. Васильева Зинаида Помощь студентам 1 16.01.2011 19:45
статья - Спин атома кобальта смогли «сфотографировать» Pblog Обсуждение статей 0 23.06.2010 05:13
Модель данных fobass SQL, базы данных 3 19.01.2010 22:09
Даталогическая модель Шульц БД в Delphi 0 27.12.2008 23:44
Реализация модели эволюции клетки. Параллельное программирование на языке с. Заноза Помощь студентам 4 03.04.2008 22:13