ParsX.com
پذیرش پروژه از دانشجویی ... تا سازمانی 09376225339
 
   ProfileProfile   Log in to check your private messagesLog in to check your private messages  |  FAQFAQ   SearchSearch   MemberlistMemberlist   UsergroupsUsergroups Log inLog in   RegisterRegister 

برنامه مربع جادويي به زبان پاسكال
Goto page 1, 2  Next
 
Post new topic   Reply to topic    ParsX.com Forum Index -> برنامه نويسي دلفي و پاسكال : Delphi & Pascal Programming
View previous topic :: View next topic  
Author Message
ghasedak404
مهمون يكي دو روزه


Joined: 24 Oct 2005
Posts: 26

PostPosted: Wed Oct 26, 2005 8:49 am    Post subject: برنامه مربع جادويي به زبان پاسكال Reply with quote

كي مي تونه اين برنامه رو برام بنويسه ؟ ممنون مي شم .
Back to top
vahid
بي تو هرگز


Joined: 26 Nov 2004
Posts: 3067
Location: Tehran

PostPosted: Wed Oct 26, 2005 5:28 pm    Post subject: Reply with quote

اين مربع جادويي چي هست ؟
بايد چي كار كنه ؟
با جارو پرواز كنه ؟
انقدري ميدونم كه مثلا سطرها با ستونها جمعشون يكي باشه ؟ بيشتر توضيح بده .
Back to top
arash
مدير بخش سي
مدير بخش سي


Joined: 27 Nov 2004
Posts: 1232
Location: www.parsx.com

PostPosted: Wed Oct 26, 2005 9:25 pm    Post subject: Reply with quote

بگو چیه ؟
چقدر ؟
Smile
Back to top
ghasedak404
مهمون يكي دو روزه


Joined: 24 Oct 2005
Posts: 26

PostPosted: Wed Nov 02, 2005 9:50 am    Post subject: برنامه مربع جادويي Reply with quote

مربع جادويي يك ماتريس n*n است كه اعضاي آن اعداد 3,2,1, ... , n به توان 2 هستند كه هر كدام يك بار تكرار شده اند و مجموع سطرها ، ستون ها و قطرهاي آن يكسان است .
مثلا مربع جادويي 5*5 كه مجموع عناصر سطرها ، ستون ها و قطرهاي آن 65 است :

15 8 1 24 17
16 14 7 5 23
22 20 13 6 4
3 21 19 12 10
9 2 25 18 11
Back to top
vahid
بي تو هرگز


Joined: 26 Nov 2004
Posts: 3067
Location: Tehran

PostPosted: Wed Nov 02, 2005 9:45 pm    Post subject: Reply with quote

اگه خواستي هزينه كني بابتش ميتوني در بخش پروژه بنويسي .
دو روزه يكي پيدا ميشه برات مينويسه Wink
Back to top
ghasedak404
مهمون يكي دو روزه


Joined: 24 Oct 2005
Posts: 26

PostPosted: Thu Nov 03, 2005 10:02 am    Post subject: Reply with quote

سلام
آخه مي دوني چيه ؟
من فكر مي كردم ما اينجا جمع شديم كه به همديگه كمك كنيم و از همديگه چيز ياد بگيريم نه اينكه ....
به هر حال اميدوارم يكي پيدا بشه و مشكل ما رو حل كنه .
Back to top
vahid
بي تو هرگز


Joined: 26 Nov 2004
Posts: 3067
Location: Tehran

PostPosted: Thu Nov 03, 2005 12:53 pm    Post subject: Reply with quote

دقيقا همين چيزيه كه ميخواي .
اما كمك كردن روش داره !
شما شروع كن به نوشتن . هر جا سوال داشتي بپرس . من بشخصه در خدمت هستم .
اما اينكه من بشينم 4 ساعت روي برنامه شما فكر كنم و بنويسم كه نميشه كمك كه ! ميشه ؟
Back to top
vahid
بي تو هرگز


Joined: 26 Nov 2004
Posts: 3067
Location: Tehran

