Форум программистов, компьютерный форум, киберфорум
Наши страницы
PascalABC.NET
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.80/5: Рейтинг темы: голосов - 5, средняя оценка - 4.80
kotAV
26 / 24 / 13
Регистрация: 15.09.2017
Сообщений: 149
1

Ошибка в алгоритме изменения координат

18.07.2018, 22:59. Просмотров 934. Ответов 21

В общем, код следующий:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
{$apptype windows}
uses GraphABC, System;
 
type
  tpmap = record
    name: string;
    sort: integer;
    x,y: real;
    road: array of record
      id: integer;
      tp: string;
    end;
  end;
 
var
  types: array of string;
  map: array of tpmap;
  current: integer = 77;
  
begin
  if (FileExists('mpf.dat')=true) or (current<>0) then
  begin
    if (FileExists('mpf.dat')=true) then
    begin
      var d: TextFile;
      assign(d,'mpf.dat');
      reset(d,encoding.UTF8);
      read(d,current);
      close(d);
      d.Erase;
    end;
    window.SetSize(500,500);
    window.Title:='Biker 2 Map Viewer';
    window.CenterOnScreen;
    window.IsFixedSize:=true;
    {$region MAP}
    begin
      var mapfile: TextFile;
      var mapid1: integer;
      var mapid2: integer;
      var mapinput: string;
      var typeid: integer;
      if FileExists('map.dat')=true then
      begin
        reset(mapfile,'map.dat',encoding.UTF8);
        while mapfile.Eof<>true do
        begin
          //try
          readln(mapfile,mapinput);
          if mapinput.left(6)='towns=' then
          begin
            SetLength(map,Copy(mapinput,7,16).ToInteger);
          end;
          if mapinput.left(8)='newtype=' then
          begin
            typeid+=1;
            SetLength(types,typeid);
            types[typeid-1]:=Copy(mapinput,9,32);
          end;
          if mapinput.left(5)='town=' then
          begin
            mapid1:=StrToInt(Copy(mapinput,6,32));
            mapid2:=0;
          end;
          if mapinput.left(5)='name=' then
          begin
            map[mapid1].name:=Copy(mapinput,6,64);
          end;
          if mapinput.left(5)='type=' then
          begin
            map[mapid1].sort:=StrToInt(Copy(mapinput,6,32));
          end;
          if mapinput.left(5)='posx=' then
          begin
            map[mapid1].x:=StrToFloat(Copy(mapinput,6,64));
          end;
          if mapinput.left(5)='posy=' then
          begin
            map[mapid1].y:=StrToFloat(Copy(mapinput,6,64));
          end;
          if mapinput.left(5)='road=' then
          begin
            mapid2+=1;
            SetLength(map[mapid1].road,mapid2);
            map[mapid1].road[mapid2-1].id:=StrToInt(mapinput.ToWords[1])-1;
            map[mapid1].road[mapid2-1].tp:=mapinput.ToWords[2];
          end;
          //except
          //  on System.Exception do
          //end;
        end;
        close(mapfile);
      end;
    end;{$endregion}
    var map0: array of tpmap;
    var count: array of integer;
    var count1: array of integer;
    var countid: integer;
    for var i:=0 to map[current].road.Length-1 do
    begin
      inc(countid);SetLength(count1,countid);
      count1[countid-1]:=map[current].road[i].id;
      for var j:=0 to map[map[current].road[i].id].road.Length-1 do
      begin
        inc(countid);SetLength(count1,countid);
        count1[countid-1]:=map[map[current].road[i].id].road[j].id;
      end;
    end;
    countid:=0;
    var check: boolean;
    for var i:=0 to count1.Length-1 do
    begin
      check:=false;
      for var j:=(i+1) to count1.Length-1 do
      begin
        if count1[i]=count1[j] then check:=true;
      end;
      if check=false then
      begin
        inc(countid);
        SetLength(count,countid);
        count[countid-1]:=count1[i];
      end;
    end;
    var maxx, maxy, minx, miny: real;
    var dx, dy, MASTER: real;
    for var i:=0 to map.Length-1 do
    for var j:=0 to count.Length-1 do
    if i=count[j] then
    begin
      if maxx<map[i].x then maxx:=map[i].x;
      if maxy<map[i].y then maxy:=map[i].y;
      if minx>map[i].x then minx:=map[i].x;
      if miny>map[i].y then miny:=map[i].y;
    end;
    dx:=maxx-minx;
    dy:=maxy-miny;
    if (dx) > (dy) then
      MASTER:=(window.Height/dy)
      else MASTER:=(window.Width/dx);
    for var i:=0 to map.Length-1 do
    begin
      map[i].x:=((map[i].x-map[current].x)*MASTER)+250;
      map[i].y:=250-((map[i].y-map[current].y)*MASTER);
    end;
    for var i:=0 to map.Length-1 do
    for var k:=0 to count.Length-1 do
    if i=count[k] then
    begin
      if i=current then
      case map[i].sort of
        0: for var j:=9 downto 1 do if j mod 3 = 0 then DrawCircle(round(map[i].x),round(map[i].y),j);
        1: for var j:=15 downto 1 do if j mod 3 = 0 then DrawCircle(round(map[i].x),round(map[i].y),j);
        2: for var j:=27 downto 1 do if j mod 3 = 0 then DrawCircle(round(map[i].x),round(map[i].y),j);
      end
      else
      case map[i].sort of
        0: DrawCircle(round(map[i].x),round(map[i].y),9);
        1: DrawCircle(round(map[i].x),round(map[i].y),15);
        2: DrawCircle(round(map[i].x),round(map[i].y),27);
      end;
      for var j:=0 to map[i].road.Length-1 do
      begin
        if map[i].road[j].tp.ToLower='g' then
        line(round(map[i].x),round(map[i].y),round(map[map[i].road[j].id].x),round(map[map[i].road[j].id].y),color.Orange)
        else
        line(round(map[i].x),round(map[i].y),round(map[map[i].road[j].id].x),round(map[map[i].road[j].id].y),color.OliveDrab);
      end;
      case map[i].sort of
        0: TextOut(round(map[i].x)+5,round(map[i].y)-13,map[i].name);
        1: TextOut(round(map[i].x)+8,round(map[i].y)-20,map[i].name);
        2: TextOut(round(map[i].x)-(map[i].name.Length*4),round(map[i].y)-30,map[i].name);
      end;
    end;
  end
  else window.Close;
