HOME ПРИМЕРЫ THANKS НОВИЧКАМ ДОКИ LINKS JavaScript Mail


 
В этот день много лет назад...
1 мая. В 1945 году (72 года назад) - Покончил с собой, предварительно убив свою семью, нацистский министр пропаганды Й. Геббельс.
 
 

Turbo Pascal Examples

Графика:
Построение графика функции
Прыгающий по экрану мячик.
Качание маятника.
Вложенные цветные круги.
Броуновское движение. Использование объектов.
Матрицы и массивы:
Сортировка элементов массива.
Удаление одинаковых элементов.
Простой пример на поворот матрицы.
Сортировка методом Шелла. +функции измерения временных интервалов.
Проверка выпуклости многоугольника.
Перемоножение матриц
Вычисление определителя матрицы. Рекурсия.
Нахождение обратной матрицы.
Задача об автостоянке.
Рекурсия. Подземелье сокровищ.
Численные методы:
Задачка на определение угла между стрелками часов.
Проверка на принадлежность точки многоугольнику.
Нахождение точки пересечения двух отрезков на плоскости.
Сортировка методом Шелла. +функции измерения временных интервалов.
Сортировка методом "пузырька". Пример на динамические структуры данных. Связанные списки.
Нахождение корня функции методом половинного деления.
Вычисление арккосинуса
Нахождение суммы цифр натурального числа.
Работа с фалами:
Рекурсивное сканирование директорий.
Работа со строками:
Работа со словами в предложении с разделителями.
Простейший синтаксический анализатор для распознавания и вычисления многчлена.
Синтаксический анализатор для распознавания и вычисления многчлена.
Работа со строками: смена кодировки, удаление тегов из HTML текста, обработка
Переименование файлов из кириллицы в латиницу.
Выдача контекстной подсказки.
Частотный словарь символов.
Подсчет повторяющихся символов в строке.
Ссылочные переменные:
Моделирование стека.
Пасьянс "Косынка".
Игры:
Пасьянс "Косынка".
Игра "Питон"
Игра "Анацефал". Пример использования объектов.
Игра "Минное поле"
Большие проекты:
Электронная картотека (без исходника)


 Игра "Минное поле".
Реализация на паскале стандартной игры Windows. На поле, размер которого вы выбираете, находится некоторое количество мин. Изначально все ячейки скрыты. Чтобы вскрыть ячейку, нажмите клавишу "Ввод". Если она содержит мину, вы проиграли. Если мины нет, в ячейке появится цифра, которая указывает, сколько мин находится в восьми смежных с ней ячейках.
Чтобы пометить ячейку, в которой по вашему мнению находится мина, нажмите клавишу "Пробел".
После того как все мины, смежные с ячейкой, содержащей номер, будут найдены, укажите на эту ячейку и нажмите Ctrl-Ввод или "с", чтобы вскрыть все оставшиеся невскрытыми смежные ячейки. Однако, если вы неверно пометили мины, вы проиграете.
Цель игры состоит в том, чтобы как можно быстрее найти все мины на минном поле, не вскрыв ни одну из них.

uses crt,dos;
const NMaxX=40;
      NMaxY=25;
      Level:array[1..3,1..3] of byte = ((8,8,10),(16,16,40),(30,16,99));
      BorderColor=16*9+11;
      ScrCh=' '; ScrColor=16*8; { color of screen }
      MenCh='L'; MenColor=16*14+1;
      MinCh='M'; MinColor=16*15+1;
      NoMinCh='P'; NoMinColor=16*12+2;
      ErrorMinCh='X'; ErrorMinColor=16*12+15;
      DigColors:array[0..8] of byte =(16*9+11,16*9+1,16*9+10,16*9+4,16*9+12,16*9+15,12*16+14,127,143);
      DigCh:    array[0..8] of char =(' ','1','2','3','4','5','6','7','8');
      MoveIJ:array[1..8,1..2] of shortint=
        ((0,-1),(1,-1),(1,0),(1,1),(0,1),(-1,1),(-1,0),(-1,-1));
      Ramk:string=#218#191#192#217#179#196; {'-¬L-¦-'}
      SU=#24; SD=#25; SL=#26; SR=#27; ENT=#17#217;
      hlp_string=SU+','+SD+','+SL+','+SR+'-move player, '+ENT+'-open cell, SPACE-mark/unmark, C-check cell around';
      hlp_string2=' N - new game; ESC - exit';
