DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / d2df-sdl.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
mempool is optional now
[d2df-sdl.git] / src / game / g_textures.pas
1 (* Copyright (C) DooM 2D:Forever Developers
2 *
3 * This program is free software: you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation, either version 3 of the License, or
6 * (at your option) any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this program. If not, see <http://www.gnu.org/licenses/>.
15 *)
16 {$INCLUDE ../shared/a_modes.inc}
17 unit g_textures;
18
19 interface
20
21 uses
22 SysUtils, Classes,
23 {$IFDEF USE_MEMPOOL}mempool,{$ENDIF}
24 e_graphics, MAPDEF, ImagingTypes, Imaging, ImagingUtility;
25
26 Type
27 TLevelTexture = record
28 TextureName: String;
29 Width,
30 Height: Word;
31 case Anim: Boolean of
32 False: (TextureID: DWORD;);
33 True: (FramesID: DWORD;
34 FramesCount: Byte;
35 Speed: Byte);
36 end;
37
38 TLevelTextureArray = Array of TLevelTexture;
39
40 TAnimation = class{$IFDEF USE_MEMPOOL}(TPoolObject){$ENDIF}
41 private
42 ID: DWORD;
43 FAlpha: Byte;
44 FBlending: Boolean;
45 FCounter: Byte; // Ñ÷åò÷èê îæèäàíèÿ ìåæäó êàäðàìè
46 FSpeed: Byte; // Âðåìÿ îæèäàíèÿ ìåæäó êàäðàìè
47 FCurrentFrame: Integer; // Òåêóùèé êàäð (íà÷èíàÿ ñ 0)
48 FLoop: Boolean; // Ïåðåõîäèòü íà ïåðâûé êàäð ïîñëå ïîñëåäíåãî?
49 FEnabled: Boolean; // Ðàáîòà ðàçðåøåíà?
50 FPlayed: Boolean; // Ïðîèãðàíà âñÿ õîòÿ áû ðàç?
51 FHeight: Word;
52 FWidth: Word;
53 FMinLength: Byte; // Îæèäàíèå ïîñëå ïðîèãðûâàíèÿ
54 FRevert: Boolean; // Ñìåíà êàäðîâ îáðàòíàÿ?
55
56 public
57 constructor Create(FramesID: DWORD; Loop: Boolean; Speed: Byte);
58 destructor Destroy(); override;
59 procedure Draw(X, Y: Integer; Mirror: TMirrorType);
60 procedure DrawEx(X, Y: Integer; Mirror: TMirrorType; RPoint: TDFPoint;
61 Angle: SmallInt);
62 procedure Reset();
63 procedure Update();
64 procedure Enable();
65 procedure Disable();
66 procedure Revert(r: Boolean);
67 procedure SaveState(st: TStream);
68 procedure LoadState(st: TStream);
69 function TotalFrames(): Integer;
70
71 property Played: Boolean read FPlayed;
72 property Enabled: Boolean read FEnabled;
73 property IsReverse: Boolean read FRevert;
74 property Loop: Boolean read FLoop write FLoop;
75 property Speed: Byte read FSpeed write FSpeed;
76 property MinLength: Byte read FMinLength write FMinLength;
77 property CurrentFrame: Integer read FCurrentFrame write FCurrentFrame;
78 property CurrentCounter: Byte read FCounter write FCounter;
79 property Counter: Byte read FCounter;
80 property Blending: Boolean read FBlending write FBlending;
81 property Alpha: Byte read FAlpha write FAlpha;
82 property FramesID: DWORD read ID;
83 property Width: Word read FWidth;
84 property Height: Word read FHeight;
85 end;
86
87 function g_Texture_CreateWAD(var ID: DWORD; Resource: String): Boolean;
88 function g_Texture_CreateFile(var ID: DWORD; FileName: String): Boolean;
89 function g_Texture_CreateWADEx(TextureName: ShortString; Resource: String; altrsrc: AnsiString=''): Boolean;
90 function g_Texture_CreateFileEx(TextureName: ShortString; FileName: String): Boolean;
91 function g_Texture_Get(TextureName: ShortString; var ID: DWORD): Boolean;
92 procedure g_Texture_Delete(TextureName: ShortString);
93 procedure g_Texture_DeleteAll();
94
95 function g_CreateFramesImg (ia: TDynImageDataArray; ID: PDWORD; Name: ShortString; BackAnimation: Boolean = False): Boolean;
96
97 function g_Frames_CreateWAD(ID: PDWORD; Name: ShortString; Resource: String;
98 FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
99 function g_Frames_CreateFile(ID: PDWORD; Name: ShortString; FileName: String;
100 FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
101 function g_Frames_CreateMemory(ID: PDWORD; Name: ShortString; pData: Pointer; dataSize: LongInt;
102 FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
103 function g_Frames_Dup(NewName, OldName: ShortString): Boolean;
104 //function g_Frames_CreateRevert(ID: PDWORD; Name: ShortString; Frames: string): Boolean;
105 function g_Frames_Get(out ID: DWORD; FramesName: ShortString): Boolean;
106 function g_Frames_GetTexture(out ID: DWORD; FramesName: ShortString; Frame: Word): Boolean;
107 function g_Frames_Exists(FramesName: String): Boolean;
108 procedure g_Frames_DeleteByName(FramesName: ShortString);
109 procedure g_Frames_DeleteByID(ID: DWORD);
110 procedure g_Frames_DeleteAll();
111
112 procedure DumpTextureNames();
113
114 function g_Texture_Light(): Integer;
115
116 implementation
117
118 uses
119 g_game, e_log, g_basic, g_console, wadreader,
120 g_language, GL, utils, xstreams;
121
122 type
123 _TTexture = record
124 Name: ShortString;
125 ID: DWORD;
126 Width, Height: Word;
127 end;
128
129 TFrames = record
130 TexturesID: Array of DWORD;
131 Name: ShortString;
132 FrameWidth,
133 FrameHeight: Word;
134 end;
135
136 var
137 TexturesArray: Array of _TTexture = nil;
138 FramesArray: Array of TFrames = nil;
139
140 const
141 ANIM_SIGNATURE = $4D494E41; // 'ANIM'
142
143 function FindTexture(): DWORD;
144 var
145 i: integer;
146 begin
147 if TexturesArray <> nil then
148 for i := 0 to High(TexturesArray) do
149 if TexturesArray[i].Name = '' then
150 begin
151 Result := i;
152 Exit;
153 end;
154
155 if TexturesArray = nil then
156 begin
157 SetLength(TexturesArray, 8);
158 Result := 0;
159 end
160 else
161 begin
162 Result := High(TexturesArray) + 1;
163 SetLength(TexturesArray, Length(TexturesArray) + 8);
164 end;
165 end;
166
167 function g_Texture_CreateWAD(var ID: DWORD; Resource: String): Boolean;
168 var
169 WAD: TWADFile;
170 FileName: String;
171 TextureData: Pointer;
172 ResourceLength: Integer;
173 begin
174 Result := False;
175 FileName := g_ExtractWadName(Resource);
176
177 WAD := TWADFile.Create;
178 WAD.ReadFile(FileName);
179
180 if WAD.GetResource(g_ExtractFilePathName(Resource), TextureData, ResourceLength) then
181 begin
182 if e_CreateTextureMem(TextureData, ResourceLength, ID) then
183 Result := True
184 else
185 FreeMem(TextureData);
186 end
187 else
188 begin
189 e_WriteLog(Format('Error loading texture %s', [Resource]), TMsgType.Warning);
190 //e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
191 end;
192 WAD.Free();
193 end;
194
195 function g_Texture_CreateFile(var ID: DWORD; FileName: String): Boolean;
196 begin
197 Result := True;
198 if not e_CreateTexture(FileName, ID) then
199 begin
200 e_WriteLog(Format('Error loading texture %s', [FileName]), TMsgType.Warning);
201 Result := False;
202 end;
203 end;
204
205 function texture_CreateWADExInternal (TextureName: ShortString; Resource: String; showmsg: Boolean): Boolean;
206 var
207 WAD: TWADFile;
208 FileName: String;
209 TextureData: Pointer;
210 find_id: DWORD;
211 ResourceLength: Integer;
212 begin
213 FileName := g_ExtractWadName(Resource);
214
215 find_id := FindTexture();
216
217 WAD := TWADFile.Create;
218 WAD.ReadFile(FileName);
219
220 if WAD.GetResource(g_ExtractFilePathName(Resource), TextureData, ResourceLength) then
221 begin
222 result := e_CreateTextureMem(TextureData, ResourceLength, TexturesArray[find_id].ID);
223 if result then
224 begin
225 e_GetTextureSize(TexturesArray[find_id].ID, @TexturesArray[find_id].Width, @TexturesArray[find_id].Height);
226 TexturesArray[find_id].Name := LowerCase(TextureName);
227 end
228 else
229 begin
230 FreeMem(TextureData);
231 end;
232 end
233 else
234 begin
235 if showmsg then
236 begin
237 e_WriteLog(Format('Error loading texture %s', [Resource]), TMsgType.Warning);
238 end;
239 //e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
240 result := false;
241 end;
242 WAD.Free();
243 end;
244
245 function g_Texture_CreateWADEx(TextureName: ShortString; Resource: String; altrsrc: AnsiString=''): Boolean;
246 begin
247 if (Length(altrsrc) > 0) then
248 begin
249 result := texture_CreateWADExInternal(TextureName, altrsrc, false);
250 if result then exit;
251 end;
252 result := texture_CreateWADExInternal(TextureName, Resource, true);
253 end;
254
255 function g_Texture_CreateFileEx(TextureName: ShortString; FileName: String): Boolean;
256 var
257 find_id: DWORD;
258 begin
259 find_id := FindTexture;
260
261 Result := e_CreateTexture(FileName, TexturesArray[find_id].ID);
262 if Result then
263 begin
264 TexturesArray[find_id].Name := LowerCase(TextureName);
265 e_GetTextureSize(TexturesArray[find_id].ID, @TexturesArray[find_id].Width,
266 @TexturesArray[find_id].Height);
267 end
268 else e_WriteLog(Format('Error loading texture %s', [FileName]), TMsgType.Warning);
269 end;
270
271 function g_Texture_Get(TextureName: ShortString; var ID: DWORD): Boolean;
272 var
273 a: DWORD;
274 begin
275 Result := False;
276
277 if TexturesArray = nil then Exit;
278
279 if TextureName = '' then Exit;
280
281 TextureName := LowerCase(TextureName);
282
283 for a := 0 to High(TexturesArray) do
284 if TexturesArray[a].Name = TextureName then
285 begin
286 ID := TexturesArray[a].ID;
287 Result := True;
288 Break;
289 end;
290
291 //if not Result then g_ConsoleAdd('Texture '+TextureName+' not found');
292 end;
293
294 procedure g_Texture_Delete(TextureName: ShortString);
295 var
296 a: DWORD;
297 begin
298 if TexturesArray = nil then Exit;
299
300 TextureName := LowerCase(TextureName);
301
302 for a := 0 to High(TexturesArray) do
303 if TexturesArray[a].Name = TextureName then
304 begin
305 e_DeleteTexture(TexturesArray[a].ID);
306 TexturesArray[a].Name := '';
307 TexturesArray[a].ID := 0;
308 TexturesArray[a].Width := 0;
309 TexturesArray[a].Height := 0;
310 end;
311 end;
312
313 procedure g_Texture_DeleteAll();
314 var
315 a: DWORD;
316 begin
317 if TexturesArray = nil then Exit;
318
319 for a := 0 to High(TexturesArray) do
320 if TexturesArray[a].Name <> '' then
321 e_DeleteTexture(TexturesArray[a].ID);
322
323 TexturesArray := nil;
324 end;
325
326 function FindFrame(): DWORD;
327 var
328 i: integer;
329 begin
330 if FramesArray <> nil then
331 for i := 0 to High(FramesArray) do
332 if FramesArray[i].TexturesID = nil then
333 begin
334 Result := i;
335 Exit;
336 end;
337
338 if FramesArray = nil then
339 begin
340 SetLength(FramesArray, 64);
341 Result := 0;
342 end
343 else
344 begin
345 Result := High(FramesArray) + 1;
346 SetLength(FramesArray, Length(FramesArray) + 64);
347 end;
348 end;
349
350 function g_Frames_CreateFile(ID: PDWORD; Name: ShortString; FileName: String;
351 FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
352 var
353 a: Integer;
354 find_id: DWORD;
355 begin
356 Result := False;
357
358 find_id := FindFrame;
359
360 if FCount <= 2 then BackAnimation := False;
361
362 if BackAnimation then SetLength(FramesArray[find_id].TexturesID, FCount+FCount-2)
363 else SetLength(FramesArray[find_id].TexturesID, FCount);
364
365 for a := 0 to FCount-1 do
366 if not e_CreateTextureEx(FileName, FramesArray[find_id].TexturesID[a],
367 a*FWidth, 0, FWidth, FHeight) then Exit;
368
369 if BackAnimation then
370 for a := 1 to FCount-2 do
371 FramesArray[find_id].TexturesID[FCount+FCount-2-a] := FramesArray[find_id].TexturesID[a];
372
373 FramesArray[find_id].FrameWidth := FWidth;
374 FramesArray[find_id].FrameHeight := FHeight;
375 if Name <> '' then
376 FramesArray[find_id].Name := LowerCase(Name)
377 else
378 FramesArray[find_id].Name := '<noname>';
379
380 if ID <> nil then ID^ := find_id;
381
382 Result := True;
383 end;
384
385 function CreateFramesMem(pData: Pointer; dataSize: LongInt; ID: PDWORD; Name: ShortString;
386 FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
387 var
388 find_id: DWORD;
389 a: Integer;
390 begin
391 Result := False;
392
393 find_id := FindFrame();
394
395 if FCount <= 2 then BackAnimation := False;
396
397 if BackAnimation then SetLength(FramesArray[find_id].TexturesID, FCount+FCount-2)
398 else SetLength(FramesArray[find_id].TexturesID, FCount);
399
400 for a := 0 to FCount-1 do
401 if not e_CreateTextureMemEx(pData, dataSize, FramesArray[find_id].TexturesID[a],
402 a*FWidth, 0, FWidth, FHeight) then
403 begin
404 //!!!FreeMem(pData);
405 Exit;
406 end;
407
408 if BackAnimation then
409 for a := 1 to FCount-2 do
410 FramesArray[find_id].TexturesID[FCount+FCount-2-a] := FramesArray[find_id].TexturesID[a];
411
412 FramesArray[find_id].FrameWidth := FWidth;
413 FramesArray[find_id].FrameHeight := FHeight;
414 if Name <> '' then
415 FramesArray[find_id].Name := LowerCase(Name)
416 else
417 FramesArray[find_id].Name := '<noname>';
418
419 if ID <> nil then ID^ := find_id;
420
421 Result := True;
422 end;
423
424 function g_CreateFramesImg (ia: TDynImageDataArray; ID: PDWORD; Name: ShortString; BackAnimation: Boolean = False): Boolean;
425 var
426 find_id: DWORD;
427 a, FCount: Integer;
428 begin
429 result := false;
430 find_id := FindFrame();
431
432 FCount := length(ia);
433
434 //e_WriteLog(Format('+++ creating %d frames [%s]', [FCount, Name]), MSG_NOTIFY);
435
436 if FCount < 1 then exit;
437 if FCount <= 2 then BackAnimation := False;
438 if BackAnimation then
439 SetLength(FramesArray[find_id].TexturesID, FCount+FCount-2)
440 else
441 SetLength(FramesArray[find_id].TexturesID, FCount);
442
443 //e_WriteLog(Format('+++ creating %d frames, %dx%d', [FCount, ia[0].width, ia[0].height]), MSG_NOTIFY);
444
445 for a := 0 to FCount-1 do
446 begin
447 if not e_CreateTextureImg(ia[a], FramesArray[find_id].TexturesID[a]) then exit;
448 //e_WriteLog(Format('+++ frame %d, %dx%d', [a, ia[a].width, ia[a].height]), MSG_NOTIFY);
449 end;
450
451 if BackAnimation then
452 begin
453 for a := 1 to FCount-2 do
454 begin
455 FramesArray[find_id].TexturesID[FCount+FCount-2-a] := FramesArray[find_id].TexturesID[a];
456 end;
457 end;
458
459 FramesArray[find_id].FrameWidth := ia[0].width;
460 FramesArray[find_id].FrameHeight := ia[0].height;
461 if Name <> '' then
462 FramesArray[find_id].Name := LowerCase(Name)
463 else
464 FramesArray[find_id].Name := '<noname>';
465
466 if ID <> nil then ID^ := find_id;
467
468 result := true;
469 end;
470
471 function g_Frames_CreateWAD(ID: PDWORD; Name: ShortString; Resource: string;
472 FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
473 var
474 WAD: TWADFile;
475 FileName: string;
476 TextureData: Pointer;
477 ResourceLength: Integer;
478 begin
479 Result := False;
480
481 // models without "advanced" animations asks for "nothing" like this; don't spam log
482 if (Length(Resource) > 0) and ((Resource[Length(Resource)] = '/') or (Resource[Length(Resource)] = '\')) then exit;
483
484 FileName := g_ExtractWadName(Resource);
485
486 WAD := TWADFile.Create();
487 WAD.ReadFile(FileName);
488
489 if not WAD.GetResource(g_ExtractFilePathName(Resource), TextureData, ResourceLength) then
490 begin
491 WAD.Free();
492 e_WriteLog(Format('Error loading texture %s', [Resource]), TMsgType.Warning);
493 //e_WriteLog(Format('WAD Reader error: %s', [WAD.GetLastErrorStr]), MSG_WARNING);
494 Exit;
495 end;
496
497 if not CreateFramesMem(TextureData, ResourceLength, ID, Name, FWidth, FHeight, FCount, BackAnimation) then
498 begin
499 WAD.Free();
500 Exit;
501 end;
502
503 WAD.Free();
504
505 Result := True;
506 end;
507
508 function g_Frames_CreateMemory(ID: PDWORD; Name: ShortString; pData: Pointer; dataSize: LongInt;
509 FWidth, FHeight, FCount: Word; BackAnimation: Boolean = False): Boolean;
510 begin
511 Result := CreateFramesMem(pData, dataSize, ID, Name, FWidth, FHeight, FCount, BackAnimation);
512 end;
513
514 {function g_Frames_CreateRevert(ID: PDWORD; Name: ShortString; Frames: string): Boolean;
515 var
516 find_id, b: DWORD;
517 a, c: Integer;
518 begin
519 Result := False;
520
521 if not g_Frames_Get(b, Frames) then Exit;
522
523 find_id := FindFrame();
524
525 FramesArray[find_id].Name := Name;
526 FramesArray[find_id].FrameWidth := FramesArray[b].FrameWidth;
527 FramesArray[find_id].FrameHeight := FramesArray[b].FrameHeight;
528
529 c := High(FramesArray[find_id].TexturesID);
530
531 for a := 0 to c do
532 FramesArray[find_id].TexturesID[a] := FramesArray[b].TexturesID[c-a];
533
534 Result := True;
535 end;}
536
537 function g_Frames_Dup(NewName, OldName: ShortString): Boolean;
538 var
539 find_id, b: DWORD;
540 a, c: Integer;
541 begin
542 Result := False;
543
544 if not g_Frames_Get(b, OldName) then Exit;
545
546 find_id := FindFrame();
547
548 FramesArray[find_id].Name := LowerCase(NewName);
549 FramesArray[find_id].FrameWidth := FramesArray[b].FrameWidth;
550 FramesArray[find_id].FrameHeight := FramesArray[b].FrameHeight;
551
552 c := High(FramesArray[b].TexturesID);
553 SetLength(FramesArray[find_id].TexturesID, c+1);
554
555 for a := 0 to c do
556 FramesArray[find_id].TexturesID[a] := FramesArray[b].TexturesID[a];
557
558 Result := True;
559 end;
560
561 procedure g_Frames_DeleteByName(FramesName: ShortString);
562 var
563 a: DWORD;
564 b: Integer;
565 begin
566 if FramesArray = nil then Exit;
567
568 FramesName := LowerCase(FramesName);
569
570 for a := 0 to High(FramesArray) do
571 if FramesArray[a].Name = FramesName then
572 begin
573 if FramesArray[a].TexturesID <> nil then
574 for b := 0 to High(FramesArray[a].TexturesID) do
575 e_DeleteTexture(FramesArray[a].TexturesID[b]);
576 FramesArray[a].TexturesID := nil;
577 FramesArray[a].Name := '';
578 FramesArray[a].FrameWidth := 0;
579 FramesArray[a].FrameHeight := 0;
580 end;
581 end;
582
583 procedure g_Frames_DeleteByID(ID: DWORD);
584 var
585 b: Integer;
586 begin
587 if FramesArray = nil then Exit;
588
589 if FramesArray[ID].TexturesID <> nil then
590 for b := 0 to High(FramesArray[ID].TexturesID) do
591 e_DeleteTexture(FramesArray[ID].TexturesID[b]);
592 FramesArray[ID].TexturesID := nil;
593 FramesArray[ID].Name := '';
594 FramesArray[ID].FrameWidth := 0;
595 FramesArray[ID].FrameHeight := 0;
596 end;
597
598 procedure g_Frames_DeleteAll;
599 var
600 a: DWORD;
601 b: DWORD;
602 begin
603 if FramesArray = nil then Exit;
604
605 for a := 0 to High(FramesArray) do
606 if FramesArray[a].TexturesID <> nil then
607 begin
608 for b := 0 to High(FramesArray[a].TexturesID) do
609 e_DeleteTexture(FramesArray[a].TexturesID[b]);
610 FramesArray[a].TexturesID := nil;
611 FramesArray[a].Name := '';
612 FramesArray[a].FrameWidth := 0;
613 FramesArray[a].FrameHeight := 0;
614 end;
615
616 FramesArray := nil;
617 end;
618
619 function g_Frames_Get(out ID: DWORD; FramesName: ShortString): Boolean;
620 var
621 a: DWORD;
622 begin
623 Result := False;
624
625 if FramesArray = nil then
626 Exit;
627
628 FramesName := LowerCase(FramesName);
629
630 for a := 0 to High(FramesArray) do
631 if FramesArray[a].Name = FramesName then
632 begin
633 ID := a;
634 Result := True;
635 Break;
636 end;
637
638 if not Result then
639 g_FatalError(Format(_lc[I_GAME_ERROR_FRAMES], [FramesName]));
640 end;
641
642 function g_Frames_GetTexture(out ID: DWORD; FramesName: ShortString; Frame: Word): Boolean;
643 var
644 a: DWORD;
645 begin
646 Result := False;
647
648 if FramesArray = nil then
649 Exit;
650
651 FramesName := LowerCase(FramesName);
652
653 for a := 0 to High(FramesArray) do
654 if FramesArray[a].Name = FramesName then
655 if Frame <= High(FramesArray[a].TexturesID) then
656 begin
657 ID := FramesArray[a].TexturesID[Frame];
658 Result := True;
659 Break;
660 end;
661
662 if not Result then
663 g_FatalError(Format(_lc[I_GAME_ERROR_FRAMES], [FramesName]));
664 end;
665
666 function g_Frames_Exists(FramesName: string): Boolean;
667 var
668 a: DWORD;
669 begin
670 Result := False;
671
672 if FramesArray = nil then Exit;
673
674 FramesName := LowerCase(FramesName);
675
676 for a := 0 to High(FramesArray) do
677 if FramesArray[a].Name = FramesName then
678 begin
679 Result := True;
680 Exit;
681 end;
682 end;
683
684 procedure DumpTextureNames();
685 var
686 i: Integer;
687 begin
688 e_WriteLog('BEGIN Textures:', TMsgType.Notify);
689 for i := 0 to High(TexturesArray) do
690 e_WriteLog(' '+IntToStr(i)+'. '+TexturesArray[i].Name, TMsgType.Notify);
691 e_WriteLog('END Textures.', TMsgType.Notify);
692
693 e_WriteLog('BEGIN Frames:', TMsgType.Notify);
694 for i := 0 to High(FramesArray) do
695 e_WriteLog(' '+IntToStr(i)+'. '+FramesArray[i].Name, TMsgType.Notify);
696 e_WriteLog('END Frames.', TMsgType.Notify);
697 end;
698
699 { TAnimation }
700
701 constructor TAnimation.Create(FramesID: DWORD; Loop: Boolean; Speed: Byte);
702 begin
703 ID := FramesID;
704
705 FMinLength := 0;
706 FLoop := Loop;
707 FSpeed := Speed;
708 FEnabled := True;
709 FCurrentFrame := 0;
710 FPlayed := False;
711 FAlpha := 0;
712 FWidth := FramesArray[ID].FrameWidth;
713 FHeight := FramesArray[ID].FrameHeight;
714 end;
715
716 destructor TAnimation.Destroy;
717 begin
718 inherited;
719 end;
720
721 procedure TAnimation.Draw(X, Y: Integer; Mirror: TMirrorType);
722 begin
723 if not FEnabled then
724 Exit;
725
726 e_DrawAdv(FramesArray[ID].TexturesID[FCurrentFrame], X, Y, FAlpha,
727 True, FBlending, 0, nil, Mirror);
728 //e_DrawQuad(X, Y, X+FramesArray[ID].FrameWidth-1, Y+FramesArray[ID].FrameHeight-1, 0, 255, 0);
729 end;
730
731 procedure TAnimation.Update();
732 begin
733 if not FEnabled then
734 Exit;
735
736 FCounter := FCounter + 1;
737
738 if FCounter >= FSpeed then
739 begin // Îæèäàíèå ìåæäó êàäðàìè çàêîí÷èëîñü
740 if FRevert then
741 begin // Îáðàòíûé ïîðÿäîê êàäðîâ
742 // Äîøëè äî êîíöà àíèìàöèè. Âîçìîæíî, æäåì åùå:
743 if FCurrentFrame = 0 then
744 if Length(FramesArray[ID].TexturesID) * FSpeed +
745 FCounter < FMinLength then
746 Exit;
747
748 FCurrentFrame := FCurrentFrame - 1;
749 FPlayed := FCurrentFrame < 0;
750
751 // Ïîâòîðÿòü ëè àíèìàöèþ ïî êðóãó:
752 if FPlayed then
753 if FLoop then
754 FCurrentFrame := High(FramesArray[ID].TexturesID)
755 else
756 FCurrentFrame := FCurrentFrame + 1;
757
758 FCounter := 0;
759 end
760 else
761 begin // Ïðÿìîé ïîðÿäîê êàäðîâ
762 // Äîøëè äî êîíöà àíèìàöèè. Âîçìîæíî, æäåì åùå:
763 if FCurrentFrame = High(FramesArray[ID].TexturesID) then
764 if Length(FramesArray[ID].TexturesID) * FSpeed +
765 FCounter < FMinLength then
766 Exit;
767
768 FCurrentFrame := FCurrentFrame + 1;
769 FPlayed := (FCurrentFrame > High(FramesArray[ID].TexturesID));
770
771 // Ïîâòîðÿòü ëè àíèìàöèþ ïî êðóãó:
772 if FPlayed then
773 if FLoop then
774 FCurrentFrame := 0
775 else
776 FCurrentFrame := FCurrentFrame - 1;
777
778 FCounter := 0;
779 end;
780 end;
781 end;
782
783 procedure TAnimation.Reset();
784 begin
785 if FRevert then
786 FCurrentFrame := High(FramesArray[ID].TexturesID)
787 else
788 FCurrentFrame := 0;
789
790 FCounter := 0;
791 FPlayed := False;
792 end;
793
794 procedure TAnimation.Disable;
795 begin
796 FEnabled := False;
797 end;
798
799 procedure TAnimation.Enable;
800 begin
801 FEnabled := True;
802 end;
803
804 procedure TAnimation.DrawEx(X, Y: Integer; Mirror: TMirrorType; RPoint: TDFPoint;
805 Angle: SmallInt);
806 begin
807 if not FEnabled then
808 Exit;
809
810 e_DrawAdv(FramesArray[ID].TexturesID[FCurrentFrame], X, Y, FAlpha,
811 True, FBlending, Angle, @RPoint, Mirror);
812 end;
813
814 function TAnimation.TotalFrames(): Integer;
815 begin
816 Result := Length(FramesArray[ID].TexturesID);
817 end;
818
819 procedure TAnimation.Revert(r: Boolean);
820 begin
821 FRevert := r;
822 Reset();
823 end;
824
825 procedure TAnimation.SaveState (st: TStream);
826 begin
827 if (st = nil) then exit;
828
829 utils.writeSign(st, 'ANIM');
830 utils.writeInt(st, Byte(0)); // version
831 // Ñ÷åò÷èê îæèäàíèÿ ìåæäó êàäðàìè
832 utils.writeInt(st, Byte(FCounter));
833 // Òåêóùèé êàäð
834 utils.writeInt(st, LongInt(FCurrentFrame));
835 // Ïðîèãðàíà ëè àíèìàöèÿ öåëèêîì
836 utils.writeBool(st, FPlayed);
837 // Alpha-êàíàë âñåé òåêñòóðû
838 utils.writeInt(st, Byte(FAlpha));
839 // Ðàçìûòèå òåêñòóðû
840 utils.writeInt(st, Byte(FBlending));
841 // Âðåìÿ îæèäàíèÿ ìåæäó êàäðàìè
842 utils.writeInt(st, Byte(FSpeed));
843 // Çàöèêëåíà ëè àíèìàöèÿ
844 utils.writeBool(st, FLoop);
845 // Âêëþ÷åíà ëè
846 utils.writeBool(st, FEnabled);
847 // Îæèäàíèå ïîñëå ïðîèãðûâàíèÿ
848 utils.writeInt(st, Byte(FMinLength));
849 // Îáðàòíûé ëè ïîðÿäîê êàäðîâ
850 utils.writeBool(st, FRevert);
851 end;
852
853 procedure TAnimation.LoadState (st: TStream);
854 begin
855 if (st = nil) then exit;
856
857 if not utils.checkSign(st, 'ANIM') then raise XStreamError.Create('animation chunk expected');
858 if (utils.readByte(st) <> 0) then raise XStreamError.Create('invalid animation chunk version');
859 // Ñ÷åò÷èê îæèäàíèÿ ìåæäó êàäðàìè
860 FCounter := utils.readByte(st);
861 // Òåêóùèé êàäð
862 FCurrentFrame := utils.readLongInt(st);
863 // Ïðîèãðàíà ëè àíèìàöèÿ öåëèêîì
864 FPlayed := utils.readBool(st);
865 // Alpha-êàíàë âñåé òåêñòóðû
866 FAlpha := utils.readByte(st);
867 // Ðàçìûòèå òåêñòóðû
868 FBlending := utils.readBool(st);
869 // Âðåìÿ îæèäàíèÿ ìåæäó êàäðàìè
870 FSpeed := utils.readByte(st);
871 // Çàöèêëåíà ëè àíèìàöèÿ
872 FLoop := utils.readBool(st);
873 // Âêëþ÷åíà ëè
874 FEnabled := utils.readBool(st);
875 // Îæèäàíèå ïîñëå ïðîèãðûâàíèÿ
876 FMinLength := utils.readByte(st);
877 // Îáðàòíûé ëè ïîðÿäîê êàäðîâ
878 FRevert := utils.readBool(st);
879 end;
880
881
882 var
883 ltexid: GLuint = 0;
884
885 function g_Texture_Light(): Integer;
886 const
887 Radius: Integer = 128;
888 var
889 tex, tpp: PByte;
890 x, y, a: Integer;
891 dist: Double;
892 begin
893 if ltexid = 0 then
894 begin
895 GetMem(tex, (Radius*2)*(Radius*2)*4);
896 tpp := tex;
897 for y := 0 to Radius*2-1 do
898 begin
899 for x := 0 to Radius*2-1 do
900 begin
901 dist := 1.0-sqrt((x-Radius)*(x-Radius)+(y-Radius)*(y-Radius))/Radius;
902 if (dist < 0) then
903 begin
904 tpp^ := 0; Inc(tpp);
905 tpp^ := 0; Inc(tpp);
906 tpp^ := 0; Inc(tpp);
907 tpp^ := 0; Inc(tpp);
908 end
909 else
910 begin
911 //tc.setPixel(x, y, Color(cast(int)(dist*255), cast(int)(dist*255), cast(int)(dist*255)));
912 if (dist > 0.5) then dist := 0.5;
913 a := round(dist*255);
914 if (a < 0) then a := 0 else if (a > 255) then a := 255;
915 tpp^ := 255; Inc(tpp);
916 tpp^ := 255; Inc(tpp);
917 tpp^ := 255; Inc(tpp);
918 tpp^ := Byte(a); Inc(tpp);
919 end;
920 end;
921 end;
922
923 glGenTextures(1, @ltexid);
924 //if (tid == 0) assert(0, "VGL: can't create screen texture");
925
926 glBindTexture(GL_TEXTURE_2D, ltexid);
927 glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
928 glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);
929 glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
930 glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
931
932 //GLfloat[4] bclr = 0.0;
933 //glTexParameterfv(GL_TEXTURE_2D, GL_TEXTURE_BORDER_COLOR, bclr.ptr);
934
935 glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, Radius*2, Radius*2, 0, GL_RGBA{gltt}, GL_UNSIGNED_BYTE, tex);
936 end;
937
938 result := ltexid;
939 end;
940
941 end.
[MIRROR] a port of Doom 2D Forever to FPC/SDL
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024