مژده مژده

    

مژدهAمژده

 

 

 

باسلام

 

ورود غرورآفرین برنامه نویسان عرصه علم

 

وفرهنگ وهنر و...را به شهرنطنز(نگینی درحاشیه کویر)

 

خوش آمدمی گوییم و امیدواریم با حضورشما

 

روح تازه ای به نطنزداده شود.

 

درضمن عیدقربان وشب یلدا را به جناب      

 

آقای خطیری و تمامی دوستان گرامی تبریک

 

عرض می کنیم.

 

(از طرف MRS ها) 

 

b 

{ این هم از دوچرخه }

 

سلام.ضمن عرض تبریک مجدد به مناسبت این روز بزرگ به اطلاع همه ی مردم دانش دوست شهر نطنز و مردم دانش پرور اصفهان میرسانم عید قربان امسال یه فرق بزرگی با سالهای دیگه داره.این همون عیدی بزرگی که قول دادم بهتون بگم:

  امروز حدود ساعت ۱۲ ظهر به وقت گیرینویچ نطنز(قابل توجه اونایی که می گن گیرینویچ تو انگلستانه) زمین این شهر(شهر نطنز) پذیرای قدوم سبز چند تن از دانشمندان معاصر قرن حاضر میباشد.ضمنا" مراسم استقبال در محل میدان بسیج(محل فرود هوا پیما) برگزار می گردد.

                         ستاد استقبال از دانشمندان  

سلام.ضمن عرض تبریک مجدد به مناسبت این روز بزرگ به اطلاع

همه ی مردم دانش دوست شهر نطنز میرسانم عید قربان امسال یه فزق بزرگی با سالهای دیگه داره.این همون عیدی بزرکی که قول دادم بهتون بگم:

  امروز حدود ساعت ۱۲ ظهر به وقت گیرینویچ نطنز(قابل توجه اونایی که می گن گیرینویچ تو انگلستانه) زمین این شهر پذیرای قدوم چند تن از دانشمندان معاصر قرن حاضر میباشد.ضمنا" مراسم استقبال در محل میدان بسیج(محل فرود هوا پیما) برگزار می گردد.

                         ستاد استقبال از دانشمندان  

program 13-2;

uses
  WinCrt;

 type
       student=record
       id:integer;
       name:string[15];
       family:string[15];
       sex:char;
       age:integer;

      end;
 var
     stu:student;

 begin

   stu.id:=32;
   stu.name:='ali';
   stu.family:='ahmadi';
   stu.sex:='m';
   stu.age:=18;
   case  stu.sex of

      'm':write('mr ');
      'f':write('mrs ');
   end;

 write(stu.name,' ',stu.family);

 end.

program 13-9;

uses
  WinCrt;

   const   no=100;
   type
         stu_rec=record
             name:string[10];
             id:integer;
             mark:integer;
         end;
         stu_arr=array [1..no] of stu_rec;
    var
        stu:stu_arr;
        count:integer;
        a:real;
    procedure  readstu(var  s:stu_arr);
    var
       i:integer;
    begin
      i:=1;

      repeat
         write('enter student names,id and mark: ');
         readln(s[i].name,s[i].id,s[i].mark);
         inc(i);
      until  (s[i].id=0) or (i>n);
      count:=i-1;

    end;

    function  writestu(s:stu_arr):real;
      var
        i:integer;
        g:real;
      begin
        g:=0;
        for i:=1 to count do
         begin
           writeln(s[i].id,' ',s[i].mark);
           g:=g+s[i].mark;
         end;
           writestu:=g/count;
      end;
      begin
       readstu(stu);
       a:=writestu(stu);
       writeln('the average mark of student is: ',a);
      end.

 

program 12-3;

uses
  WinCrt;

  var   num,temp:set of byte;
        i,c:integer;

  begin
    writeln('enter numbers');
    readln(i);
    num:=[];
    c:=0;
    while i>-1 do
     begin
      inc(c);
      temp:=[i];
      num:=num+temp;
      readln(i);
     end;
    for i:=0 to 255 do
     if i in num then
      write(i:5);
  end.

program 11-24;

uses
  WinCrt;
  type  na=array [1..100] of string;
  var   i,n:integer;
        name:na;
        procedure  sort(var name:na; n:integer);
         var  i,j:integer;
              temp:string;
        begin
          for i:=1 to n-1 do
           begin
            for j:=i+1 to n do
             if name[i]>name[j] then
              begin
               temp:=name[i];
               name[i]:=name[j];
               name[j]:=temp;
              end;
            end;
        end;

  begin
    writeln('enter number');
    readln(n);
    for i:=1 to n do
     readln(name[i]);
    sort(name,n);
    writeln('the sorted list');
    for i:=1 to n do
     writeln(name[i]);
  end.

program 11-28;

uses
  WinCrt;

  procedure  binary(var list:intarray; element,first,last:integer;var found:boolean);
   var middle:integer;

  begin
    middle:=(first+last) div 2;
    if first>last then
     found:=false
    else if element=list[middle] then
     begin
      found:=true;
      index:=middle;
     end
    else if element       binary(list,element,first,index-1,found)
    else binary(list,element,index+1,found);
  end;

program ex-10-7;
uses
    wincrt;
var st:string;
    i,j,k:integer;
    a:array[1..10,1..10]of char;