end.
Какая-то часть точек смещается относительно других. Следовательно, ошибка в преобразовании. Код очень ужасный, да, но я весь его перечитал, но так и не понял в чём дело. Файл map.txt (поменять тип на .dat): map.txt

Координаты в файле верные (проверил прошлой программой, выводящей всю карту). Мозгов не хватает найти банальнейшую ошибку в алгоритме преобразования координат (отцентровка относительно текущей точки).
0
Лучшие ответы (1)
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
18.07.2018, 22:59
Ответы с готовыми решениями:

Ошибка в алгоритме, нужно исправить
Задача: Дан целочисленный массив N*M. Разработать алгоритм и программу...

Ошибка в алгоритме пузырьковой сортировки
Добрый день, мне необходимо написать алгоритм сортировки массива, заполненного...

Поиск седлового элемента матрицы. Ошибка в алгоритме
Всем привет. Пытался реализовать поиск седлового элемента матрицы, однако...

Ошибка 0 - выход за границы диапазона изменения индекса
program masiv; var i, j, n, sum: integer; mas: array of integer; ...

Ошибка работы с матрицей: Выход за границы диапазона изменения индекса
program laba; type mas=array of integer; var i,j:integer; procedure...

21
JuriiMW
1952 / 1051 / 1560
Регистрация: 10.12.2014
Сообщений: 3,870
19.07.2018, 08:22 2
Я не понял что там у вас с дорогами… Поэтому вывожу всё подряд.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
uses GraphABC, System;
 
type
  tpmap = record
    name: string;
    sort: integer;
    x,y: real;
    road: array of record
      id: integer;
      tp: char;
    end;
  end;
 
var
  types: array of string;
  map: array of tpmap;
 
procedure AddTypes(t : String);
begin
  var L := types.Count;
  SetLength(types, L+1);
  types[L] := t;
end;
  
