Форум программистов, компьютерный форум, киберфорум
Наши страницы
Pascal ABC
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.86/7: Рейтинг темы: голосов - 7, средняя оценка - 4.86
BadGivi
0 / 0 / 1
Регистрация: 27.05.2012
Сообщений: 13
1

Калейдоскоп - исправить недочеты в коде

21.08.2012, 12:39. Просмотров 1256. Ответов 13
Метки нет (Все метки)

Всем доброго времени суток, дамы и господа
Возникла у меня такая вот проблема, вернее у одногрупницы моей, игру ей надо было написать, колейдоскопом называется она, но вот досада, проблемка тут возникла одна, ошибка в проге вылетает, и за помощью к вам решил я обратиться.

Программы суть описана в картинках ниже
Искрене надеюсь на вашу помощь.
С уважением, Максим


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
program kaleidoskop;
uses graphabc;
type
   pr=record
        k,b:real;
        end;
   pcol=^col;
   col=record
      c:color;                        {вот тут вылетает}
      n:pcol;
      end;
var p:array[0..99] of pr;
    n,i,x1,x2,y1,y2:integer;
    c,g:color;                        {и вот тут}
    
procedure myline(x1,y1,x2,y2:integer;p:boolean);
var dx,dy,x,y:real;
    l,i:integer;
begin
if abs(x1-x2)>abs(y1-y2) then begin
                                dx:=1;
                                dy:=abs((y2-y1)/(x2-x1));
                                y:=y1; x:=x1;
                                l:=abs(x2-x1);
                                for i:=0 to l do
                                   begin
                                     if (WindowWidth>x)and(x>0)and(WindowHeight>y)and(y>0)and((p)or(getpixel(round(x),round(y))=c)) then setpixel(round(x),round(y),pencolor);
                                     if x2>x1 then x:=x+dx else x:=x-dx;
                                     if y2>y1 then y:=y+dy else y:=y-dy;
                                   end;
                              end
                         else begin
                                dx:=abs((x2-x1)/(y2-y1));
                                dy:=1;
                                y:=y1; x:=x1;
                                l:=abs(y2-y1);
                                for i:=0 to l do
                                   begin
                                     if (WindowWidth>x)and(x>0)and(WindowHeight>y)and(y>0)and((p)or(getpixel(round(x),round(y))=c)) then setpixel(round(x),round(y),pencolor);
                                     if x2>x1 then x:=x+dx else x:=x-dx;
                                     if y2>y1 then y:=y+dy else y:=y-dy;
                                   end;
                              end;
end;
    
procedure paint(a:pr);
const z=1000;
begin
myline(0,round(a.b),z,round(a.k*z+a.b),false);
end;
 
function fline(x1,y1,x2,y2:integer):pr;
var v:pr;
begin
v.k:=(y2-y1)/(x2-x1);
v.b:=y1-x1*v.k;
fline:=v;
end;
 
procedure krush;
var a1,a2:pcol;
    x,y:integer;
    c:color;
    b:boolean;
begin
  new(a1);
  a1^.n:=nil;
  a1^.c:=g;
  a2:=a1;
  new(a1);
  a1^.n:=a2;
  a1^.c:=rgb(0,0,0);
  for x:=100 to 300 do
    for y:=173 to 346 do
      begin
        b:=true;
        c:=getpixel(x,y);
        a2:=a1;
        while a2<>nil do
          begin
            if a2^.c=c then b:=false;
            a2:=a2^.n;
          end;
        if b then begin
                    c:=rgb(random(256),random(256),random(256));
                    a2:=a1;
                    new(a1);
                    a1^.n:=a2;
                    a1^.c:=c;
                    FloodFill(x,y,c);
                  end;
      end;
  while a1<>nil do
  begin
    a2:=a1^.n;
    dispose(a1);
    a1:=a2;
  end;
end;
 