type  PoleTp=array[1..NMaxX,1..NMaxY] of byte;
      ScrPtr=array[1..25,1..80] of
        record
          ch,at:char;
        end;
var scr:^ScrPtr;
    Pole:PoleTp;
    nx,ny,nm,im,jm,mleft:byte;
    i,j,k,i1,j1,Lev:byte;
    ch:char;
    p:^byte;
    MinX,MinY:byte;
    GameOver:boolean;
    hs, ms, ss, SpentTime,SpentTimeC: Word;
    h, m, s, hund, CellLeft: Word;
Function InPole(i,j:integer):boolean;
  begin
  InPole:=(i>0) and (i<=nx) and (j>0) and (j<=ny);
  end;
Procedure FillPole;
var i,j,k,d,im,jm:integer;
  begin
  for i:=1 to nx do for j:=1 to ny do Pole[i,j]:=0;
  randomize; i:=1+random(nx); j:=1+random(ny);
  { Заполнение поля и подсчет количества мин, находящихся
  рядом с каждой клеткой }
  for k:=1 to nm do
    begin
    while Pole[i,j]=9 do begin i:=1+random(nx); j:=1+random(ny) end;
    Pole[i,j]:=9; { Установлена мина }
    { Подсчет количества мин, находящихся рядом с каждой клеткой }
    for d:=1 to 8 do
      begin
      im:=i+MoveIJ[d,1];
      jm:=j+MoveIJ[d,2];
      if InPole(im,jm) then if Pole[im,jm]<9 then inc(Pole[im,jm]);
      end;
    i:=1+random(nx); j:=1+random(ny)
    end;
  mleft:=nm;
{ Цифра от 0 до 8 соответствует числу мин, расположенных рядом с клеткой.
  9 - означает мину. Пока клетка не видима, она имеет значение на 10 больше.
  Когда игрок помечает клетку как клетку с миной - значение увеличивается
  еще на 10  }
  for i:=1 to nx do for j:=1 to ny do
    if Pole[i,j]<10 then inc(Pole[i,j],10);
  end;
Procedure OutCell(i,j:integer;first:boolean);
var col,ch:char;
  begin
  case Pole[i,j] of
      0..8: begin col:=chr(DigColors[Pole[i,j]]); ch:=DigCh[Pole[i,j]]; end;
         9: begin col:=chr(MinColor);             ch:=MinCh; end;
    10..19: if First
              then begin col:=chr(ScrColor);      ch:=ScrCh; end
              else if (Pole[i,j]=19)
                then begin col:=chr(NoMinColor);    ch:=NoMinCh; end
                else begin col:=chr(ErrorMinColor); ch:=ErrorMinCh; end;
    20..29: begin col:=chr(NoMinColor);           ch:=NoMinCh; end;
    end;
  scr^[MinY+j,MinX+2*i-1].at:=col;
  scr^[MinY+j,MinX+2*i].at:=col;
  scr^[MinY+j,MinX+2*i].ch:=ch;
  end;
Procedure ShowMen(i,j:integer);
  begin
  scr^[MinY+j,MinX+2*i-1].at:=chr(MenColor);
  scr^[MinY+j,MinX+2*i].at:=chr(MenColor);
  end;
Procedure HideMen(i,j:integer);
  begin
  OutCell(i,j,true);
  end;
Procedure OutCh(x,y,atr:byte;ch:char);
  begin
  scr^[y,x].at:=chr(atr);
  scr^[y,x].ch:=ch;
  end;
Procedure WriteString(s:string);
  begin
  i:=1;
  while (i<80) and (i<Length(s)) do
  for i:=1 to 80 do if (i<=Length(s))
    then OutCh(i,25,16*7+1,s[i])
    else OutCh(i,25,16*7+1,' ')
  end;