procedure ReadMap(fName : String);
begin
  if Not IO.File.Exists(fName) then Exit;
  var txt := ReadAllText(fName, Encoding.UTF8).ToWords(#13#10.toArray);
  var (mapid1, mapid2) := (0, 0);
  foreach var s in txt do
    if s.IndexOf('=') > 0 then
      begin
        var p := s.ToWords('=');
        case p[0] of
          'towns' : SetLength(map, p[1].ToInteger);
          'newtype' : AddTypes(p[1]);
          'town' : (mapid1, mapid2) := (StrToInt(p[1]), 0);
          'name' : map[mapid1].name := p[1];
          'type' : map[mapid1].sort := StrToInt(p[1]);
          'posx' : map[mapid1].x := StrToFloat(p[1]);
          'posy' : map[mapid1].y := StrToFloat(p[1]);
          'road' : begin
                     SetLength(map[mapid1].road, mapid2 + 1);
                     map[mapid1].road[mapid2].id := StrToInt(p[1].ToWords(' ')[0]) - 1;
                     map[mapid1].road[mapid2].id := StrToInt(p[1].ToWords(' ')[0]) - 1;
                     mapid2 += 1;
                   end;
        end;
      end;
end;
 
function Xcoord(X : Real; Town0, Town1 : tpmap; Scale : Real) := X + (Town1.x - Town0.x) * Scale;
function Ycoord(Y : Real; Town0, Town1 : tpmap; Scale : Real) := Y + (Town1.y - Town0.y) * Scale;
 
var Lout, Lwait : List<integer>; // out - отрисованные, wait - ожидающие отрисовки
 
procedure DrawRoads(X, Y : Real; Town : tpmap; Scale : Real);
begin
  foreach var over in Town.road do
    begin
      case over.tp of
        'B' : Pen.Color := rgb(100, 255, 100);
        'G' : Pen.Color := rgb(128, 128, 128);
      end;
      Line(Round(X), Round(Y), Round(Xcoord(X, Town, map[over.id], Scale)), Round(Ycoord(Y, Town, map[over.id], Scale)));
      if Not Lout.Contains(over.id) and Not Lwait.Contains(over.id) then Lwait.Add(over.id);
    end;
end;
 
procedure DrawTown(X, Y : Real; DrawType : Integer; Town : tpmap; Scale : Real);
begin
  case DrawType of
    0 : begin
          DrawRoads(X, Y, Town, Scale);
          Brush.Color := rgb(128, 128, 192);
          Pen.Color := rgb(0, 0, 0);
        end;
    1 : begin
          DrawRoads(X, Y, Town, Scale);
          Brush.Color := rgb(128, 192, 128);
          Pen.Color := rgb(0, 0, 0);
        end;
    2 : begin
          DrawRoads(X, Y, Town, Scale);
          Brush.Color := rgb(192, 128, 128);
          Pen.Color := rgb(0, 0, 0);
        end;
    3 : begin // центральная точка
          DrawRoads(X, Y, Town, Scale);
          Brush.Color := rgb(255, 255, 0);
          Pen.Color := rgb(255, 0, 0);
          Circle(Round(X), Round(Y), 10);
          DrawTextCentered(Round(X), Round(Y) - 10 - TextHeight(Town.Name), Town.Name);
          Exit;
        end;
  end;
  Circle(Round(X), Round(Y), 5);
  DrawTextCentered(Round(X), Round(Y) - 5 - TextHeight(Town.Name), Town.Name);
end;
 
procedure DrawMap(Center : Integer; Scale : Real);
begin
  Lout := New List<integer>;
  Lwait := New List<integer>;
  DrawTown(Window.Center.X, Window.Center.Y, 3, map[Center], Scale); Lout.Add(Center);
  while Lwait.Count > 0 do
    begin
      var cur := Lwait.First;
      DrawTown(Xcoord(Window.Center.X, map[Center], map[cur], Scale), Ycoord(Window.Center.Y, map[Center], map[cur], Scale), map[cur].sort, map[cur], Scale);
      Lout.Add(cur); Lwait.Remove(cur);
    end;
  Lout := nil;
  Lwait := nil;
end;
 
begin
  window.SetSize(1000,800);
  window.Title:='Biker 2 Map Viewer';
  window.CenterOnScreen;
  window.IsFixedSize:=true;
  
  SetLength(types, 0);
  ReadMap('map.dat');
  
  DrawMap(77, 2.1);
end.
1
kotAV
26 / 24 / 13
Регистрация: 15.09.2017
Сообщений: 149
19.07.2018, 09:52  [ТС] 3
JuriiMW, Ничего себе вы мастер GraphABC...
Среди дорог есть два типа - хорошие (асфальт) и плохие (песок или щебёнка).
(Ваша ошибка - вы из файла тип дороги не прочитали)

Кстати, координаты в оригинальном файле (.svg) начинаются с левого нижнего угла, а в GraphABC - верхнего. Потому надо всю карту ещё и перевернуть...

Насчёт того как я выводил - город(текущий) - от него по дорогам города и от тех города. Что бы не было видно всю карту сразу типо.

Также просто офигел с того, что Array.Count, при нулевом размере массива, в отличии от Array.Length - не вылетает.

Добавлено через 7 минут
А да, зачем использовать System.IO.File.Exists? Хотя, я с таким же успехом отказался от CRT в пользу System.Console, но всё же))
Pascal
1
2
3
4
function FileExists(name: string): boolean;
begin
  Result := System.IO.File.Exists(name);