procedure sim(a:pr;g1,g2:integer;b:boolean);
var x,x1,y:real;
    a1:pr;
    i:integer;
begin
  if g1>g2 then begin i:=g2; g2:=g1; g1:=i; end;
  a1.k:=-1/a.k;
  x:=g1;
  while x<g2 do
  begin
    x1:=0;
    y:=x*a.k+a.b;
    a1.b:=y-a1.k*x;
    while x1<200 do
    begin
      if b then begin
      if (round(x+x1)>0)and(round(x+x1)<402)and(round(a1.k*(x+x1)+a1.b)>0)and(round(a1.k*(x+x1)+a1.b)<348) then setpixel(round(x+x1),round(a1.k*(x+x1)+a1.b),getpixel(round(x-x1),round(a1.k*(x-x1)+a1.b)));
       end else begin 
      if (round(x-x1)>0)and(round(x-x1)<402)and(round(a1.k*(x-x1)+a1.b)>0)and(round(a1.k*(x-x1)+a1.b)<348) then setpixel(round(x-x1),round(a1.k*(x-x1)+a1.b),getpixel(round(x+x1),round(a1.k*(x+x1)+a1.b)));
       end;
      x1:=x1+0.4;
    end;
    x:=x+0.4;
  end;
end;
 
procedure simall(x,y:integer);
var i,j:integer;
begin
  y:=y div 2;
  for i:=0 to x do
     for j:=0 to y-1 do
     setpixel(i,y-j-1,getpixel(i,y+j));
end;
 
begin
randomize;
setwindowsize(402,348);
g:=clgreen;
c:=rgb(255,255,255);
clearwindow(c);
myline(200,173,100,346,true);
myline(200,173,300,346,true);
myline(300,346,100,346,true);
FloodFill(1,1,g);
n:=random(20);
for i:=0 to n do
begin
  repeat
  x1:=random(200)+100;
  y1:=random(173)+173;
  x2:=random(200)+100;
  y2:=random(173)+173;
  until (x1<>x2)and(y1<>y2);
  p[i]:=fline(x1,y1,x2,y2);
  paint(p[i]);
end;
krush;
sim(fline(200,173,100,346),100,200,false);
sim(fline(200,173,300,346),200,300,true);
simall(402,348);
myline(300,0,100,346,true);
myline(100,0,300,346,true);
myline(300,346,100,346,true);
myline(100,1,300,1,true);
myline(0,173,400,173,true);
myline(100,1,0,173,true);
myline(0,173,100,346,true);
myline(300,1,400,173,true);
myline(400,173,300,346,true);
FloodFill(1,1,rgb(random(256),random(256),random(256)));
end.

Заказываю контрольные, курсовые, дипломные и любые другие студенческие работы здесь.

0
Миниатюры
Калейдоскоп - исправить недочеты в коде   Калейдоскоп - исправить недочеты в коде  
Лучшие ответы (1)
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
21.08.2012, 12:39
Ответы с готовыми решениями:

Исправить недочеты в коде
var T : Text; a, b, h, x: real; y1, y2, y3, y1_1, y1_2, y1_3: real; ...

Исправить ошибку в коде
program v1; const n=10; var a:array of integer; i:integer; begin for i:=1...

Исправить ошибку в коде
var s,n,i:integer; a:array of integer; begin s:=0; readln(n); for...

Исправить ошибки в коде
Uses GraphABC; var S: Array of String; Procedure Opisanie; begin ...

Исправить ошибки в коде
Program Lab_4; Var i: integer; j, k: char; Begin i:=0; Repeat Readln(k);...

13
Puporev
Модератор
55411 / 42542 / 29396
Регистрация: 18.05.2008
Сообщений: 100,636
21.08.2012, 12:46 2
Лучший ответ Сообщение было отмечено Памирыч как решение

Решение

