Администраторы группы

  • Аватар

Олимпиада по информатике. Готовимся побеждать!

Открытая группа активность: 4 нед., 1 дн. назад

Группа для тех, кто намеревается побеждать на районных и региональных олимпиадах по информатике.
Здесь можно будет найти олимпиадные задания, задачи повышенной сложности, обсудить оптимальные алгоритмы решений
Памятка для участников олимпиады

Сайт Информатикс – регистрирууемся, решаем, продвигаемся в рейтинге

Программирование на Pascal. (записей: 79)

← Форум группы   Все форумы
  • Аватар GQ - 1 мес., 3 нед. назад:
    
    program book1;
    
    uses crt;
    type book=record
    name:string;
    page:word;
    author:string;
    rating:byte;
    price:word;
    end;
    var
    j,q,w,e,r:byte;
    
    procedure okno(q,w,e,r:byte);
    begin
    window(q,w,e,r);
    end;
    procedure create;
    var f:file of book;
    i:byte;
    n:book;
    
    begin assign(f,'book');
    rewrite(f);
    for i:=1 to 5 do
    begin
    writeln('введи название');
    	readln(N.name);
    	writeln('веди кол-во стр');
    	readln(N.page);
    	writeln('введи автора');
    	readln(N.author);
    	writeln('введи цену');
    	readln(N.price);
    	writeln('введи рейтинг');
    	readln(N.rating);
    	write(F,N);
    	end;
     end;
     procedure watch;
     var f:file of book;
     n:book;
     i:byte;
     begin
     assign(f,'book');
     reset(f);
     writeln('выбери книгу');
     readln(i);
     seek(F,i);
     read(f,n);
      writeln('название:');
     writeln(n.name);
      writeln('рейтинг:');
     writeln(n.rating);
      writeln('автор:');
     writeln(n.author);
      writeln('кол-во стр:');
     writeln(n.page);
      writeln('цена:');
     writeln(n.price);
    end;
    procedure redakt;
    var f:file of book;
    n:book;
    k:byte;
    
    begin
    assign(f,'book');
    reset(f);
    writeln('выбери файл');
    readln(k);
    writeln('новое название');
    readln(n.name);
    writeln('новый рейтинг');
    readln(n.rating);
    writeln('новое кол-во ср');
    readln(n.page);
    writeln('новый автор');
    readln(n.author);
    writeln('новая цена');
    readln(n.price);
    seek(F,k);
    write(F,n);
    end;
    
    BEGIN
    repeat
    okno(2,2,60,5);
    writeln('1-создать,2-посмотреть,3-редактировать,4-ничего');
    okno(2,7,30,20);
    readln(e);
    if e=1 then
    begin
     okno(32,7,60,20);
     create;
     end;
    if e=2 then
    begin
    okno(32,7,60,20);
    watch;
    end;
    if e=3 then
    begin
    okno(32,7,60,20);
     redakt;
     end;
    if e=4 then
    begin
     okno(32,7,60,20);
     writeln('пока');
     end;
    until e=4;
    
    END.
    
  • Аватар 永遠の雨 - 1 мес., 1 нед. назад:
    Program N1;
    uses crt;
    type
      mas = array [1..3,1..3] of integer;
    var
      m : mas;
       i,j: byte;
       s,sn,sm,sr,k,i1,i2,i3,i4,i5,i6,i8,i9,i10: integer;
    
       xx: word;
    
    BEGIN
    xx:=0;
    
    	for i1:=0 to 9 do
    	begin
    	 m[1,1]:=i1;
    
    	 for i2:=0 to 9 do
    	  begin
    	  m[1,2]:=i2;
          for i3:=0 to 9 do
    	   begin
    	   m[1,3]:=i3;
           for i4:=0 to 9 do
    	    begin
    	    m[2,1]:=i4;
    	    for i5:=0 to 9 do
    	     begin
    	     m[2,2]:=i5;
    	     for i6:=0 to 9 do
    	     begin
    	     m[2,3]:=i6;
    	     for i8:=0 to 9 do
    	     begin
    	     m[3,1]:=i8;
    	     for i9:=0 to 9 do
    	     begin
    	     m[3,2]:=i9;
    	     for i10:=0 to 9 do
    	     begin
    	     m[3,3]:=i10; 
    
     s:=0; k:=0;
    for i:=1 to 3 do
    	S:=S+M[1,I];
    
    for i:=1 to 3 do
    begin
     sn:=0;
    	for j:=1 to 3 do
    	Sn:=Sn+M[i,j];
    
    	if sn <>s then k:=1;
    	end;
    
    	sm:=0;
    for j:=1 to 3 do
    begin
        sm:=0;
    	for i:=1 to 3 do
    	Sm:=Sm+M[i,j];
    
    	if sm <>s then k:=1;
    end;
    
    sr:=0;
    for i:=1 to 3 do
    	Sr:=Sr+M[i,i];
    	if sr <>s then k:=1;
    
    	sr:=0;
    for i:=1 to 3 do
    	Sr:=Sr+M[i,4-i];
    	if sr <>s then k:=1;
    
    	if k=0 then begin
    
    	writeln ('квадрат магический');
    	xx:=xx+1;
    
    for i:=1 to 3 do    {здесь задаем число столбцов матрицы}
         for j:=1 to 3 do {здесь задаем число строк в столбцах матрицы}
           begin
                  gotoxy (i*3+40,j*1); {команды между begin-end будут повторяться 15 раз}
                  writeln (m [ i, j ]);
    
               end;
    
    end;
    
    	     end;
    	    end;
    	    end;
    	    end;
    	    end;
    	    end;
    	    end;
    	    end;
    	    end;
    
    		writeln ('кол-во магических квадратов=',xx); 
    
    	readln;
    
    end.
    
  • Аватар ◕␣◕ ๖ۣۣۜДøБῥö - 1 мес., 1 нед. назад:
    program kalkylyator;
    uses crt;
    var n:byte;
    l,h:string;
    procedure windows(x1,y1,x2,y2,ct,cb:integer);
    begin
    window(x1,y1,x2,y2);
    textcolor(ct);
    textbackground(cb);
    clrscr;
    end;
    procedure delenie;
    var c,a,b,m:longint;
    begin
    windows(3,3,77,9,4,6);
    writeln('vvedite znacheniya');
    readln(a,b);
    if a>b then
     begin
          c:= a div b;
          m:= a mod b;
      end
    else
    begin
    c:=b div a;
    m:= b mod a
    end;
    writeln('polychennoe znachenie:',c);
    writeln('ostatok:',m)
    end;
    procedure ymnojenie;
      var a,b,c:longint;
         begin
              writeln('vvedite znacheniya');
              readln(a,b);
          c:=a*b;
      writeln('polychennoe znachenie:',c);
    end;
    procedure slojenie;
      var a,b,c:longint;
        begin
          writeln('vvedite znacheniya');
          readln(a,b);
        c:=a+b;
      writeln('polychennoe znachenie:',c);
    end;
    procedure vichitanie;
      var a,b,c:longint;
        begin
          writeln('vvedite znacheniya');
            readln(a,b);
           if a>b then c:=a-b
         else c:=b-a;
      writeln(c);
    end;
    procedure koren;
    var a,b,c:real;
    begin
    writeln('vvedite chislo');
    readln(a);
    b:=sqrt(a);
    writeln('polychennoe znachenie:',b:1:0);
    end;
    procedure rofl;
    var n:byte;
     begin
    repeat
      writeln('1-delit,2-ymnojit,3-slojit,4-vichest,5-koren,6-vihod');
        readln(n);
          if n=1 then delenie;
          if n=2 then ymnojenie;
          if n=3 then slojenie;
          if n=4 then vichitanie;
          if n=5 then koren;
    until n=6;
    end;
    Begin
    writeln('hotite li kalkylyator?');
    readln(l);
    if l=('da') then
    begin
      writeln('1-delit,2-ymnojit,3-slojit,4-vichest,5-koren,6-vihod');
        readln(n);
          if n=1 then delenie;
          if n=2 then ymnojenie;
          if n=3 then slojenie;
          if n=4 then vichitanie;
          if n=5 then koren;
          repeat
    writeln('again?');
          readln(h);
          if h=('da') then
          begin
          writeln('1-delit,2-ymnojit,3-slojit,4-vichest,5-koren,6-vihod');
        readln(n);
          if n=1 then delenie;
          if n=2 then ymnojenie;
          if n=3 then slojenie;
          if n=4 then vichitanie;
          if n=5 then koren;
          end
          else exit;
          until n=42523424;
          writeln('chem vse konchitsya?');
    end;
    
    End.
    
  • Аватар GQ - 1 мес., 1 нед. назад:
    program wwww;
    var
    f,O:file of string;
    g,v,p:word;
    y,l:string;
    procedure watch;
    var
    q:byte;
    begin
    writeln('какой вопрос хотите посмотреть?');
    readln(q);
    
    assign(f,'quastions');
    reset(f);
    seek(f,q);
    read(f,g);
    writeln('вопрос:',g);
    close(f);
    
    assign(f,'1answer');
    reset(f);
    seek(f,q);
    read(f,g);
    writeln('первый ответ:',g);
    close(f);
    
    assign(f,'2answer');
    reset(f);
    seek(f,q);
    read(f,g);
    writeln('второй ответ:',g);
    close(f);
    
    assign(f,'3answer');
    reset(f);
    seek(f,q);
    read(f,g);
    writeln('третий ответ:',g);
    close(f);
    end;
    procedure create;
    var t:byte;
    x:string;
    begin
    assign(f,'quastions');
    reset(f);
    t:=filesize(f);
    seek(f,t);
    writeln('новый вопрос');
    readln(x);
    write(f,x);
    close(f);
    
    assign(f,'1answers');
    reset(f);
    t:=filesize(f);
    seek(f,t);
    writeln('первый ответ');
    readln(x);
    write(f,x);
    close(f);
    
    assign(f,'2answers');
    reset(f);
    t:=filesize(f);
    seek(f,t);
    writeln('второй ответ');
    readln(x);
    write(f,x);
    close(f);
    
    assign(f,'3answers');
    reset(f);
    t:=filesize(f);
    seek(f,t);
    writeln('третий ответ');
    readln(x);
    write(f,x);
    close(f);
    
    end;
    procedure change;
    var t:byte;
    x:string;
    begin
    writeln('какой вопрос изменить');
    readln(t);
    
    assign(f,'quastions');
    reset(f);
    seek(f,t);
    witeln('введи новый вопрос');
    readln(x);
    write(f,x);
    close(f);
    
    assign(f,'1answers');
    reset(f);
    seek(f,t);
    witeln('введи первый ответ');
    readln(x);
    write(f,x);
    close(f);
    
    assign(f,'2answers');
    reset(f);
    seek(f,t);
    witeln('введи второй ответ ');
    readln(x);
    write(f,x);
    close(f);
    
    assign(f,'3answers');
    reset(f);
    seek(f,t);
    witeln('введи третий ответ');
    readln(x);
    write(f,x);
    close(f);
    
    writeln('какой ответ правильный?');
    readln(g);
    
    if g=1 then
    begin
    assign(f,'1answers');
    seek(f,t);
    read(f,y);
    close(f);
    
    assign(f,'correct_answers');
    reset(f);
    seek(f,t);
    write(f,y);
    close(f);
    end;
    
    if g=2 then
    begin
    assign(f,'2answers');
    seek(f,t);
    read(f,y);
    close(f);
    
    assign(f,'correct_answers');
    reset(f);
    seek(f,t);
    write(f,y);
    close(f);
    end;
    if g=3 then
    begin
    assign(f,'3answers');
    seek(f,t);
    read(f,y);
    close(f);
    
    assign(f,'correct_answers');
    reset(f);
    seek(f,t);
    write(f,y);
    close(f);
    end;
    end;
    procedure test;
    var i,e,s:byte;
    k,a,b:string;
    begin
    assign(O,'otveti');
    rewrite(O);
    assign(f,'quastions');
    reset(f);
    e:filesize(f);
    close(f);
    for i:=1 to e do
    begin
    assign (f,'questions');
    reset(f);
    read(f,y);
    writeln(y);
    close(f);
    
    assign (f,'1answers');
    reset(f);
    read(f,y);
    writeln('первый ответ;'y);
    close(f);
    
    assign (f,'2answers');
    reset(f);
    read(f,y);
    writeln('второй ответ;'y);
    close(f);
    
    assign (f,'3answers');
    reset(f);
    read(f,y);
    writeln('третий ответ;'y);
    close(f);
    
    writeln('какой ответ?');
    readln(s);
    
    if s=1 then
    begin
    assign(f,'1answers');
    reset(f);
    seek(f,i);
    read(f,k);
    close(f);
    end;
    
    if s=2 then
    begin
    assign(f,'2answers');
    reset(f);
    seek(f,i);
    read(f,k);
    close(f);
    end;
    
    if s=3 then
    begin
    assign(f,'3answers');
    reset(f);
    seek(f,i);
    read(f,k);
    close(f);
    end;
    
    write (O,k)
    end;
    close(O)
    for i:=1 to e do
    begin
    
    assign(f,'correct_answers');
    assign(O,'otveti');
    seek(f,e);
    seek(O,e);
    read(f,a);
    read(O,b);
    if a=b then
    v:=v+1;
    writeln('правильных ответов:',v)
    
    end;
    end;
    procedure watch_all;
    var j,e,n:byte;
    begin
    begin
    assign(f,'questions') ;
    reset(f);
    n:=filesize(f);
    for j:=1 to n do
    seek(f,j);
    read(f,e);
    writeln(j,'-й вопрос',e);
    close(f);
    
    assign(f,'1answers');
    reset(f);
    seek(f,j);
    read(f,e);
    writeln('первый ответ:',e);
    close(f);
    
    assign(f,'2answers');
    reset(f);
    seek(f,j);
    read(f,e);
    writeln('второй ответ:',e);
    close(f);
    
    assign(f,'3answers');
    reset(f);
    seek(f,j);
    read(f,e);
    writeln('третий ответ:',e);
    close(f);
    
    end;
    
    begin
    v:=0;
    writeln('начинаем?');
    readln(l);
    if l='да' then
    begin
    writeln('продолжаем?');
    readln(l);
    writeln('1-посмотреть вопрос');
    writeln('1-изменить вопрос');
    writeln('1-добавить вопрос');
    writeln('4-пройти тест');
    writeln('5-прсмотреть все');
    readln(p);
    if p=1 then watch;
    if p=2 then change;
    if p=3 then create;
    if p=4 then test;
    if p=5 then watch_all;
    else writeln('error');
    until l='нет'
    end;
    if l='нет';
    writeln('пока');
    end