end;
0
JuriiMW
1952 / 1051 / 1560
Регистрация: 10.12.2014
Сообщений: 3,870
19.07.2018, 10:16 4
Поправил:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
uses GraphABC, System;
 
type
  tpmap = record
    name: string;
    sort: integer;
    x,y: real;
    road: array of record
      id: integer;
      tp: char;
    end;
  end;
 
var
  types: array of string;
  map: array of tpmap;
 
procedure AddTypes(t : String);
begin
  var L := types.Count;
  SetLength(types, L+1);
  types[L] := t;
end;
  
procedure ReadMap(fName : String);
begin
  if Not IO.File.Exists(fName) then Exit;
  var txt := ReadAllText(fName, Encoding.UTF8).ToWords(#13#10.toArray);
  var (mapid1, mapid2) := (0, 0);
  foreach var s in txt do
    if s.IndexOf('=') > 0 then
      begin
        var p := s.ToWords('=');
        case p[0] of
          'towns' : SetLength(map, p[1].ToInteger);
          'newtype' : AddTypes(p[1]);
          'town' : (mapid1, mapid2) := (StrToInt(p[1]), 0);
          'name' : map[mapid1].name := p[1];
          'type' : map[mapid1].sort := StrToInt(p[1]);
          'posx' : map[mapid1].x := StrToFloat(p[1]);
          'posy' : map[mapid1].y := StrToFloat(p[1]);
          'road' : begin
                     SetLength(map[mapid1].road, mapid2 + 1);
                     map[mapid1].road[mapid2].id := StrToInt(p[1].ToWords(' ')[0]) - 1;
                     map[mapid1].road[mapid2].tp := p[1].ToWords(' ')[1][1];
                     mapid2 += 1;
                   end;
        end;
      end;
end;
 
function Xcoord(X : Real; Town0, Town1 : tpmap; Scale : Real) := X + (Town1.x - Town0.x) * Scale;
function Ycoord(Y : Real; Town0, Town1 : tpmap; Scale : Real) := Y - (Town1.y - Town0.y) * Scale;
 
var Lout, Lwait : List<integer>; // out - отрисованные, wait - ожидающие отрисовки
 
procedure DrawRoads(X, Y : Real; Town : tpmap; Scale : Real);
begin
  foreach var over in Town.road do
    begin
      case over.tp of
        'B' : Pen.Color := rgb(32, 32, 32);
        'G' : Pen.Color := rgb(192, 192, 192);
      end;
      Line(Round(X), Round(Y), Round(Xcoord(X, Town, map[over.id], Scale)), Round(Ycoord(Y, Town, map[over.id], Scale)));
      if Not Lout.Contains(over.id) and Not Lwait.Contains(over.id) then Lwait.Add(over.id);
    end;
end;
 
procedure DrawTown(X, Y : Real; DrawType : Integer; Town : tpmap; Scale : Real);
begin
  var R := 5;
  case DrawType of
    0 : begin
          Brush.Color := rgb(128, 128, 192);
          Pen.Color := rgb(0, 0, 0);
        end;
    1 : begin
          Brush.Color := rgb(128, 192, 128);
          Pen.Color := rgb(0, 0, 0);
        end;
    2 : begin
          Brush.Color := rgb(192, 128, 128);
          Pen.Color := rgb(0, 0, 0);
        end;
    3 : begin // центральная точка
          R := 8;
          Brush.Color := rgb(255, 255, 0);
          Pen.Color := rgb(255, 0, 0);
        end;
  end;
  Circle(Round(X), Round(Y), R);
  DrawTextCentered(Round(X), Round(Y) - TextHeight(Town.Name), Town.Name);
end;
 
procedure DrawMap(Center : Integer; Scale : Real);
begin
  Lout := New List<integer>;
  Lwait := New List<integer>;
  Lwait.Add(Center);
  while Lwait.Count > 0 do
    begin
      var cur := Lwait.First;
      DrawRoads(Xcoord(Window.Center.X, map[Center], map[cur], Scale), Ycoord(Window.Center.Y, map[Center], map[cur], Scale), map[cur], Scale);
      Lout.Add(cur); Lwait.Remove(cur);
    end;
  Lout := nil;
  Lwait := nil;
  
  for var cur := 0 to map.Count-1 do
    DrawTown(Xcoord(Window.Center.X, map[Center], map[cur], Scale), Ycoord(Window.Center.Y, map[Center], map[cur], Scale), cur = Center ? 3 : map[cur].sort, map[cur], Scale);
end;
 
begin
  window.SetSize(1000,800);
  window.Title:='Biker 2 Map Viewer';
  window.CenterOnScreen;
  window.IsFixedSize:=true;
  
  SetLength(types, 0);
  ReadMap('map.dat');
  
  DrawMap(77, 2.1);
end.
Цитата Сообщение от kotAV Посмотреть сообщение
А да, зачем использовать System.IO.File.Exists?
Зачем вызывать обёртку метода, если можно вызвать сам метод?
Ведь вы же сами используете методы Window вместо SetWindowSize, SetWindowTitle и прочего ;–)
1
Puporev
Модератор
54586 / 42092 / 29061
Регистрация: 18.05.2008
Сообщений: 99,290
19.07.2018, 10:29 5
Интересно, почему у меня на строке
Pascal
1
DrawTown(Window.Center.X, Window.Center.Y, 3, map[Center], Scale); Lout.Add(Center);
Выдает ошибку
Program1.pas(105) : Ошибка времени выполнения: Ссылка на объект не указывает на экземпляр объекта.