PostPosted: Thu Nov 03, 2005 1:38 pm    Post subject: Reply with quote

program MSMFPC;
const GRAU = 5;     { DIMENSION }
const CGRAU2= ((GRAU)*(GRAU-1)) div 2;
const GRAU2 = GRAU*GRAU;
const NTROCA= (GRAU2*(GRAU2-1)) div 2;
const TOTLIN = (((1+GRAU2)*GRAU2) div 2) div GRAU;

const QueroArq = false;

type TAQUAD = array[1..GRAU2] of word;

type TTROCA = record
               A:word;
               B:word;
             end;

type TATROCA = array[1..NTROCA] of TTROCA;

type TALTROCA = array[1..CGRAU2] of TTROCA;

type TQUAD = object                    { Magic Square Class }
                FOUND:boolean;
                QUAD:TAQUAD;        {square}
                TROCA:TATROCA;
                LTROCA:TALTROCA;
                CICLOS:longint;     {cicles }
                NFOUND:longint;
                WantQuit:boolean;

                constructor Init;
                destructor Done;

                procedure Mostra;   { show }
                procedure Gera(var Q:TAQUAD); {generate a square }
                procedure PTroca(var Q:TAQUAD;N:longint);  {exchange cells}
                procedure Run;
                procedure Try03;
              end;


