Repair the colors of a Dos program ported to ptcGraph unit

[Roland57]

I changed the graphic mode to 16 colors. Now you really have the feeling of a Dos program. 

[Fred vS]

There remains ony one small memory leak: I don't find where it comes from.

Imho, it comes from engine88.pas

You may try this:

Code: Pascal  [Select][+][-]

1. program nero5_test;
2. uses
3.   cthreads,
4.   engine88;
5.  
6. begin
7. end.

Compile it with this:

Code: Bash  [Select][+][-]

1. $ fpc -ghl nero5_test.pas

I get that:

fred@fiens $ ./nero5_test

Heap dump by heaptrc unit of nero5_test
1260 memory blocks allocated : 115031/117752
1259 memory blocks freed     : 114983/117704
1 unfreed memory blocks : 48
True heap size : 229376
True free heap : 229120
Should be : 229136
Call trace for block $00007FD7F1068F00 size 48

But I did not investigate where is the guilty.

Fre;D

[Fred vS]

Hum, in engine88.pas, in uses section there is:

Code: Pascal  [Select][+][-]

1. uses
2.   sysutils, ptccrt, ptcgraph;

Now doing this:

Code: Pascal  [Select][+][-]

1. program nero5_test;
2.  
3. uses
4.  cthreads,
5.  ptccrt;
6.  
7. begin
8. end.
9.  

Compile it with:

Code: Bash  [Select][+][-]

1. $ fpc -ghl nero5_test.pas

Gives the same result:

fred@fiens ~/roland> /home/fred/roland/nero5_test
Heap dump by heaptrc unit of /home/fred/roland/nero5_test
1260 memory blocks allocated : 115031/117752
1259 memory blocks freed     : 114983/117704
1 unfreed memory blocks : 48
True heap size : 229376
True free heap : 229120
Should be : 229136
Call trace for block $00007F008E667F00 size 48

Conclusion:

I fear that the memory leak is in ptccrt

Fre;D

[Fred vS]

It is me again!

Continuing the battle:

In ptccrt.pp in uses section there is:

Code: Pascal  [Select][+][-]

1. uses
2.   ptcgraph, ptc, ptcwrapper, ...

And doing this:

   

Code: Pascal  [Select][+][-]

1. program nero5_test;
2.      
3.     uses
4.      cthreads,
5.      ptcgraph;
6.  
7.   begin
8.   end.
9.  

Gives:   

Code: Pascal  [Select][+][-]

1. fred@fiens ./nero5_test
2. Heap dump by heaptrc unit of nero5_test
3. 1259 memory blocks allocated : 111191/113912
4. 1258 memory blocks freed     : 111143/113864
5. 1 unfreed memory blocks : 48
6. True heap size : 229376
7. True free heap : 229120
8. Should be : 229136
9. Call trace for block $00007F0409FDDF00 size 48

Re-conclusion, the memory leak is in ptcgraph.pp

(and not in ptc.pp, ptcwrapper.pp that are in uses section of ptcgraph.pp)

There is something missing in Finalization section of ptcgraph.pp.

For the sport, I let you find where.

Fre;D

[Roland57]

Thank your for your search Fred. So we should add this?

Code: Pascal  [Select][+][-]

1. // ptcgraph.pp
2. finalization
3.   PTCFormat8.Destroy;
4.   PTCFormat15.Destroy;
5.   PTCFormat16.Destroy;

I would like to test, but I don't know what is the procedure to test a modification in FPC units.

[Fred vS]

Thank your for your search Fred. So we should add this?

Code: Pascal  [Select][+][-]

1. // ptcgraph.pp
2. finalization
3.   PTCFormat8.Destroy;
4.   PTCFormat15.Destroy;
5.   PTCFormat16.Destroy;

Hello Roland.

I did try this already but sadly it does not compile, even using .free;

ptcgraph.pp(3467,15) Error: (5038) identifier idents no member "Destroy"

I did a fast investigation but without luck, this memory leak is well hidden.

I would like to test, but I don't know what is the procedure to test a modification in FPC units.

I do a easy way, to be sure to not touch at the original source.

So, copy in the root directory of project all files that are in:
 

Code: Pascal  [Select][+][-]