Кстати в в коде от kotAV ту же ошибку на строке
Pascal
1
for var i:=0 to map[current].road.Length-1 do
0
JuriiMW
1952 / 1051 / 1560
Регистрация: 10.12.2014
Сообщений: 3,870
19.07.2018, 10:30 6
Добавил приближение-удаление и поменял цвета для дорог:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
uses GraphABC, System;
 
type
  tpmap = record
    name: string;
    sort: integer;
    x,y: real;
    road: array of record
      id: integer;
      tp: char;
    end;
  end;
 
var
  types: array of string;
  map: array of tpmap;
 
procedure AddTypes(t : String);
begin
  var L := types.Count;
  SetLength(types, L+1);
  types[L] := t;
end;
  
procedure ReadMap(fName : String);
begin
  if Not IO.File.Exists(fName) then Exit;
  var txt := ReadAllText(fName, Encoding.UTF8).ToWords(#13#10.toArray);
  var (mapid1, mapid2) := (0, 0);
  foreach var s in txt do
    if s.IndexOf('=') > 0 then
      begin
        var p := s.ToWords('=');
        case p[0] of
          'towns' : SetLength(map, p[1].ToInteger);
          'newtype' : AddTypes(p[1]);
          'town' : (mapid1, mapid2) := (StrToInt(p[1]), 0);
          'name' : map[mapid1].name := p[1];
          'type' : map[mapid1].sort := StrToInt(p[1]);
          'posx' : map[mapid1].x := StrToFloat(p[1]);
          'posy' : map[mapid1].y := StrToFloat(p[1]);
          'road' : begin
                     SetLength(map[mapid1].road, mapid2 + 1);
                     map[mapid1].road[mapid2].id := StrToInt(p[1].ToWords(' ')[0]) - 1;
                     map[mapid1].road[mapid2].tp := p[1].ToWords(' ')[1][1];
                     mapid2 += 1;
                   end;
        end;
      end;
end;
 
function Xcoord(X : Real; Town0, Town1 : tpmap; Scale : Real) := X + (Town1.x - Town0.x) * Scale;
function Ycoord(Y : Real; Town0, Town1 : tpmap; Scale : Real) := Y - (Town1.y - Town0.y) * Scale;
 
var Lout, Lwait : List<integer>; // out - отрисованные, wait - ожидающие отрисовки
 
procedure DrawRoads(X, Y : Real; Town : tpmap; Scale : Real);
begin
  foreach var over in Town.road do
    begin
      case over.tp of
        'B' : Pen.Color := rgb(192, 192, 192);
        'G' : Pen.Color := rgb(32, 32, 32);
      end;
      Line(Round(X), Round(Y), Round(Xcoord(X, Town, map[over.id], Scale)), Round(Ycoord(Y, Town, map[over.id], Scale)));
      if Not Lout.Contains(over.id) and Not Lwait.Contains(over.id) then Lwait.Add(over.id);
    end;
end;
 
procedure DrawTown(X, Y : Real; DrawType : Integer; Town : tpmap; Scale : Real);
begin
  var R := 5;
  case DrawType of
    0 : begin
          Brush.Color := rgb(128, 128, 192);
          Pen.Color := rgb(0, 0, 0);
        end;
    1 : begin
          Brush.Color := rgb(128, 192, 128);
          Pen.Color := rgb(0, 0, 0);
        end;
    2 : begin
          Brush.Color := rgb(192, 128, 128);
          Pen.Color := rgb(0, 0, 0);
        end;
    3 : begin // центральная точка
          R := 8;
          Brush.Color := rgb(255, 255, 0);
          Pen.Color := rgb(255, 0, 0);
        end;
  end;
  Circle(Round(X), Round(Y), R);
  DrawTextCentered(Round(X), Round(Y) - TextHeight(Town.Name), Town.Name);
end;
 
procedure DrawMap(Center : Integer; Scale : Real);
begin
  Lout := New List<integer>;
  Lwait := New List<integer>;
  Lwait.Add(Center);
  while Lwait.Count > 0 do
    begin
      var cur := Lwait.First;
      DrawRoads(Xcoord(Window.Center.X, map[Center], map[cur], Scale), Ycoord(Window.Center.Y, map[Center], map[cur], Scale), map[cur], Scale);
      Lout.Add(cur); Lwait.Remove(cur);
    end;
  Lout := nil;
  Lwait := nil;
  
  for var cur := 0 to map.Count-1 do
    DrawTown(Xcoord(Window.Center.X, map[Center], map[cur], Scale), Ycoord(Window.Center.Y, map[Center], map[cur], Scale), cur = Center ? 3 : map[cur].sort, map[cur], Scale);
end;
 
var Scale := 2.1;
 
procedure KeyPress(c : Char);
begin
  case c of
    '+' : begin
            LockDrawing;
            Window.Clear;
            Scale += 0.1;
            DrawMap(77, Scale);
            UnlockDrawing;
          end;
    '-' : if Scale > 1 then
          begin
            LockDrawing;
            Window.Clear;
            Scale -= 0.1;
            DrawMap(77, Scale);
            UnlockDrawing;
          end;
     #27 : Window.Close;
  end;
end;
 
begin
  window.SetSize(1000,800);
  window.Title:='Biker 2 Map Viewer';
  window.CenterOnScreen;
  window.IsFixedSize:=true;
  
  SetLength(types, 0);
  ReadMap('map.dat');
  
  DrawMap(77, Scale);
  
  OnKeyPress := KeyPress;
end.
0
kotAV
26 / 24 / 13
Регистрация: 15.09.2017
Сообщений: 149
19.07.2018, 10:34  [ТС] 7
JuriiMW, Блин! Я тоже приближение и удаление добавил, пока вы код писали, только на мышь. Извините, я уже со всем разобрался))