{ implementation }

  function EvalQuad(Q:TAQUAD):longint;
  var COUNT,COUNT2:word;
      POS,POS2:word;
      SOMLIN,SOMCOL: array[1..GRAU] of longint;
      COLPRIN,COLSEC:longint;
      DIFTOTAL:longint;
  begin
  DIFTOTAL:=0;

  for COUNT:=1 to GRAU do
      begin
      SOMLIN[COUNT]:=0;
      SOMCOL[COUNT]:=0;
      end;

  COLPRIN:=0;
  COLSEC:=0;

  for COUNT:=1 to GRAU do  { soma linhas e colunas }
      for COUNT2:=1 to GRAU do
          begin
          SOMLIN[COUNT2]:=SOMLIN[COUNT2]+Q[GRAU*pred(COUNT )+COUNT2];
          SOMCOL[COUNT2]:=SOMCOL[COUNT2]+Q[GRAU*pred(COUNT2)+COUNT ];
          end;

  POS:=1;
  POS2:=GRAU;

  for COUNT:=1 to GRAU do   {soma diagonais}
      begin
      COLPRIN:=COLPRIN+Q[POS];
      COLSEC:=COLSEC+Q[POS2];
      POS:=POS+succ(GRAU);
      POS2:=POS2+pred(GRAU);
      end;

  DIFTOTAL:=abs(COLPRIN-TOTLIN)+abs(COLSEC-TOTLIN);

  for COUNT:=1 to GRAU do
      DIFTOTAL:=DIFTOTAL+abs(TOTLIN-SOMLIN[COUNT])+
                         abs(TOTLIN-SOMCOL[COUNT]);


  EvalQuad:=DIFTOTAL;
  end; { of procedure }


  constructor TQUAD.Init;
  var COUNT,COUNT2:longint;
      POS:longint;
  begin
  WantQuit:=false;
  Writeln('Output:');
  Writeln('Dimension(Grau):',GRAU);
  Writeln('Cells:(Celulas):',GRAU2);
  Writeln('Level 1(Nivel 1):',NTROCA);
  Writeln('Sum(Total por linha):',TOTLIN);
  CICLOS:=0;
  NFOUND:=0;
  Randomize;
  POS:=0;
  for COUNT:=1 to GRAU2 do  {gera tabela de trocas}
      for COUNT2:=succ(COUNT) to GRAU2 do
          begin
          inc(POS);
          TROCA[POS].A:=COUNT;
          TROCA[POS].B:=COUNT2;
          end;
  Gera(QUAD);
  Writeln('--------------------------------------');

  POS:=0;
  for COUNT:=1 to GRAU do
      for COUNT2:=succ(COUNT) to GRAU do
          begin                       { combinations }
          inc(POS);
          LTROCA[POS].A:=COUNT;
          LTROCA[POS].B:=COUNT2;
          end;

  end;

  destructor TQUAD.Done;
  begin
  end;

  procedure TQUAD.Gera(var Q:TAQUAD);
  var COUNT:longint;
  begin;
  for COUNT:=1 to GRAU2 do
      Q[COUNT]:=COUNT;
  for COUNT:=1 to NTROCA do
      PTROCA(Q,succ(round(random(NTROCA))));
  end;

  procedure TQUAD.Mostra;
  var COUNT,COUNT2:longint;
      POS:longint;
  begin;
  POS:=0;
  for COUNT:=1 to GRAU do
      begin
      for COUNT2:=1 to GRAU do
          begin
          inc(POS);
          Write(QUAD[POS]:4);
          end;
      Writeln;
      end;
  {Application.ProcessMessages;}
  end;

  procedure TQUAD.PTroca(var Q:TAQUAD;N:longint);
  var AUX:word;
  begin;
  AUX:=Q[TROCA[N].A];
  Q[TROCA[N].A]:=Q[TROCA[N].B];
  Q[TROCA[N].B]:=AUX;
  end;

  procedure TQUAD.Try03;
  var USE:TAQUAD;
      OLDEVAL,EVAL:longint;
      COUNT,COUNT3:longint;
      BESTPOS1,BESTEVAL:longint;
      ATUAL1:longint;
      MAX:longint;
      LA:boolean; {local achei}
  begin
  BESTPOS1:=1;
  BESTEVAL:=NTROCA{EvalQuad(QUAD)};
  OLDEVAL:=EvalQuad(QUAD);{BESTEVAL;}
  EVAL:=OLDEVAL;
  USE:=QUAD;
  COUNT:=0;
  LA:=false;
  MAX:=round(NTROCA/1.5);
  while (COUNT<MAX) and not(LA) do
      begin
      inc(COUNT);
      USE:=QUAD;
      ATUAL1:=succ(round(random(NTROCA)));
      PTROCA(USE,ATUAL1);        {troca}
      EVAL:=EvalQuad(USE);
      if EVAL<=BESTEVAL then
         begin
         BESTEVAL:=EVAL;
         BESTPOS1:=ATUAL1;
         end; { of if}

      if EVAL<=OLDEVAL then
         LA:=true;
      end;{ of FOR }

  PTROCA(QUAD,BESTPOS1);
  if Random(100)>8 then
        begin
        {Application.ProcessMessages;}
        {writeln(BESTEVAL);}
        end;

  if BESTEVAL=0 then
     begin
     inc(NFOUND);
     writeln;
     writeln('This is another magic square 4u ghasedak40:',NFOUND);
     MOSTRA;
     Gera(Quad);
     end;
  end;


  procedure TQUAD.Run;
  var Count:longint;
  begin
  Count:=0;
  while not(WantQuit) do
      begin
      Try03;
      end;
  end;


 var MS:TQUAD;  { Magic Square Object }

begin
  MS.Init;
  MS.Run;
  MS.Done;
end.
Back to top
ghasedak404
مهمون يكي دو روزه


Joined: 24 Oct 2005
Posts: 26

PostPosted: Fri Nov 04, 2005 1:24 am    Post subject: Reply with quote

سلام وحيد
قبل از هر چيز به خاطر نوشتن برنامه ازت تشكر مي كنم
. هر چند هنوز تستش نكردم ولي همين كه زحمت كشيدي ازت ممنونم .
سعي مي كنم ازش سر در بيارم . ولي هر جا كه مشكل داشتم سوال مي كنم .
جوابم رو ميدي ؟؟؟؟

باز هم ممنونم .
Back to top
vahid
بي تو هرگز


Joined: 26 Nov 2004
Posts: 3067
Location: Tehran

PostPosted: Fri Nov 04, 2005 11:54 am    Post subject: Reply with quote