1. /fpc/src/packages/graph/src/ptcgraph/*.*

and in:

Code: Pascal  [Select][+][-]

1. /fpc/src/packages/graph/src/inc/*.*

And tune those files then compile.

[Fred vS]

[EDIT] Removed previous attachment, there was some file missing.

Hello Roland.

Here your project in attachment with all the needed files.

Fre;D

[Roland57]

Thank you Fred.

[Fred vS]

Thank you Fred.

With pleasure (if we find the guilty).

Something smells not good, in ptcgraph.pp and TPTCWrapperThread:

Using this to test the unit:

Code: Pascal  [Select][+][-]

1. program nero5_test;
2. uses
3.  cthreads,
4.  ptcgraph;
5.  
6. begin
7. end.

And in ptcgraph.pp, If you use that code (removing all other lines in initialization and finalization):

Code: Pascal  [Select][+][-]

1. ...
2. initialization
3.   PTCWrapperObject := TPTCWrapperThread.Create;
4.  
5. finalization
6.   PTCWrapperObject.Terminate;
7.   PTCWrapperObject.WaitFor;
8.   PTCWrapperObject.Free;
9. end.

The memory leak is still there.

So, imho, there is something not freed in PTCWrapperObject.

Fre;D

[Fred vS]

Hello Roland!

I get it!

The terrorist was inside fpc/src/packages/ptc/src/ptcwrapper/ptcwrapper.pp

Here the code:

Code: Pascal  [Select][+][-]

1. constructor TPTCWrapperThread.Create;
2. begin
3.   FOpen := False;
4.   FNeedsUpdate := False;
5.  
6.   FOpenRequest.Processed := True;
7.   FCloseRequest.Processed := True;
8.   FOptionRequest.Processed := True;
9.   FGetModesRequest.Processed := True;
10.   FMoveMouseToRequest.Processed := True;
11.  
12.   FSurfaceCriticalSection := TCriticalSection.Create; // HUH DONT FORGET IT
13.  
14.   inherited Create(False);
15. end;
16.  
17. ....
18.  
19. destructor TPTCWrapperThread.Destroy;
20. begin
21.   FSurfaceCriticalSection.free; // THIS WAS MISSING
22.   inherited;
23. end;
24.  

Doing this, no more memory leak.

       You have played FREEWARE program NERO 5.
                   Feel free to give it to your friends too!
                          Send your feedback to:
                             <huikari@mit.jyu.fi>
                                       OR
 Jari Huikari, Jenkkakuja 1 B 34, 40520  JKL, FINLAND, EUROPE

Heap dump by heaptrc unit of /home/fred/roland/nero5
3066 memory blocks allocated : 627850/630696
3066 memory blocks freed     : 627850/630696
0 unfreed memory blocks : 0
True heap size : 196608
True free heap : 196608

Included fixed ptcwrapper.pp, just add it in your root directory project.

Fre.D

[circular]

Good job Fred 

[Thaddy]

at least 16777216 values are errors in the test.....

[Roland57]

Congratulations inspector Fred! Excellent job.

at least 16777216 values are errors in the test.....

Sorry, I don't understand. 

[BobDog]

Hi Roland.
For a bit of an experiment converting 32 bit colours to 16 bit (256) colours.
I set up the converting array from freebasic.

Code: Pascal  [Select][+][-]

1.   program To256;
2.  uses
3.  Windows;
4.  
5.      type
6. colour =packed record
7. case integer of
8. 0:(r,g,b:byte);
9. 1:(c:longword);
10. end;
11.  
12.   function SetDCBrushColor(p:hdc;colour:COLORREF): COLORREF; stdcall external 'gdi32.dll' name 'SetDCBrushColor';
13.   function SetDCPenColor(p:hdc;colour:COLORREF): COLORREF; stdcall external 'gdi32.dll' name 'SetDCPenColor';
14.   function closest(v:colour):longword;forward;
15.  
16.    type
17.  circle=object
18.  x:integer;
19.  y:integer ;
20.  r:integer;
21.  c:colour;
22.  procedure draw(h:hdc);
23.  procedure draw256(h:hdc);
24.  end;
25.  
26.  procedure circle.draw(h:hdc) ;
27.  begin
28.   SetDCBrushColor(h,c.c);
29.   SetDCPenColor(h,c.c);
30.  ellipse(h,trunc(x-r)+50,trunc(y-r),trunc(x+r)+50,trunc(y+r));
31.  end;
32.  
33.   procedure circle.draw256(h:hdc) ;
34.  begin
35.   SetDCBrushColor(h,closest(c));
36.   SetDCPenColor(h,closest(c));
37.  ellipse(h,trunc(x-r+400),trunc(y-r),trunc(x+r+400),trunc(y+r));
38.  end;
39.  // constants
40.     const
41.     DC_BRUSH=18;
42.     const
43.     DC_PEN=19;
44.  
45.     const clr:array[0..255] of colour=(
46. (r:0;g:0;b:0),
47. (r:0;g:170;b:0),
48. (r:0;g:0;b:170),
49. (r:0;g:170;b:170),
50. (r:170;g:0;b:0),
51. (r:170;g:170;b:0),
52. (r:170;g:0;b:85),
53. (r:170;g:170;b:170),
54. (r:85;g:85;b:85),
55. (r:85;g:255;b:85),
56. (r:85;g:85;b:255),
57. (r:85;g:255;b:255),
58. (r:255;g:85;b:85),
59. (r:255;g:255;b:85),
60. (r:255;g:85;b:255),
61. (r:255;g:255;b:255),
62. (r:0;g:0;b:0),
63. (r:20;g:20;b:20),
64. (r:32;g:32;b:32),
65. (r:44;g:44;b:44),
66. (r:56;g:56;b:56),
67. (r:68;g:68;b:68),
68. (r:80;g:80;b:80),
69. (r:97;g:97;b:97),
70. (r:113;g:113;b:113),
71. (r:129;g:129;b:129),
72. (r:145;g:145;b:145),
73. (r:161;g:161;b:161),
74. (r:182;g:182;b:182),
75. (r:202;g:202;b:202),
76. (r:226;g:226;b:226),
77. (r:255;g:255;b:255),
78. (r:0;g:255;b:0),
79. (r:64;g:255;b:0),
80. (r:125;g:255;b:0),
81. (r:190;g:255;b:0),
82. (r:255;g:255;b:0),
83. (r:255;g:190;b:0),
84. (r:255;g:125;b:0),
85. (r:255;g:64;b:0),
86. (r:255;g:0;b:0),
87. (r:255;g:0;b:64),
88. (r:255;g:0;b:125),
89. (r:255;g:0;b:190),
90. (r:255;g:0;b:255),
91. (r:190;g:0;b:255),
92. (r:125;g:0;b:255),
93. (r:64;g:0;b:255),
94. (r:0;g:0;b:255),
95. (r:0;g:64;b:255),
96. (r:0;g:125;b:255),
97. (r:0;g:190;b:255),
98. (r:0;g:255;b:255),
99. (r:0;g:255;b:190),
100. (r:0;g:255;b:125),
101. (r:0;g:255;b:64),
102. (r:125;g:255;b:125),
103. (r:157;g:255;b:125),
104. (r:190;g:255;b:125),
105. (r:222;g:255;b:125),
106. (r:255;g:255;b:125),
107. (r:255;g:222;b:125),
108. (r:255;g:190;b:125),
109. (r:255;g:157;b:125),
110. (r:255;g:125;b:125),
111. (r:255;g:125;b:157),
112. (r:255;g:125;b:190),
113. (r:255;g:125;b:222),
114. (r:255;g:125;b:255),
115. (r:222;g:125;b:255),
116. (r:190;g:125;b:255),
117. (r:157;g:125;b:255),
118. (r:125;g:125;b:255),
119. (r:125;g:157;b:255),
120. (r:125;g:190;b:255),
121. (r:125;g:222;b:255),
122. (r:125;g:255;b:255),
123. (r:125;g:255;b:222),
124. (r:125;g:255;b:190),
125. (r:125;g:255;b:157),
126. (r:182;g:255;b:182),
127. (r:198;g:255;b:182),
128. (r:218;g:255;b:182),
129. (r:234;g:255;b:182),
130. (r:255;g:255;b:182),
131. (r:255;g:234;b:182),
132. (r:255;g:218;b:182),
133. (r:255;g:198;b:182),
134. (r:255;g:182;b:182),
135. (r:255;g:182;b:198),
136. (r:255;g:182;b:218),
137. (r:255;g:182;b:234),
138. (r:255;g:182;b:255),
139. (r:234;g:182;b:255),
140. (r:218;g:182;b:255),
141. (r:198;g:182;b:255),
142. (r:182;g:182;b:255),
143. (r:182;g:198;b:255),
144. (r:182;g:218;b:255),
145. (r:182;g:234;b:255),
146. (r:182;g:255;b:255),
147. (r:182;g:255;b:234),
148. (r:182;g:255;b:218),
149. (r:182;g:255;b:198),
150. (r:0;g:113;b:0),
151. (r:28;g:113;b:0),
152. (r:56;g:113;b:0),
153. (r:85;g:113;b:0),
154. (r:113;g:113;b:0),
155. (r:113;g:85;b:0),
156. (r:113;g:56;b:0),
157. (r:113;g:28;b:0),
158. (r:113;g:0;b:0),
159. (r:113;g:0;b:28),
160. (r:113;g:0;b:56),
161. (r:113;g:0;b:85),
162. (r:113;g:0;b:113),
163. (r:85;g:0;b:113),
164. (r:56;g:0;b:113),
165. (r:28;g:0;b:113),
166. (r:0;g:0;b:113),
167. (r:0;g:28;b:113),
168. (r:0;g:56;b:113),
169. (r:0;g:85;b:113),
170. (r:0;g:113;b:113),
171. (r:0;g:113;b:85),
172. (r:0;g:113;b:56),
173. (r:0;g:113;b:28),
174. (r:56;g:113;b:56),
175. (r:68;g:113;b:56),
176. (r:85;g:113;b:56),
177. (r:97;g:113;b:56),
178. (r:113;g:113;b:56),
179. (r:113;g:97;b:56),
180. (r:113;g:85;b:56),
181. (r:113;g:68;b:56),
182. (r:113;g:56;b:56),
183. (r:113;g:56;b:68),
184. (r:113;g:56;b:85),
185. (r:113;g:56;b:97),
186. (r:113;g:56;b:113),
187. (r:97;g:56;b:113),
188. (r:85;g:56;b:113),
189. (r:68;g:56;b:113),
190. (r:56;g:56;b:113),
191. (r:56;g:68;b:113),
192. (r:56;g:85;b:113),
193. (r:56;g:97;b:113),
194. (r:56;g:113;b:113),
195. (r:56;g:113;b:97),
196. (r:56;g:113;b:85),
197. (r:56;g:113;b:68),
198. (r:80;g:113;b:80),
199. (r:89;g:113;b:80),
200. (r:97;g:113;b:80),
201. (r:105;g:113;b:80),
202. (r:113;g:113;b:80),
203. (r:113;g:105;b:80),
204. (r:113;g:97;b:80),
205. (r:113;g:89;b:80),
206. (r:113;g:80;b:80),
207. (r:113;g:80;b:89),
208. (r:113;g:80;b:97),
209. (r:113;g:80;b:105),
210. (r:113;g:80;b:113),
211. (r:105;g:80;b:113),
212. (r:97;g:80;b:113),
213. (r:89;g:80;b:113),
214. (r:80;g:80;b:113),
215. (r:80;g:89;b:113),
216. (r:80;g:97;b:113),
217. (r:80;g:105;b:113),
218. (r:80;g:113;b:113),
219. (r:80;g:113;b:105),
220. (r:80;g:113;b:97),
221. (r:80;g:113;b:89),
222. (r:0;g:64;b:0),
223. (r:16;g:64;b:0),
224. (r:32;g:64;b:0),
225. (r:48;g:64;b:0),
226. (r:64;g:64;b:0),
227. (r:64;g:48;b:0),
228. (r:64;g:32;b:0),
229. (r:64;g:16;b:0),
230. (r:64;g:0;b:0),
231. (r:64;g:0;b:16),
232. (r:64;g:0;b:32),
233. (r:64;g:0;b:48),
234. (r:64;g:0;b:64),
235. (r:48;g:0;b:64),
236. (r:32;g:0;b:64),
237. (r:16;g:0;b:64),
238. (r:0;g:0;b:64),
239. (r:0;g:16;b:64),
240. (r:0;g:32;b:64),
241. (r:0;g:48;b:64),
242. (r:0;g:64;b:64),
243. (r:0;g:64;b:48),
244. (r:0;g:64;b:32),
245. (r:0;g:64;b:16),
246. (r:32;g:64;b:32),
247. (r:40;g:64;b:32),
248. (r:48;g:64;b:32),
249. (r:56;g:64;b:32),
250. (r:64;g:64;b:32),
251. (r:64;g:56;b:32),
252. (r:64;g:48;b:32),
253. (r:64;g:40;b:32),
254. (r:64;g:32;b:32),
255. (r:64;g:32;b:40),
256. (r:64;g:32;b:48),
257. (r:64;g:32;b:56),
258. (r:64;g:32;b:64),
259. (r:56;g:32;b:64),
260. (r:48;g:32;b:64),
261. (r:40;g:32;b:64),
262. (r:32;g:32;b:64),
263. (r:32;g:40;b:64),
264. (r:32;g:48;b:64),
265. (r:32;g:56;b:64),
266. (r:32;g:64;b:64),
267. (r:32;g:64;b:56),
268. (r:32;g:64;b:48),
269. (r:32;g:64;b:40),
270. (r:44;g:64;b:44),
271. (r:48;g:64;b:44),
272. (r:52;g:64;b:44),
273. (r:60;g:64;b:44),
274. (r:64;g:64;b:44),
275. (r:64;g:60;b:44),
276. (r:64;g:52;b:44),
277. (r:64;g:48;b:44),
278. (r:64;g:44;b:44),
279. (r:64;g:44;b:48),
280. (r:64;g:44;b:52),
281. (r:64;g:44;b:60),
282. (r:64;g:44;b:64),
283. (r:60;g:44;b:64),
284. (r:52;g:44;b:64),
285. (r:48;g:44;b:64),
286. (r:44;g:44;b:64),
287. (r:44;g:48;b:64),
288. (r:44;g:52;b:64),
289. (r:44;g:60;b:64),
290. (r:44;g:64;b:64),
291. (r:44;g:64;b:60),
292. (r:44;g:64;b:52),
293. (r:44;g:64;b:48),
294. (r:0;g:0;b:0),
295. (r:0;g:0;b:0),
296. (r:0;g:0;b:0),
297. (r:0;g:0;b:0),
298. (r:0;g:0;b:0),
299. (r:0;g:0;b:0),
300. (r:0;g:0;b:0),
301. (r:0;g:0;b:0));
302.  
303.  
304. function closest(v:colour):longword;
305. function dist(cc:colour;pv:colour):single ;
306. var s:single;
307. begin
308. s:= (cc.r-pv.r)*(cc.r-pv.r) +(cc.g-pv.g)*(cc.g-pv.g)+(cc.b-pv.b)*(cc.b-pv.b) ;
309. exit(s);
310. end;
311. var
312. res:longword;
313. n:longword;
314. dt :single =1e20;
315. distance:single=0;
316.     begin
317.     res:=0;
318.     for n :=0 to 255 do
319.     begin
320.         distance:=dist(clr[n],v);
321.         if (dt > distance) then // catch the smallest
322.          begin
323.            dt := distance;res:=clr[n].c;
324.          end;
325.     end;
326.     exit(res)
327. end;
328.  
329. function rgb(r:byte;g:byte;b:byte):longword;
330. var return:colour;
331. begin
332. return.r:=r;return.g:=g;return.b:=b;
333.  exit(return.c);
334. end;
335.  
336. procedure hidecursor();
337.  var
338.     consoleHandle:handle;
339.      info:CONSOLE_CURSOR_INFO ;
340.      begin
341.      consolehandle := GetStdHandle(STD_OUTPUT_HANDLE);
342.      info.dwSize := 100;
343.      info.bVisible := FALSE ;
344.      SetConsoleCursorInfo(consoleHandle, @info);
345.      End;
346.  
347. procedure setupcircles(var a:array of circle) ;
348. var i:integer;
349. begin
350. for i:=1 to length(a) do
351. begin
352. a[i].x:=5+random(300);
353. a[i].y:=50+random(500);
354. a[i].r:=3+random(10);
355. a[i].c.c:=rgb(random(255),random(255),random(255));
356. end;
357. end;
358.  
359. var
360. p:hwnd;
361. h:hdc;
362. circles:array[1..5000] of circle;
363. i:integer;
364.  
365. begin
366.     p := GetConsoleWindow();
367.     setwindowpos(p, HWND_TOPMOST, 100, 100, 800, 600, SWP_SHOWWINDOW);
368.     hidecursor();
369.     h:=GetDC(p);
370.     setupcircles(circles);
371.     SelectObject(h,GetStockObject(DC_BRUSH));
372.     SelectObject(h,GetStockObject(DC_PEN));
373.     write('         32 bit');
374.     writeln('                                           256 colours');
375.     for i:=1 to length(circles) do circles[i].draw(h);
376.     for i:=1 to length(circles) do circles[i].draw256(h);
377. readln;
378. end.  

I don't suppose it is any good to you, just ignore it, it is a mess around for fun.
I might try it out on a bitmap.

[Roland57]

Hi Roland.
For a bit of an experiment converting 32 bit colours to 16 bit (256) colours.
I set up the converting array from freebasic.

Hi. Thank you for your code. I cannot try it at once (because I am on Linux) but I keep it.