begin
writeln('please enter a string:');
readln(st);
j:=1;
for i:=1 to length(st) do
begin
k:=1;
while st[i]<>' ' do
begin
a[k,j]:=st[i];
inc(i);
inc(k);
if i>length(st) then
begin
i:=length(st);

end;
end;
inc(j);
end;
for i:=1 to 10 do
begin
for j:=1 to 10 do
write(a[i,j]:2);
writeln;
end;
end.

 

 

program 11-27;

uses
  WinCrt;

  var  n:integer;
       function  fib(n:integer):integer;
        begin
         if n<=2 then
          fib:=1
         else
           fib:=fib(n-1)+fib(n-2);
        end;

  begin
   writeln('enter number');
   readln(n);
   writeln(fib(n));
  end.

 program 9-25;
 
 uses
  WinCrt;

 var n,i,j:integer;
     a:array [1..3,1..3] of integer;

 
 begin
   writeln('Plz En stair of matrix');
   readln(n);
   writeln('Plz En matrix');
   for i:=1 to n do
    begin
     for j:=1 to n do
      read(a[i,j]);
     writeln;
    end;
   for i:=1 to n do
    for j:=1 to n do
     if (frac(sqrt(abs(a[i,j]))))=0 then
      a[i,j]:=0;
   writeln('the output matix');
   for i:=1 to n do
     begin
      for j:=1 to n do
      write(a[i,j]:5);
     writeln;
    end;
 end.

program 9-26;

uses
  WinCrt;

  var
       i,n:integer;
       sen:array [1..80] of char;

 
 begin

 write('En sentence: ');
   i:=1;
  repeat 
   read(sen[i]);
   inc(i);
  until sen[i]='.';
  writeln;
  dec(i);
  n:=i;
  for i:=1 to n do

   if (ord(sen[i]) > ord('A')) and (ord(sen[i]) < ord('Z')) then
    sen[i]:=chr(ord(sen[i])+(ord('a')-ord('A')));
   for i:=1 to n do
    write(sen[i]);

 end.

program fasle 11_24;

uses
  WinCrt;
  type  na=array [1..100] of string;
  var   i,n:integer;
        name:na;
        procedure  sort(var name:na; n:integer);
         var  i,j:integer;
              temp:string;
        begin
          for i:=1 to n-1 do
           begin
            for j:=i+1 to n do
             if name[i]>name[j] then
              begin
               temp:=name[i];
               name[i]:=name[j];
               name[j]:=temp;
              end;
            end;
        end;

  begin
    writeln('enter number');
    readln(n);
    for i:=1 to n do
     readln(name[i]);
    sort(name,n);
    writeln('the sorted list');
    for i:=1 to n do
     writeln(name[i]);
  end.

program fasl 11_22;

uses
  WinCrt;
  type  a=array [1..100] of integer;
  var   b:a; n:word;
    function  search(b:a; n:word; x:integer):word;
     var i,index:integer; flag:boolean;

     begin
       index:=0;
       flag:=true;
       while (i<=n) and (flag) do
         begin
          if b[i]=x then
           begin
            index:=i;
            flag:=false;
           end;
          inc(i);
         end;
       search:=index;
     end;
  begin
   writeln('Enter number');
   readln(n);
   for i:=1 to n do
    readln(x);
   if search(b,n,x)=0 then
    writeln('not found');
   else writeln(search(b,n,x));
  end.

program fasle 11_23;

uses
  WinCrt;
  type p=array [1..100] of integer;
  var  prime:p;
       i,m,n:integer;
       procedure   createprime(var prime:p; var k:integer; n:integer);
        var i,j:integer; flag:boolean;
         begin
          prime[1]:=2;
          prime[2]:=3;
          k:=3;
          flag:=true;
          for i:=4 to n do
           begin
            for j:=2 to (i div 2) do
             if i mod j=0 then
              flag:=false;
             if flag then
              begin
               prime[k]:=i;
               inc(k);
              end;
             flag:=true;
           end;
         end;
   begin
    writeln('Enter number');
    readln(n);
    for i:=1 to 100 do
     prime[i]:=0;
    m:=0;
    createprime(prime,m,n);
    writeln('the prime number befor n');
    for i:=1 to m do
      writeln(prime[i]);
   end.
 

program fasle 11;

uses
  WinCrt;

  var    a,b:integer;

    procedure  change(var x,y:integer);
    var     temp:integer;

    begin
     temp:=x;
     x:=y;
     y:=temp;
    end;
  begin
    readln(a,b);
    change(a,b);
    writeln('a=',a,' b=',b);
  end.

program fasle 11_14;
uses
  WinCrt;

var   k:integer;

   procedure  add(j:integer);
    var  i:integer;

     procedure  print(i:integer);
      begin
        writeln;
        writeln(i,j);
      end;
    begin
     i:=j+10;
     print(i);
    end;
begin
  writeln;
  write('enter number');
  readln(k);
  add(k);
end.

progrram fasle 11_17;

uses
  WinCrt;

  var    n:integer;

     function   fact(m:integer):longint;
     var  p,i:integer;

        begin
          p:=1;
          for i:=2 to m do
           p:=p*i;
          fact:=p;
        end;
  begin
   write('Enter a integer number=');
   readln(n);
   writeln('factorial ',n,'  is = ',fact(n));
  end.

 

                                   

 شب یلدا شب پیوند با سنتها .....