Puporev, вот даже и не знаю.
0
JuriiMW
1952 / 1051 / 1560
Регистрация: 10.12.2014
Сообщений: 3,870
19.07.2018, 10:35 8
Лучший ответ Сообщение было отмечено kotAV как решение

Решение

Puporev, выбивает потому, что не сделана проверка на существование файла с данными…
Поправил код:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
uses GraphABC, System;
 
type
  tpmap = record
    name: string;
    sort: integer;
    x,y: real;
    road: array of record
      id: integer;
      tp: char;
    end;
  end;
 
var
  types: array of string;
  map: array of tpmap;
 
procedure AddTypes(t : String);
begin
  var L := types.Count;
  SetLength(types, L+1);
  types[L] := t;
end;
  
procedure ReadMap(fName : String);
begin
  if Not IO.File.Exists(fName) then Exit;
  var txt := ReadAllText(fName, Encoding.UTF8).ToWords(#13#10.toArray);
  var (mapid1, mapid2) := (0, 0);
  foreach var s in txt do
    if s.IndexOf('=') > 0 then
      begin
        var p := s.ToWords('=');
        case p[0] of
          'towns' : SetLength(map, p[1].ToInteger);
          'newtype' : AddTypes(p[1]);
          'town' : (mapid1, mapid2) := (StrToInt(p[1]), 0);
          'name' : map[mapid1].name := p[1];
          'type' : map[mapid1].sort := StrToInt(p[1]);
          'posx' : map[mapid1].x := StrToFloat(p[1]);
          'posy' : map[mapid1].y := StrToFloat(p[1]);
          'road' : begin
                     SetLength(map[mapid1].road, mapid2 + 1);
                     map[mapid1].road[mapid2].id := StrToInt(p[1].ToWords(' ')[0]) - 1;
                     map[mapid1].road[mapid2].tp := p[1].ToWords(' ')[1][1];
                     mapid2 += 1;
                   end;
        end;
      end;
end;
 
function Xcoord(X : Real; Town0, Town1 : tpmap; Scale : Real) := X + (Town1.x - Town0.x) * Scale;
function Ycoord(Y : Real; Town0, Town1 : tpmap; Scale : Real) := Y - (Town1.y - Town0.y) * Scale;
 
var Lout, Lwait : List<integer>; // out - отрисованные, wait - ожидающие отрисовки
 
procedure DrawRoads(X, Y : Real; Town : tpmap; Scale : Real);
begin
  foreach var over in Town.road do
    begin
      case over.tp of
        'B' : Pen.Color := rgb(192, 192, 192);
        'G' : Pen.Color := rgb(32, 32, 32);
      end;
      Line(Round(X), Round(Y), Round(Xcoord(X, Town, map[over.id], Scale)), Round(Ycoord(Y, Town, map[over.id], Scale)));
      if Not Lout.Contains(over.id) and Not Lwait.Contains(over.id) then Lwait.Add(over.id);
    end;
end;
 
procedure DrawTown(X, Y : Real; DrawType : Integer; Town : tpmap; Scale : Real);
begin
  var R := 5;
  case DrawType of
    0 : begin
          Brush.Color := rgb(128, 128, 192);
          Pen.Color := rgb(0, 0, 0);
        end;
    1 : begin
          Brush.Color := rgb(128, 192, 128);
          Pen.Color := rgb(0, 0, 0);
        end;
    2 : begin
          Brush.Color := rgb(192, 128, 128);
          Pen.Color := rgb(0, 0, 0);
        end;
    3 : begin // центральная точка
          R := 8;
          Brush.Color := rgb(255, 255, 0);
          Pen.Color := rgb(255, 0, 0);
        end;
  end;
  Circle(Round(X), Round(Y), R);
  DrawTextCentered(Round(X), Round(Y) - TextHeight(Town.Name), Town.Name);
end;
 
procedure DrawMap(Center : Integer; Scale : Real);
begin
  Lout := New List<integer>;
  Lwait := New List<integer>;
  Lwait.Add(Center);
  while Lwait.Count > 0 do
    begin
      var cur := Lwait.First;
      DrawRoads(Xcoord(Window.Center.X, map[Center], map[cur], Scale), Ycoord(Window.Center.Y, map[Center], map[cur], Scale), map[cur], Scale);
      Lout.Add(cur); Lwait.Remove(cur);
    end;
  Lout := nil;
  Lwait := nil;
  
  for var cur := 0 to map.Count-1 do
    DrawTown(Xcoord(Window.Center.X, map[Center], map[cur], Scale), Ycoord(Window.Center.Y, map[Center], map[cur], Scale), cur = Center ? 3 : map[cur].sort, map[cur], Scale);
end;
 
var Scale := 2.1;
 
procedure KeyPress(c : Char);
begin
  case c of
    '+' : begin
            LockDrawing;
            Window.Clear;
            Scale += 0.1;
            DrawMap(77, Scale);
            UnlockDrawing;
          end;
    '-' : if Scale > 1 then
          begin
            LockDrawing;
            Window.Clear;
            Scale -= 0.1;
            DrawMap(77, Scale);
            UnlockDrawing;
          end;
     #27 : Window.Close;
  end;
end;
 
begin
  window.SetSize(1000,800);
  window.Title:='Biker 2 Map Viewer';
  window.CenterOnScreen;
  window.IsFixedSize:=true;
  
  SetLength(map, 0);
  SetLength(types, 0);
  ReadMap('map.dat');
  
  if map.Count = 0 then
    begin
      Font.Size := 50;
      DrawTextCentered(Window.Center.X, Window.Center.Y, 'Карта не загружена!');
    end
  else
    begin
      DrawMap(77, Scale);
      
      OnKeyPress := KeyPress;
    end;
end.
Теперь, вроде, всё ;–)
1
kotAV
26 / 24 / 13
Регистрация: 15.09.2017
Сообщений: 149
19.07.2018, 10:36  [ТС] 9
JuriiMW, может не
Pascal
1
if Not IO.File.Exists(fName) then Exit;
а
Pascal
1
if Not IO.File.Exists(fName)=true then Exit;
0
JuriiMW
1952 / 1051 / 1560
Регистрация: 10.12.2014
Сообщений: 3,870
19.07.2018, 10:39 10
kotAV, за такое убивать нужно в младенчестве!
1
Puporev
Модератор
54586 / 42092 / 29061
Регистрация: 18.05.2008
Сообщений: 99,290
19.07.2018, 10:43 11
Понял откуда ошибка, скачал файл map.txt, а в обеих программах он имеет другое имя.
0
kotAV
26 / 24 / 13
Регистрация: 15.09.2017
Сообщений: 149
19.07.2018, 10:46  [ТС] 12
Puporev, просто форум не поддерживает формат .dat
0
Puporev
Модератор
54586 / 42092 / 29061
Регистрация: 18.05.2008
Сообщений: 99,290
19.07.2018, 10:49 13
Для этого формата нужно архив файла загружать.