Замени везде
c:color;
на
c:integer;
1
BadGivi
0 / 0 / 1
Регистрация: 27.05.2012
Сообщений: 13
21.08.2012, 13:09  [ТС] 3
Спасибо вам огромное, выручили очень

Добавлено через 20 минут
Хм, а как сам процесс отражения треугольника происходит?
0
Puporev
Модератор
55411 / 42542 / 29396
Регистрация: 18.05.2008
Сообщений: 100,636
21.08.2012, 13:17 4
Вообще-то это делают с помощью афинных преобразований, но здесь автор программы как-то все по своему делал, лучше у него спросить.
0
BadGivi
0 / 0 / 1
Регистрация: 27.05.2012
Сообщений: 13
21.08.2012, 13:23  [ТС] 5
Так и поступим, благодарю
0
harger
0 / 0 / 0
Регистрация: 21.08.2012
Сообщений: 6
21.08.2012, 17:34 6
Я создатель. Спрашивай! У меня всё отлично работает на PascalABC.NET )))))))
0
Puporev
Модератор
55411 / 42542 / 29396
Регистрация: 18.05.2008
Сообщений: 100,636
21.08.2012, 17:36 7
Цитата Сообщение от harger Посмотреть сообщение
У меня всё отлично работает на PascalABC.NET
А ему видимо в простом нужно, но исправив color на integer все работает и в простом.
0
harger
0 / 0 / 0
Регистрация: 21.08.2012
Сообщений: 6
21.08.2012, 17:44 8
Ну это уже проблема компилятора. C integer в NET не работает, только что попробовал (Недопустимость записи цвета в формат integer)!
0
Puporev
Модератор
55411 / 42542 / 29396
Регистрация: 18.05.2008
Сообщений: 100,636
21.08.2012, 17:48 9
Цитата Сообщение от harger Посмотреть сообщение
C integer в NET не работает,
Это понятно, разные типы для цвета, а простом АВС, Турбо, Фрее везде integer.

Добавлено через 1 минуту
но ТС вообще-то это интересует
Цитата Сообщение от BadGivi Посмотреть сообщение
Хм, а как сам процесс отражения треугольника происходит?
Если можешь прокомментируй ему нужные строки.
0
BadGivi
0 / 0 / 1
Регистрация: 27.05.2012
Сообщений: 13
21.08.2012, 20:03  [ТС] 10
Боря, ты чтоле?))
0
Скромняга
0 / 0 / 0
Регистрация: 18.08.2012
Сообщений: 1
21.08.2012, 20:25 11
подскажите,как работает эта программа,у меня аналогичная просто) интересует конкретно сам процесс отражения от одного треугольника к остальным? и почему фон за калейдоскопом отличается по цвету сверху и внизу, можно ли его сделать черным и как?)
0
harger
0 / 0 / 0
Регистрация: 21.08.2012
Сообщений: 6
22.08.2012, 08:06 12
Цитата Сообщение от BadGivi Посмотреть сообщение
Боря, ты чтоле?))
А ты как догадался??? )

Добавлено через 6 минут
Цитата Сообщение от BadGivi Посмотреть сообщение
Боря, ты чтоле?))
Поосторожнее!! Здесь может быть он!!
0
BadGivi
0 / 0 / 1
Регистрация: 27.05.2012
Сообщений: 13
22.08.2012, 08:15  [ТС] 13
Боря, объясни Скромняге пару моментов, выручай друзей
0
zakstep
0 / 0 / 0
Регистрация: 18.10.2016
Сообщений: 1
18.10.2016, 23:32 14
harger, привет твоя прога ?
0
18.10.2016, 23:32
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
18.10.2016, 23:32

Исправить ошибки в коде
Старая программа, помогите исправить ошибки или подскажите, какая программа...

Исправить ошибку в коде
День добрый, по поводу программы, не то что бы ошибка, просто косяк, вот...

Исправить ошибки в коде
program rita; const N=10; function SeqSearch(mas: DataArray;...


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

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

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