****8****

uses wincrt;
var
num:array [1..50] of integer;
flag:boolean;
n,i,j:integer;
begin
writeln('plz inter number of data');
readln(n);
writeln('plz inter your data');
for i:=1 to n do
read(num[i]);
flag:=true;j:=2;
for i:=1 to n do
begin
while j<=(num[i] div 2) do
begin
if (num[i] mod j)=0 then
flag:=false;
inc(j);
end;
if flag=true then
num[i]:=0;
end;{end of for}
for i:=1 to n do
write (num[i]:3);
end.

___________________

uses wincrt;
var
j,i,r:integer;
n:longint;
a:array [1..20] of integer;
begin
writeln('pleas inter number');
readln(n);
i:=0;
while n>0 do
begin
r:=n mod 10;
inc(i);
a[i]:=r;
n:=n div 10;
end;
for j:=i downto 1 do
if a[j]>0 then
write(a[j]);
end.

_________________

uses wincrt;
var
i,j,sum:integer;
a:array [1..5,1..5] of integer;
begin
writeln('please inter matrix');
writeln;
for i:= 1 to 5 do
  for j:= 1 to 5 do
read(a[i,j]);
sum:=0;
writeln;
for i:=1 to 5 do
begin
  for j:= 1 to 5 do
begin
write(a[i,j]:4);
sum:=sum+a[i,j];
end;
writeln(sum:5);
sum:=0;
end;{end of for}
writeln;
for j:= 1 to 5 do
begin
  for i:= 1 to 5 do
sum:=sum+a[i,j];
write(sum:4);
sum:=0;
end;{end of for}
end.

________________

uses wincrt;
var
n,temp1,temp,i,k,j:integer;
a:array [1..10,1..10] of integer;
begin
writeln('pleas inter number of data');
readln(n);
writeln('pleas inter matrix');
for i:=1 to n do
 for j:=1 to n do
 read(a[i,j]);
 writeln;
for i:= 1 to n do
begin
  for j:= 1 to n do
write(a[i,j]:3);
writeln;
end;
writeln('***********************');
for k:= 1 to n-1 do
for i:= 1 to n do
  for j:=1 to n-1 do
if a[i,j]>a[i,j+1] then
begin
temp:=a[i,j];
a[i,j]:=a[i,j+1];
a[i,j+1]:=temp;
end;
for k:= 1 to n-1 do
for j:= 1 to n do
  for i:=1 to n-1 do
if a[i,j]>a[i+1,j] then
begin
temp1:=a[i,j];
a[i,j]:=a[i+1,j];
a[i+1,j]:=temp1;
end;
for i:=1 to n do
begin
  for j:= 1 to n do
write(a[i,j]:3);
writeln;
end;
end.

_________________

uses wincrt;
var
a:array [1..200] of integer;
b:array [1..50] of integer;
i,j,min,index:integer;
begin
writeln('pleas inter first data');
for i:= 1 to 150 do
read(a[i]);
for i:=1 to 149 do
begin
min:=a[i];
index:=i;
for j:= i+1 to 150 do
if a[j]begin
min:=a[j];
index:=j;
end;
a[index]:=a[i];
a[i]:=min;
end;
writeln('please inter second data');
for i:=1 to 50 do
read(b[i]);
for i:= 151 to 200 do
a[i]:=b[i-150];
for i:=1 to 200 do
write(a[i]:3);
end.

سلام به همگی. این عید بزرگ را به همه دوستان مخصوصا" آقای خطیری تبریک می گم.به نظر شما چرا دانشجویان محترم دیگه فعال نیستند نکنه ........................

یا شاید...............................................

ولی به نظر من...................................

اما فکر می کنم..................................

نظر شما چیه؟؟؟؟؟

البته با اسم واقعی نظر بدید

من اناری را می کنم دانه

:به خود می گویم

 کاشکی این مردم -

-دانه های دلشان پیدا بود

 

سهراب سپهری

 

 

 

یلدایتان مبارک

و

شادمانیهایتان به بلندای یلدا باد

شب يلدا يا شب چله

ايرانيان قديم شادي و نشاط را از موهبت هاي خدايي و غم و اندوه و تيره دلي را از پديده هاي اهريمني

مي پنداشتند. مراسم نوروز، جشن مهرگان، جشن سده، چهارشنبه سوري و شب يلدا و سنت هاي  ديگر در

واقع بيانگر اين حقيقت است كه ايرانيان پس از رهايي از بيدادگري و ستم به شكرانه بازيافتن آزادي، جشن

 برپا مي ساختند و پيروزي نيكي بر بدي و روشنايي بر تاريكي و داد بر ستم را گرامي مي داشتند.

 

عید سعید قربان و شب یلدا براقای خطیری و تمامی هم کلاسیهای خوبم مبارک باد.

قابل توجه دانشجویان عزیز

در صورت تمایل به همکاری در زمینه جمع آوری اطلاعات در هر

 زمینه ای که مربوط به کامپیوتر سخت افزارنرم افزار و هر موضوعی

 که مربوط  به فن آوری اطلاعات می باشد و حتی آموزش الکترونیکی

 ،خواهشمند است در قسمت نظرات زمینه فعالیت خود را مشخص کرده

 تا در قسمت موضوع آن را ایجاد کرده،تا بتوانیم در کنار یکدیگر سطح

 علمی واطلاعات فنی خود را ارتقا دهیم.منتظر نظرات شما عزیزان می

 باشم