Добавлено через 1 минуту
Да и вообще у Вас не map, a mpf, за такое тоже нужно бить.
1
kotAV
26 / 24 / 13
Регистрация: 15.09.2017
Сообщений: 149
19.07.2018, 10:49  [ТС] 14
Puporev, mpf - файл передачи данных о текущем городе из одного экзешника в другой
0
Cyborg Drone
20.07.2018, 00:26
  #15

Не по теме:

kotAV, ещё раз сравните логическую переменную с логической константой - прокляну. Когда кто-то так делает, где-то умирает маленький пушистый котёнок... Ах, да, чуть не забыл.... Ещё индусские программисты по этому поводу выпивают стаканчик фенни в честь написания "что-то там равно true"... Ну, или "что-то там равно false"... И бросают копию Вашего кода в Ганг... И очень радуются тому факту, что индусских программистов стало на одного больше...

:sarcasm:

0
kotAV
20.07.2018, 12:14  [ТС]
  #16

Не по теме:

Cyborg Drone, так оператор if ... then продолжается только если итог сравнения (любого другого логического действия) равен true... Всё, я понял... Всю жизнь сравнивал с константой true (a=true) (a<>true), а тут на тебе

0
alex5code
20.07.2018, 13:34
  #17

Не по теме:


kotAV, как вы могли такое подумать? Все операторы, принимающие логическую переменную, принимают её!