Procedure OutPole(first:boolean);
var i,j:byte;
  begin
  window(MinX+1,MinY+1,MinX+2*nx,MinY+ny); ClrScr;
  window(1,1,80,25);
  if (first) then
    begin
    OutCh(MinX,MinY,BorderColor,Ramk[1]);
    OutCh(MinX,MinY+ny+1,BorderColor,Ramk[3]);
    OutCh(MinX+2*nx+1,MinY+ny+1,BorderColor,Ramk[4]);
    OutCh(MinX+2*nx+1,MinY,BorderColor,Ramk[2]);
    for i:=1 to nx do
      begin
      OutCh(MinX+i*2-1,MinY,BorderColor,Ramk[6]);
      OutCh(MinX+i*2,MinY,BorderColor,Ramk[6]);
      OutCh(MinX+i*2-1,MinY+ny+1,BorderColor,Ramk[6]);
      OutCh(MinX+i*2,MinY+ny+1,BorderColor,Ramk[6]);
      end;
    end;
  for j:=1 to ny do
    begin
    if (first) then
      begin
      OutCh(MinX,MinY+j,BorderColor,'¦');
      OutCh(MinX+2*nx+1,MinY+j,BorderColor,'¦');
      end;
    for i:=1 to nx do
      OutCell(i,j,first);
    end;
  end;
Procedure ClearPole(i,j:byte);
var d,im,jm:byte;
  begin
  for d:=1 to 8 do
    begin
    im:=i+MoveIJ[d,1];
    jm:=j+MoveIJ[d,2];
    if InPole(im,jm) then
      begin
      if Pole[im,jm]=10 then
        begin
        inc(Pole[im,jm],10);
        ClearPole(im,jm);
        dec(Pole[im,jm],20);
        Dec(CellLeft);
        end;
      if Pole[im,jm] in [10..19] then
        begin
        dec(Pole[im,jm],10);
        Dec(CellLeft);
        end;
      OutCell(im,jm,true);
      end;
    end;
  end;
Procedure WriteMinLeft;
  begin
  GotoXY(MinX+1,MinY);
  if (Lev>1) then
    begin
    GotoXY(MinX+1,MinY); Write(' Min');
    end;
  TextAttr:=BorderColor;
  Write(' Left:',mleft:3,' ');
  end;
Procedure TryCell(im,jm:byte;ShowMenAfter:boolean);
  begin
  if Pole[im,jm]<=19 then
    begin
    HideMen(im,jm);
    if Pole[im,jm]=19 then { mina }
      begin
      GotoXY(MinX+nx,MinY+ny+1);TextAttr:=BorderColor;Write(' BAM! ');
      for i:=1 to nx do for j:=1 to ny do
        if Pole[i,j]>=10 then Dec(Pole[i,j],10);
      GameOver:=true;
      WriteString(hlp_string2);
      OutPole(false);
      scr^[MinY+jm,MinX+2*im-1].at:=chr(ErrorMinColor);
      scr^[MinY+jm,MinX+2*im].at:=chr(ErrorMinColor);
      end
    else
      begin
      if Pole[im,jm]>=10 then
        begin
        Dec(Pole[im,jm],10);
        Dec(CellLeft);
        end;
      if Pole[im,jm]=0 then ClearPole(im,jm);
      OutCell(im,jm,true);
      if ShowMenAfter then ShowMen(im,jm);
      end;
    end; { 13 }
  end;
begin { main }
p:=Ptr($40, $49); { Адрес байта, хранящего текущую моду (режим экрана) }
if p^=7 then Scr:=Ptr($b000,0) else Scr:=Ptr($b800,0);
repeat
  TextAttr:=7; clrscr;
  window(30,9,50,15);
  TextAttr:=31; clrscr;
  window(1,1,80,25);
  GotoXY(35,10); writeln('Your level:');
  GotoXY(32,11); writeln('1: Beginner;');
  GotoXY(32,12); writeln('2: Intermediate;');
  GotoXY(32,13); writeln('3: Expert;');
  GotoXY(32,14); readln(Lev);