حافظه‌ي فلش ‌USB با سطح آيينه‌يي عرضه شد

يك حافظه‌ي فلش با سطح آيينه‌يي و چهار گيگابايت ظرفيت از سوي يك شركت آسيايي عرضه شد.

شركت كره‌ي جنوبي TwinMos به منظور جذب خريداران، ‌حافظه فلش Mobile Disk p1 خود را با يك

 سطح آيينه‌يي و شش چراغ LED رنگي چشمك زن عرضه كرده است.

اين حافظه از انتقال داده‌ي پرسرعت USB.2.D و سيستم‌هاي عامل ويندوز 2000، اكس پي، ويستا و

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

اين فلش همچنين به‌جاي داشتن سرپوشي كه ممكن به راحتي گم شود داراي اتصال USB كشويي

است.

 

تبديل voice mail به متن ممکن شد

شرکت Alltel Wireless با همکاري SpinVox دست به ارائه سرويس جديدي موسوم به Voice2TXT زده

که پيام هاي الکترونيک صوتي يا voice mail را به متن مبدل مي کند.

به گزارش بخش خبر شبكه فن آوري اطلاعات ايران، از خبرگزاری سلام، اين سرويس که براي اولين بار

ارائه مي شود از طريق تلفن همراه و در قالب پيام هاي کوتاه -sms - نيزدر دسترس است.

کاهش مدت زمان مورد نياز براي مطالعه پيامهاي صوتي اصلي ترين دليل ارائه اين سرويس اعلام شده

است.

فايل هاي صوتي تبديل شده به متن مجددا قابل تبديل به فايل صوتي هستند. هزينه استفاده از اين

خدمات به ازاي 20 پيام در ماه 4.5 دلار است.

            قابل توجه تمام دانشجویان

با توجه به اعتراض بعضی دانشجویان به قسمت نظرات 

اگر مطلب نامناسبی نوشته شود برای همگان قسمت

نظرات غیر فعال میگردد

 

program convert ;
  type
     charset=set of char;
   var
      letters:charset;
      cha1:char;
      {****************************}
      procedure readset(var letters:charset;var ch1:char);
        const sential='.';
        var
          ch:char;
        begin
        letters:=[];
        writeln('................................');
        write('enter chars and for ending enter <',sential,'>');
        readln(ch);
        while ch <>sential do
        begin
           ch:=Upcase(ch);
           if ch in ['A'..'Z'] then
             letters:=letters+[ch];
             ch1:=ch;
             readln(ch);
             end;
             end;
             {********************************************************}
             procedure printest(letter:charset;ch1:char);

             var
             ch:char;
             begin
                writeln('set={');
                for ch:='A' to'Z'do
                   if ch in letters then
                   if ch<>ch1 then
                     write(ch,',')
                     else
                        write(ch);
                       write('}');
                       readln;
                       end;
                       {**************************************************}
                      begin
                         readset(letterS,ch1);
                         printset(letters,ch1);
                      end.

program merg_array;
 uses
  wincrt;
 const
 dim=100;
 type
   in_array=array[1..dim]of string[20];
   out_array=array[1..2*dim]of string[20];