0
Cyborg Drone
22.07.2018, 02:44
  #18

Не по теме:

kotAV, верно. If a then ... если проверка на true, и if not a then ... если проверка на false. Тогда котята не умирают.

Замечу, что операции сравнения к логическим переменным (не константам!) иногда применять всё-таки можно и нужно, например, в том случае, если требуется вычисление эквиваленции, а также прямой и обратной импликации и их отрицаний. В паскале, за исключением Pascal ABC (не путать с ABC.NET), логический тип является перечисляемым, со всеми вытекающими последствиями, причём false < true, ord(false) = 0, ord(true) = 1, ну и, естественно, succ(false) = true, pred(true) = false, inc(false) = true, dec(true) = false. Пусть a и b - логические выражения либо логические переменные. Некоторые выражения с применением операций сравнения и их полные эквиваленты без операций сравнения:

Pascal
1
2
3
4
5
6
  if a = b //if not (a xor b) - экваваленция (не волнуйтесь, в данном случае нет сравнения с константой)
  if a <= b //if not a or b - прямая импликация
  if a > b //if a and not b - отрицание прямой импликации
  if a >= b //if a or not b - обратная импликация
  if a < b //if not a and b - отрицание обратной импликации
  if a xor b //if a <> b - неравнозначность, принято использовать xor, но ничто не мешает использовать <>
Как видите, очень часто с операциями сравнения получается проще и понятней.

0
kotAV
22.07.2018, 14:15  [ТС]
  #19

Не по теме:

Cyborg Drone, я бы плюс кинул, да оффтоп мешает) огромное спасибо!
пойду отвыкать от привычки сравнения логических переменных с логическими константами))

0
Соколиный глаз
Нарушитель
180 / 162 / 112
Регистрация: 25.07.2014
Сообщений: 2,971
Записей в блоге: 10
Завершенные тесты: 2
22.07.2018, 14:25 20
kotAV, сравнение с константой - плохой стиль программирования. Также как и использование везде где надо и не надо оператора goto.
0
22.07.2018, 14:25
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
22.07.2018, 14:25

Немного о линейном алгоритме
Написать прогу нахождения мин и макс трех чисел используя только линейный...

Помогите найти ошибку в алгоритме работы с файлами.
Ребят,а подскажите,вот требуется чтобы входной файл был 'input.txt' ,а выходной...

Поиск кратчайшего пути в алгоритме флойда! (На графах)
Алгоритм флойда! Нужно найти поиск кратчайшего пути в графе Program...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
20
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.
Рейтинг@Mail.ru