until Lev in [1..3];
clrscr;
nx:=level[Lev,1]; ny:=Level[Lev,2]; nm:=Level[Lev,3]; ch:=' ';
im:=nx div 2; jm:=ny div 2;
MinX:=NMaxX-nx; MinY:=(NMaxY-ny) div 2;
FillPole;
OutPole(true);
ShowMen(im,jm);
WriteString(hlp_string);
WriteMinLeft;
GameOver:=false;
GetTime(hs,ms,ss,hund); SpentTime:=0; CellLeft:=nx*ny;
WriteMinLeft;
repeat
  if KeyPressed then
    begin
    ch:=ReadKey;
    case ch of
      #0:if (not GameOver) then
          begin
          ch:=ReadKey;
          HideMen(im,jm);
          if not GameOver then case ch of
            'I': jm:=1;  {PgUp}
            'Q': jm:=ny; {PgDwn}
            'G': begin jm:=1; im:=1; end; {Home}
            'O': begin jm:=ny; im:=nx; end; {End}
            #72: if jm>1  then dec(jm);
            #75: if im>1  then dec(im);
            #77: if im<nx then inc(im);
            #80: if jm<ny then inc(jm);
            end; { case }
          ShowMen(im,jm);
          end; { 0 }
      'n','N': begin { Start new Game }
               FillPole; GameOver:=false;
               GetTime(hs,ms,ss,hund); SpentTime:=0; CellLeft:=nx*ny;
               OutPole(true); im:=nx div 2; jm:=ny div 2;
               ShowMen(im,jm);
               WriteString(hlp_string);
               WriteMinLeft;
               end;
      #13:TryCell(im,jm,true);
      'c',#10:if (Pole[im,jm] in [1..8]) then {#10 - Ctrl-Enter }
            begin
            HideMen(im,jm);
            k:=0; { подсчет количества открытых мин }
            i1:=im; j1:=jm;
            for i:=1 to 8 do if (InPole(i1+MoveIJ[i,1],j1+MoveIJ[i,2])) then
              if (Pole[i1+MoveIJ[i,1],j1+MoveIJ[i,2]] in [20..29]) then
                inc(k);
            if (Pole[im,jm]=k) then for i:=1 to 8 do if not GameOver then
              if (InPole(i1+MoveIJ[i,1],j1+MoveIJ[i,2])) then
                TryCell(im+MoveIJ[i,1],jm+MoveIJ[i,2],false);
            ShowMen(im,jm);
            end;
      ' ': if Pole[im,jm]>19 then
             begin
             Dec(Pole[im,jm],10);Inc(mleft);Inc(CellLeft);
             WriteMinLeft;
             OutCell(im,jm,true);
             ShowMen(im,jm);
             end
           else if Pole[im,jm]>=10 then
             begin
             Inc(Pole[im,jm],10); Dec(MLeft);Dec(CellLeft);
             WriteMinLeft;
             OutCell(im,jm,true);
             ShowMen(im,jm);
             end;
      end; { case }
    end;
  if (not GameOver) then
    begin { calculating spent time }
    GetTime(h,m,s,hund);
    SpentTimeC:=(h-hs)*3600+(m-ms)*60+s-ss;
    if SpentTimeC-SpentTime>=1 then
      begin
      GotoXY(MinX+nx*2-5,MinY); TextAttr:=BorderColor;
      if (Lev>1) then
        begin GotoXY(MinX+nx*2-12,MinY); Write(' Time:'); end;
      Write(SpentTimeC:4,' ');
      SpentTime:=SpentTimeC;
      end;
    end;
  if (CellLeft=0) and (not GameOver) then
    begin
    GotoXY(MinX+nx-9,MinY+ny+1);TextAttr:=BorderColor;Write(' CONGRATULATIONS! ');
    GameOver:=true;
    HideMen(im,jm);
    WriteString(hlp_string2);
    end;
until ch=#27;
end.

 

 

 

 

 

 

 


HOME