var
  a,b:in_array;
  c:out_array;
  n1,n2,i:integer;
 procedure merge(n1,n2:integer;a,b:in_array;varc:out_array);
 var
    i,j,k,r:integer;
    flag:boolean;
   begin
     k:=n1;
     for i:=1 to n1 do
     c[i]:=a[i];
     for i:=1 to n1 do
     begin
     j:=1;
     flag:=true;
     while(j<=n1+n2)and(flag=true) do
       begin
          if(b[i]>c[i])and(b[i]             begin
                for r:=k downto j+1 do
                   c[r+1]:=c[r];
                   c[j+1]:=b[i];
                   k:=k+1;
                   flag:=false;
               end;
               j:=j+1;
           end;
          end;
         end;
         {************************************************************}
      begin   
         writeln;
         writeln('please enter dimension of first array:');
           readln(n1);
         writeln('pleas enter dimonesion of second array:');
           readln(n2);
         writeln('please enter first array:');
         for i:=1 to n1 do
           readln(a[i]);
         writeln('please enter second array:');
         for i:=1 to n2 do
           readln(b[i]);
         merge(n1,n2,a,b,c);
         writeln('merged array:');
         for i:=1 to (n1+n2) do
           writeln(c[i]);
       end.
       

program 13_9;

uses
  WinCrt;

   const   no=100;
   type
         stu_rec=record
             name:string[10];
             id:integer;
             mark:integer;
         end;
         stu_arr=array [1..no] of stu_rec;
    var
        stu:stu_arr;
        count:integer;
        a:real;
    procedure  readstu(var  s:stu_arr);
    var
       i:integer;
    begin
      i:=1;

      repeat
         write('enter student names,id and mark: ');
         readln(s[i].name,s[i].id,s[i].mark);
         inc(i);
      until  (s[i].id=0) or (i>n);
      count:=i-1;

    end;

    function  writestu(s:stu_arr):real;
      var
        i:integer;
        g:real;
      begin
        g:=0;
        for i:=1 to count do
         begin
           writeln(s[i].id,' ',s[i].mark);
           g:=g+s[i].mark;
         end;
           writestu:=g/count;
      end;
      begin
       readstu(stu);
       a:=writestu(stu);
       writeln('the average mark of student is: ',a);
      end.

 

program 13_7;

uses
  WinCrt;

const
      no=4;

  type
      book_type=record
        name:string;
        id:integer;
  end;
  book_arr=array [1..no] of book_type;

  var
       book:book_arr;
       i:integer;
  begin
     for i:=1 to no do
       with book[i] do
          readln(name,id);
     for i:=1 to no do
       writeln(i,':',book[i].name,' ',book[i].id);
  end.

program 13_1;

uses
  WinCrt;

type
     numbers = record
       a,b,c:integer;
       x,y,z:real;
      end;
 var   num:numbers;
 begin
   num.a:=2;
   num.b:=3;
   num.x:=2.5;
   num.y:=3.5;
   num.z:=10;
   write(num.a+num.b+num.y+num.x+num.z:6:3);
 end

program 13_2;

uses
  WinCrt;

 type
       student=record
       id:integer;
       name:string[15];
       family:string[15];
       sex:char;
       age:integer;

      end;
 var
     stu:student;

 begin

   stu.id:=32;
   stu.name:='ali';
   stu.family:='ahmadi';
   stu.sex:='m';
   stu.age:=18;
   case  stu.sex of

      'm':write('mr ');
      'f':write('mrs ');
   end;

 write(stu.name,' ',stu.family);

 end.

program 13_8;

uses
  WinCrt;

   const  no=30;

type
       stu_rec=record
         name:string[15];
         id:integer;
         age:record
           day:integer;
           month:integer;
         end;

        end;
        stu_arr=array [1..no] of stu_rec;
 var
    stu:stu_rec;
    procedure readstu(var  s:stu_rec);
     var
         i:integer;
    begin
      for i:=1 to no do
        readln(s[i].name,s[i].id,s[i].age.day,s[i].age.month,s[i].age.year);
    end;
    procedure  writestu(s:stu_rec)
     var
         i:integer;
    begin
     for i:=1 to no do
        writeln(s[i].name,' ',s[i].id,' ',s[i].age.day,' ',s[i].age.month,' ',s[i].age.year);
    end;
    begin
      readstu(stu);
      writestu(stu);
    end.

حضور غرور آفرین و پر شور خانم حق شناس به وب بر تمامی دانشجویان مبارک باد

پیداکردن ماکزیمم ومینیمم وتعدادآن

program example1;
uses
     wincrt;
var   MAX,MIN,MAX_COUNT,MIN_COUNT,I,n:iNTEGER;
begin
     writeln('please enter data of number:');
     readln(n);
     writeln('please enter a numbers:');
     readln(number);
     max:=number;
     min:=number;
     max_count:=1;
     min_count:=1;
     for i:=2 to n do
     begin
          readln(number);
      if number>max then
      max:=number;
      max_count:=1;
     
      end;
     else if number=max then
      max:=number;
      max_count:=max_count+1;
      if number      begin
      min:=number;
      min_count:=1;
      end;
      else if min=number then
      min_count:=min_count+1;
      end;
      writeln('max=',max,'max_count=',max_count);
      writeln('min=',min,'min_count=',min_count);
      writeln;
     end.

 

 

قابل توجه دانشجویانی که با اسامی نامتعارف نظر میدهند به

اطلاع میرسانم از این به بعد از  طریق پی گیری ip address ا

سامي آنها اعلام خواهد شد.

دانشجویان گرامی لطفا صورت هر مسئله را بالای هر برنامه ذکر کنید تا

دانشجویان استفاده کنند

program example1;
uses
    wincrt;
var st:string;
    i,j,k:integer;
    a:array[1..10,1..10]of char;
begin
writeln('please enter a string:');
readln(st);
j:=1;
for i:=1 to length(st) do
begin
k:=1;
while st[i]<>' ' do
begin
a[k,j]:=st[i];
inc(i);
inc(k);
if i>length(st) then
begin
i:=length(st);

end;
end;
inc(j);
end;
for i:=1 to 10 do
begin
for j:=1 to 10 do
write(a[i,j]:2);
writeln;
end;
end.

 

Program  Student;
Uses
wincrt;
   Const
      max=50; {max number of student}
   Type
      Names=array[1..max] of string[30];
      Snumber=array[1..max] of longint;
      Marks=array[1..max ,1..3] of Real;
      Average=array[1..max] of Real;
    Var
      NA:Names;        {Name Array}
      SNA:Snumber;     {Student number array}
      MA:Marks;        {Marks and average array}
      Avg:Average;
      i:integer;
 {****************** print max grade ****************}
 procedure Print_Max_Grade(Var SN:Snumber; Var NF:Names; Var MA:Marks; n:integer);
     Var
       M:Array[1..3] of Real;
       k,i,j:integer;
     Begin
       for k:=1 to 3 do
             M[k]:=-1;
       for k:=1 to 3 do
           Begin
             for i:=1 to Max do
                if MA[i,k]>M[k] Then
                  Begin
                    M[k]:=MA[i,k];
                    j:=i;
                  End;
             Writeln('Student that have Max Marks in lesson', k , ':');
             Writeln('St Number:' , SN[j] , 'Name:' :15, NA[j], 'Mark=':10,M[k]:5:2);
            End;
      End;
 {***************** Print Average **************}
 procedure Print_Average(MA:Marks);
   Var
       Sum:Array[1..3] of Real;
       i,j:integer;
   Begin
       for i:=1 to 3 do
            Sum[i]:=0;
       for j:=1 to 3 do
          for i:=1 to Max do
              Sum[j]:=Sum[j] + MA[i+j];
       for i:=1 to 3 do
       Writeln('The average of Lesson' ,i, 'is' , Sum[i]/Max:5:2);
 {***************Print Sorted Average**************}
 procedure Print_Sorted Average(SNA:Snumber; NA:Names; MA:Marks; Var Avg:Average);
    Var
        TempS:string [30];
        TempSN:longint;
        TempM,Sum:real;
        k,i,j:integer;
    Begin
        for i:=1 to Max do
            Begin
               Sum:=0;
               for j:=1 to 3 do
                  Sum:=Sum+MA[i,j];
                  Avg[i]:=Sum/3;
            End;
         for i:=1 to Max do
            for j:=1 to Max-i do
                 if Avg[j] . Avg[j+1] Then
                    Begin
                       TempM:=Avg[j];
                       Avg[j]:=Avg[j+1];
                       Avg[j+1]:=TempM;
                       TempSN:=SNA[j];
                       SNA[j]:=SNA[j+1];
                       SNA[j+1]:=TempSN;
                       TempS:=NA[j];
                       NA[j]:=NA[j+1];
                       NA[j+1]:=TempS;
                       for k:=1 to 3 do
                           begin
                              TempM:=MA[j,k];
                              MA[j,k]:=MA[j+1,k];
                              MA[j+1,k]:=TempM;
                           End;
                    End;
         Writeln('Names of student Sorted with Average');
         for i:=1 to Max do
          Writeln(NA[i] , Avg[i]:10:2);
   End;
{***********Print Nearest Average**********}
Procedure print_Nearest_Average(NA:Names; MA:Marks; Var Avg:Average);
   Var
      Temp,Sum,Aver:Real;
      i,j,Index:integer;
   Begin
      sum:=0;
      for i:=1 to Max do
           Sum:=Sum+Avg[i];
           Aver:=Sum/Max;
             Temp:=20;
           for i:=1 to Max do
             if  (abs(Aver-Avg[i]))                 Begin
                     Temp:=abs(Aver-Avg[i]);
                       Index:=i;
                 End;
       Writeln('Name:' ,NA[Index], 'Average:' ,Aver, 'Nearest Average:' ,Avg[Index]);
   End;
 {************Print Histogram*************}
 procedure prinit_Histogram(Ma:Marks; Var Avg:Average);
     var
          i,j:integer;
          NMR:Array[1..3 of integer;
     Begin
          NMR[1]:=0;  NMR[2]:=2; NMR[3]:=0;
          for i:=1 to Max do
               if(Avg[i]>=0)AND(AVg[i]<9) Then
                 NMR[1]:=NMR[1]+1
               else if(Avg[i]>=9)AND(avg[i]<15)Then
                 NMR[2]:=NMR{2]+1
               else if(Avg[i]>=15)AND(Avg[i]<20) Then
                 NMR[3]:=NMR[3]+1;
           Writeln('The histogram:');
             Writeln('Range 1:(0-9):');
           for i:=1 to NMR[1] do
                  Write('*');
              Writeln;
              Writeln('Range 2:(9-15):');
           for i:=1 to NMR[2] do
                  Write('*');
               Writeln;
               Writeln('range 3:(15-20):');
           for i:=1 to NMR[3] do
              write('*');
              Writeln;
     End;
{*****************Main program***************}
   Begin
        for i:=1 to Max do
           Begin
                Write('student' ,i, ':please enter student Number:');
                Readln(SNA[i]);
                Write('Please enter Name:');
                Readln(NA[i]);
                Write('Please enter Mark1:');
                Readln(MA[i,1]);
                Write('Please enter Mark2:');
                Readln(MA[i,2]);
                Write('please enter Mark3:');
                Readln(MA[i,3]);
           End;
        print_Max_grade(SNA, NA, Ma, Max);
        print_Average(MA);
        prinr_Sorted_Average(SNA, NA, MA, Avg);
        print_Nearest_Average(NA, MA, Avg);
        Print_Histogram(Ma, AVg);
   End.

              
               

program ss_student;
uses
wincrt;
const
max=100;
type
names_family=array[1..max,1..2]of string[20];
snumber=array[1..max]of longint;
var
nfa:names_family;
sna:snumber;
i:integer;
n,searchsn:integer;
ch:char;
{*************************search procedure****************************}
procedure search (ssn:longint;var sn:snumber;VAR NF :NAMES_family;n:integer);
var
i:integer;
find:integer;
begin
find:=-1;
for i:=1 to n do
    begin
    if (sn[i]=ssn)then
      begin
      find:=i;
 
      end;
    end;
  if find=-1 then
  writeln('student with',ssn,'notfound')
else
  begin
     writeln('studet with',ssn,'finded:');
     writeln('name:',nf[find,1],'family:':20,nf[find,2]);
     end;
   END;
  {******************exchange procedure:sub procedure for sort procedure ****************}

  var
      temps:string[20];
      tempsn:longint;
   begin
     TEMPSN:=SN[I];
   sn[i]:=sn[j];
   sn[j]:=tempsn;
   temps:=nf[i,1];
   nf[i,1]:=nf[j,1];
   nf[j,1]:=temps;
   temps:=nf[i,2];
   nf[i,2]:=nf[j'2];
   nf[j,2]:=temps;
 end;
 {******************************sort procedure ****************************}

  procedure exchange (var sn:snumber;var nf:names_family;n:integer);
  var
     i,j:integer;
    begin
     for i:=1 to n do
     for j:=1 to n-i do
        if sn[j]>sn[j+1] then
        exchange(j,j+1,sn,nf);
    end;
  {******************************main program****************************}
  begin
  for i:=1 to max do
  begin
      write('input number of student',i,':');
      readln(sna[i]);
      write('input name:');
      readln(nfa[i,1]);
      writr('inpute family:');
      readln(nfa[i,2]);
 end;
sort(sna,nfa,max);
writeln('student number':16,'name':20,'family':20);
fori:=1 to max do
writeln(i,sna[i]:14,nfA[I,1]:20,nfa[i,2]:20);
repeat
write('inpute one student number for search in list:');
readln(searchsn,sna nfa,max);
write('do you want search again(y/n)?');
readln(ch);
until(ch='n')or (ch='n');
end.

Program welcome;
uses
wincrt;
   Type
       Intset=set of Byte;
   Var
       Number:Intset;
       N:Integer;
{**********************************************}
  Procedure Emptyset (Var Number:Intset);
    Var
       Num:Integer;
         Begin
              For Num:=0 to 255 do
                if Num in Number then
                  Number:=Number-[Num];
         end;
{**********************************************}
  Procedure Readset  (Var Number:Intset;  Var N:Integer);
      Const
           Sential=0;
      Var
           Num,Sum:Integer;
      Begin
           Writeln('******************************');
           Write('Please enter members of set:');
                Number:=[ ];
                Sum:=0;
                Read(Num);
                While Num <> -1 do
                     Begin
                         if Num in [0..255] Then
                           Begin
                                Number:=Number + [Num];
                                Sum:= Num + Sum;
                           End;
                         if Num > N Then
                             N:=Num;
                           Read(Num);
                     End;
                     Writeln;
                     Writeln('Sum=' ,Sum);
                     Write;
       End;
{****************************************************}
  Procedure Printset (Number:Intset;  N:Integer);
        Var
           Num:Integer;
        Begin
           Write('set= { ');
           for Num:=0 to 255 do
               if Num in Number Then
                 If Num <> N Then
                 Write (Num, ',')
                 else
                 Write(Num);
           write (' } ');
        end;
{****************************************}
Begin
     N:=0;
     Writeln;
     Readset ( Number,N );
     Write ('Primary');
     Printset(Number,N);
     Writeln;
     Write ('Final');
     Emptyset(Number);
     Printset(Number,N);
End.

program procedure;
uses
wincrt;
const
top=100;
type
tname=array[1..top]of string[15];
tfamily=array[1..top]of string[20];
tsalarybase=array[1..top]of real;
texp=array[1..top]of integer;
var
name:tname;
family:tfamily;
salarybase:tsalarybase;
exp:texp;
control:char;
i,count:integer;
salary:real;
procedure sort(var n:tname;var f:tfamily;var sb:tsalarybase;var expr:texp;max:integer);
var
  j,k:integer;
  tempn:string[15];
  tempf:string[20];
  tempsb:real;
  tempexp:integer;
 begin
    for j:=1 to (max-1)do
    begin
      for k:=(j+1)to max do
      begin
       if((f[j]>f[k])or((f[j]=f[k])and(n[j]>n[k])))then
        begin
         tempn:=n[k];tempf:=f[k];tempsb:=sb[k];tempexp:=expr[k];
         n[k]:=n[j];f[k]:=f[j];sb[k]:=sb[j];expr[k]:=expr[j];
         n[j]:=tempn;f[j]:=tempf;sb[j]:=tempsb;expr[j]:=tempexp;
      end;
     end;
    end;
   end;
  {*************************************************************}
  function salarypay(s:real):real;
  begin
       if((s>=0)and(s<=1700000))then
         salarypay:=s
         else if ((s>1700000)and(s<=2000000))then
          salarypay:=(s-(s*0.1))
          else if ((s>2000000)and(s<=4000000))then
          salarypay:=(s-(s*0.15))
          else if ((s>4000000)and(s<=6000000))then
          salarypay:=(s-(s*0.2))
          else
            salarypay:=(s-(s*0.5))
            end;
  {*************************************************************}
  begin
  for i:=1 to top do
   begin
    write('please enter',i,'th employee name>');
    readln(name[i]);
    write('pleaseenter',i,'th employee family>');
    readln(family[i]);
    write('please enter',i,'th employee experience>');
    readln(exp[i]);
    write('please enter',i,'th employee salarybase>');
    readln(salarybase[i]);
   
    end;
    sort(name,family,salarybase,exp,top);
    for i:=1 to top do
      begin
       case exp[i] of
         0,1:salary:=salarybase[i]+(salarybase[i]*0.05);
         2,3,4:salary:=salarybase[i]+(salarybase[i]*0.1);
         5,6:salary:=salarybase[i]+(salarybase[i]*0.2);
         7,8,9:salary:=salarybase[i]+(salarybase[i]*0.3);
       else
         salary:=salarybase[i]+(salarybase[i]*0.5);
       end;
       write(family[i]:20);
       write(name[i]:15);
       writeln('   salarypay=(' ,salarypay(salary):10,2,')');
       end;
 end.

سلام.

1_ از خانم زمانی تشکر می کنم بابت اصلاحاتی که تا کنون برای کامپیوتری ها انجام دادن البته بگذریم که بعضی ها قدر این زحمات را نمی دونند و باعث می شن هم خودشون ضرر کنن هم ما.

2_این صحبتشون را تأ یید می کنم که اگه همه ی ما متحد باشیم و فکرمون اصلاح دانشگاه باشه و صرفا" به فکر پاس کردن دروس ونهایتا" گرفتن یک مهندسی صوری نباشیم کارها بهتر و سریعتر پیش می ره.

3_از آقای خطیری هم به خاطر زحماتی که کشیدن تا این محیط را برای ارائه ی کارهای دانشجو ها و تبادل نظرشون آماده کنند تشکر می کنم.

program ex_10_7;
uses
    wincrt;
var st:string;
    i,j,k:integer;
    a:array[1..10,1..10]of char;
begin
writeln('please enter a string:');
readln(st);
j:=1;
for i:=1 to length(st) do
begin
k:=1;
while st[i]<>' ' do
begin
a[k,j]:=st[i];
inc(i);
inc(k);
if i>length(st) then
begin
i:=length(st);

end;
end;
inc(j);
end;
for i:=1 to 10 do
begin
for j:=1 to 10 do
write(a[i,j]:2);
writeln;
end;
end.

 

نمونه اي از فعاليتهاي دانشجويان نطنز در دهه 50 خداييش انده امكانات بوده الان دانشگاه رو نگاه نكنيد عظمتي داشته واسه خودش....................

6-1

uses wincrt;
var
i,j:integer;
begin
writeln('please inter two number');
read(i,j);
i:=i+j;
j:=i-j;
i:=i-j;
writeln('i=',i,'j=':10,j);
end.

6-2

uses wincrt;
var
temp,first,second,third:integer;
begin
writeln('please inter 3 number');
readln(first,second,third);
temp:=0;
temp:=first;
first:=second;
second:=third;
third:=temp;
writeln;
writeln('first=',first,'second=':10,second,'third=':10,third);
end.

6-3

 

uses wincrt;
var
f,c:real;
begin
writeln('pleas inter fahrenheit degree');
readln(f);
c:=(f-32)/1.8;
writeln(c:3:2,'centigrade degree');
end.

6-4

uses wincrt;
var
id:string;price,tax,liability:real;
begin
writeln('please inter your id');
readln(id);
writeln('please inter price');
readln(price);
writeln('please inter tax');
readln(tax);
liability:=price*tax/100;
writeln('id =':42,id);
writeln('price=':43,price:4:1);
writeln('tax=':42,tax:2:2);
writeln('liability=':43,liability:5:3);
end.

6-5

uses wincrt;
var
m:integer;
sum:real;
begin
writeln('please inter number');
readln(m);
sum:=((m+1)/2)*m;
writeln('The sum is=',sum:3:2);
end.

6-6

uses wincrt;
var
pg,mg,average:real;pu,mu:integer;id:string;
begin
writeln('please inter collegian id');
readln(id);
writeln('please inter pascal grade and number of unit');
readln(pg,pu);
writeln('pleas inter math grade and number of unit');
readln(mg,mu);
average:=(pg*pu+mg*mu)/(pu+mu);
writeln('collegian id :':47,id);
writeln;
writeln('name    grade   unit':50);
writeln;
writeln('pascal':36,pg:8:2,pu:5);
writeln;
writeln('math':34,mg:10:2,mu:5);
writeln;
writeln('average:':44,average:2:2);
end.

 

 

program merg_array;
 uses
  wincrt;
 const
 dim=100;
 type
   in_array=array[1..dim]of string[20];
   out_array=array[1..2*dim]of string[20];
var
  a,b:in_array;
  c:out_array;
  n1,n2,i:integer;
 procedure merge(n1,n2:integer;a,b:in_array;varc:out_array);
 var
    i,j,k,r:integer;
    flag:boolean;
   begin
     k:=n1;
     for i:=1 to n1 do
     c[i]:=a[i];
     for i:=1 to n1 do
     begin
     j:=1;
     flag:=true;
     while(j<=n1+n2)and(flag=true) do
       begin
          if(b[i]>c[i])and(b[i]             begin
                for r:=k downto j+1 do
                   c[r+1]:=c[r];
                   c[j+1]:=b[i];
                   k:=k+1;
                   flag:=false;
               end;
               j:=j+1;
           end;
          end;
         end;
         {************************************************************}
      begin   
         writeln;
         writeln('please enter dimension of first array:');
           readln(n1);
         writeln('pleas enter dimonesion of second array:');
           readln(n2);
         writeln('please enter first array:');
         for i:=1 to n1 do
           readln(a[i]);
         writeln('please enter second array:');
         for i:=1 to n2 do
           readln(b[i]);
         merge(n1,n2,a,b,c);
         writeln('merged array:');
         for i:=1 to (n1+n2) do
           writeln(c[i]);
       end.