هر جا مشكلي داشتي اگه بلد بودم در خدمت هستم .
اين برنامه رو از يكي از تالارهاي orkut گرفتم .
Back to top
ghasedak404
مهمون يكي دو روزه


Joined: 24 Oct 2005
Posts: 26

PostPosted: Sat Nov 05, 2005 1:55 am    Post subject: Reply with quote

سلام
خيلي باهاش ور رفتم . ولي چيز زيادي دستگيرم نشد
به نظرم يه خورده پيچيده هست !!!
راستي تو منطق برنامه رو به دست آوردي ؟ اينكه اعداد چه جوري چيده مي شن ؟
Back to top
vahid
بي تو هرگز


Joined: 26 Nov 2004
Posts: 3067
Location: Tehran

PostPosted: Sat Nov 05, 2005 9:24 pm    Post subject: Reply with quote

من فكر كنم خودشم نفهميده چي نوشته Laughing
Back to top
ghasedak404
مهمون يكي دو روزه


Joined: 24 Oct 2005
Posts: 26

PostPosted: Sun Nov 06, 2005 1:18 am    Post subject: Reply with quote

دارم به همين نتيجه مي رسم .
Back to top
ghasedak404
مهمون يكي دو روزه


Joined: 24 Oct 2005
Posts: 26

PostPosted: Tue Nov 08, 2005 9:59 am    Post subject: Reply with quote

سلام

وحيد جان ، برنامه اي كه شما گذاشتيد رو سايت درست كار نمي كنه .

البته بابت زحمتي كه كشيدي ازت ممنونم .

ولي بالاخره خودم تونستم برنامه رو بنويسم . درست درست هم كار مي كنه
مي ذارمش روي سايت تا همه ازش استفاده كنن .



program msquare;

const
     MAX_SIZE=15;
   var
      square:array[1..MAX_SIZE,1..MAX_SIZE] of integer;

   i,j,row,column,sum:integer;
   count:integer;
   size:integer;
BEGIN
     sum:=0;
     writeln;
     write('Enter the size of the square:');
     readln(size);
     if ((size<1) or (size>MAX_SIZE)) then
         begin
            writeln('Error! size is out of range.');
            readln;
            exit;
            end;
     if not ((size mod 2<>0)) then
        begin
           writeln('Error! size is even.');
           readln;
           exit;
           end;
     for i:=1 to size do
         for j:=1 to size do
          square[i,j]:=0 ;
      square[1,trunc((size+1)/2)]:=1;
     i:=1;
     j:=trunc((size+1)/2);

     for count:=2 to size*size do
         begin
           if (i-1=0) then
               row:=size
             else
               row:=i-1;
           if (j-1=0) then
               column:=size
             else
               column:=j-1;
           if (square[row,column]<>0) then
              i:=i+1
             else
               begin
                 i:=row;
                 if (j-1=0) then
                     j:=size
                   else
                     j:=j-1;
                end;
            square[i,j]:=count;
            end;
            writeln('Magic square of size ',size,': ');
            writeln;
              for i:=1 to size do
                begin
                   for j:=1 to size do
                      write(square[i,j]:4);
                      writeln;
                      writeln;
               end;
               writeln;
                for i:=1 to size do
                 sum:=sum+square[i,1];
                writeln('The sum of any ( row,column and diameter ) is : ',sum);
                writeln;
                write('Press Enter to Exit ...');

            readln;
        end.
Back to top
Etrok
مهمون يكي دو روزه


Joined: 05 Jul 2005
Posts: 1

PostPosted: Wed Nov 09, 2005 11:08 pm    Post subject: Reply with quote

اين برنامه هه كه گذاشتم كار ميكردا ؟
اما خوب ماله شما خيلي واضحتر و بهتر بنظر ميرسه ...
Back to top
Display posts from previous:   
Post new topic   Reply to topic    ParsX.com Forum Index -> برنامه نويسي دلفي و پاسكال : Delphi & Pascal Programming All times are GMT + 3.5 Hours
Goto page 1, 2  Next
Page 1 of 2

 
Jump to:  
You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot vote in polls in this forum