pascal
Главная | Каталог статей | Регистрация | Вход
Воскресенье
02.02.2025
07:04
Приветствую Вас Гость | RSS
Главная » Статьи » Pascal » Программы

Двухмерная клеточная система перемещения с картой и стенами
Имя файла Назначение файла
FileP.pas  Модуль считывает параметры из файла карты
M1.pas  Модуль констант (для удобства)
M2.pas Модуль создания базы и рисования карты
Objects.pas Модуль отрисовки объектов (персонаж, стена)
Main.pas Главный программа (управление) .exe (Главная программа)
Run.pas Доп. Программа - простая проверка целостности и состояния карты (Не обязателен) .exe (Запуск с тестом структуры)
map.m Файл карта (имя - константа)

Управление

w a s d - перемещение

0 - выход

Конфигурация карты

-1 - начальное положение персонажа (используется 1 раз)

1 - просто пространство

2 - стена (непроходимость)


FileP.pas

 unit
    FileP;
 
 interface
  
  const
      FMap = 'map.m';
      MaxCl = 50;
     
  function NumberX () : integer;
  function NumberY () : integer;
  function CellL () : integer;
 
 implementation
  function NumberX () : integer;
   var
     a : integer;
     t : text;
   begin
    assign (t,FMap);
    reset (t);
     read (t,a);
     Result := a;
    close (t);
   end;
  
  function NumberY () : integer;
   var
     a : integer;
     t : text;
   begin
    assign (t,FMap);
    reset (t);
     read (t,a);
     read (t,a);
     Result := a;
    close (t);
   end;
  
  function CellL () : integer;
   var
     a : integer;
     t : text;
   begin
    assign (t,FMap);
    reset (t);
     readln (t,a);
     read (t,a);
     Result := a;
    close (t);
   end;  
 end.


M1.pas

 unit
    M1;
 
 interface
  uses
     FileP;
 
  const
      Wx = NumberX ();
      Wy = NumberY ();
      Cl = CellL();
      
 implementation
 
 end.


M2.pas

 unit
    M2;
 
 interface
  uses
     GraphABC,
     FileP,
     Objects,
     M1;
 
  type
     BS = array [1..MaxCl,1..MaxCl] of integer;
 
  procedure CrMap (var map : BS; var x,y : integer);
  procedure CrWindow();
  
 
 implementation
 
  procedure CrMap (var map : BS; var x,y : integer);
   var
     t : text;
     i,j : integer;
     
   begin
    assign (t,FMap);
    reset (t);
     for i := 1 to 2 do
      readln (t,j);
     for i := 1 to Wy do
      begin
      for j := 1 to Wx do
       begin
        read (t,map[j,i]);
       end;
     end;
    close (t);
   
    for i := 1 to Wy do
     for j := 1 to Wx do
      case map[j,i] of
       -1 : begin
             PUser (j,i);
             x := j;
             y := i;
            end;
        2 : PWall (j,i);
      end; 
   end;
  
  procedure CrWindow();
   var
     WinX,WinY : integer;
     i,a : integer;
   begin
    WinX := Wx * Cl;
    WinY := Wy * Cl;
       
    SetWindowHeight (WinY);
    SetWindowWidth  (WinX);
    SetWindowIsFixedSize (true);
    SetWindowTitle ('Kletka');
    
     for i := 1 to Wy do
      begin
       a := i*Cl;
       line (0,a,Winx,a);
      end;
     
     for i := 1 to Wx do
      begin
       a := i*Cl;
       line (a,0,a,WinY);
      end;
     
   end;
   
 end.


Main.pas

 uses
    Objects,
    M1,
    M2;
 
 function TestCell (x,y : integer) : boolean;
  var
    r : boolean;
  begin
   r := false;
     if (x >0) and (x <= Wx) and
       (y >0) and (y <= Wy) then
        r := true;
    Result := r;
  end;
 
 
 var
   map : BS;
   m : char := 'a';
   Ix,Iy,Xn,Yn : integer;
 
 begin
  CrWindow();
  CrMap(map,Ix,Iy);
  
  
  While m <> '0' do
   begin
    readln (m);
    case m of
    'w','s','a','d' : begin
     xn := Ix;
     yn := Iy;
     case m of
      'w' : Yn := Iy -1;
      's' : Yn := Iy +1;
      'd' : Xn := Ix +1;
      'a' : Xn := Ix -1;
     end;
      
     if TestCell(Xn,Yn) then
      if map[Xn,Yn] <> 2 then
       begin

        UnpUser (Ix,Iy);
        Ix := xn;
        Iy := yn;
        PUser (Ix,Iy);
       end;                      
                      
                      end;
    end;  
   end;
  
 end.


Run.pas

 uses
    FileP,
    M1;
 
 function TestMap() : boolean;
  var
    t : text;
    a,i,j : integer;
    r : boolean;
  begin
   assign (t,FMap);
   reset (t);
      
  //Тест Размеров
   for i := 1 to 2 do
    begin
     read (t,a);
      if (a > MaxCL) or (a < 1) then
       begin
        Result := false;
        writeln ('Введены недопустимые размеры карты');
        Exit;
       end;
    end;
    
   //Тест размера клетки
   readln (t,a);
    if a < 1 then
     begin
       Result := false;
       writeln ('Введены недопустимые размеры клетки (px)');
       Exit;
     end;
   
   i := 1;
   j := 1;
   r := true;
   //Тест базы карты
   While (i <= Wy) and (r) do
     begin
       
       if i = Wx then
        j := j +1;
      read (t,a);
       if (a < -1) or (a > 2) or (a = 0) then
        begin
         r := false;
         writeln ('Карта содержит недопустимые значения');
        end;
       i := i +1;
     end;
   
   Result := r;         
   close (t);
  end;
 
 var
   r : boolean;
 
 begin
  r := true;
  
  if (not FIleExists ('M1.pcu')) or
     (not FIleExists ('M2.pcu')) or
     (not FIleExists ('Objects.pcu')) or
     (not FIleExists ('FileP.pcu'))  
  then
   begin
    r := false;
    writeln ('Програмная бибиотека повреждена или отцутсвует');
    writeln ('Запуск невозможен');
   end
  else
   writeln ('Програмные файлы ОК');
   
  if not FIleExists (FMap) then
   begin
    r := false;
    writeln ('Файл карты не найден');
   end;
  writeln ('Файл карты обнаружен');
  writeln ('--------------------');
   
  if r then
   r := TestMap ();
   
  if r then
   begin
    Exec ('main.exe');
    writeln ('Программа запущена Ok');
    sleep (2500);    
   end
  else
   begin
    writeln ('Запуск программы невозможен');
    writeln ('Исправьте ошибку и попытайтесь снова');
    readln ();
   end;
 end.



Пример файла карты

map.m

10 10
50
-1 2 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1
1 1 2 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1

--------

1 строка - Кол-во клеток x,y

2 строка - размер клетки px

Далее карта


 

Категория: Программы | Добавил: cccc1808 (25.07.2015)
Просмотров: 191 | Рейтинг: 0.0/0
Всего комментариев: 0
avatar
Вход на сайт
Поиск
Copyright MyCorp © 2025
Бесплатный хостинг uCoz