1 (* Copyright (C) Doom 2D: Forever Developers
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, version 3 of the License ONLY.
7 * This program is distributed in the hope that it will be useful,
8 * but WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10 * GNU General Public License for more details.
12 * You should have received a copy of the GNU General Public License
13 * along with this program. If not, see <http://www.gnu.org/licenses/>.
15 {$INCLUDE ../../../shared/a_modes.inc}
20 uses r_textures
, r_fonts
, g_player
, g_phys
, g_panel
;
24 BP_LEFTUP
, BP_UP
, BP_RIGHTUP
,
25 BP_LEFT
, BP_CENTER
, BP_RIGHT
,
26 BP_LEFTDOWN
, BP_DOWN
, BP_RIGHTDOWN
40 r_Common_ProcessLoadingCallback
: TProcedure
;
42 procedure r_Common_FreeAndNil (var obj
);
43 procedure r_Common_FreeMemAndNil (var p
);
45 function r_Common_LoadThis (const name
: AnsiString; var here
: THereTexture
): Boolean;
46 procedure r_Common_FreeThis (var here
: THereTexture
);
48 procedure r_Common_CalcAspect (ow
, oh
, nw
, nh
: LongInt; horizontal
: Boolean; out ww
, hh
: LongInt);
50 procedure r_Common_GetBasePoint (x
, y
, w
, h
: Integer; p
: TBasePoint
; out xx
, yy
: Integer);
51 procedure r_Common_DrawText (const text: AnsiString; x
, y
: Integer; r
, g
, b
, a
: Byte; f
: TGLFont
; p
: TBasePoint
);
52 procedure r_Common_DrawTexture (img
: TGLTexture
; x
, y
, w
, h
: Integer; p
: TBasePoint
);
53 procedure r_Common_GetFormatTextSize (const text: AnsiString; f
: TGLFont
; out w
, h
: Integer);
54 procedure r_Common_DrawFormatText (const text: AnsiString; x
, y
: Integer; a
: Byte; f
: TGLFont
; p
: TBasePoint
);
56 function r_Common_TimeToStr (t
: LongWord): AnsiString;
58 procedure r_Common_GetPanelPos (const p
: TPanel
; out x
, y
, w
, h
: Integer);
59 procedure r_Common_GetObjectPos (constref obj
: TObj
; out x
, y
: Integer);
60 procedure r_Common_GetPlayerPos (const p
: TPlayer
; out x
, y
: Integer);
61 procedure r_Common_GetCameraPos (const p
: TPlayer
; center
: Boolean; out x
, y
: Integer);
62 function r_Common_GetPosByUID (uid
: WORD; out obj
: TObj
; out x
, y
: Integer): Boolean;
64 procedure r_Common_DrawBackgroundImage (img
: TGLTexture
);
65 procedure r_Common_DrawBackground (const name
: AnsiString);
67 procedure r_Common_ClearLoading
;
68 procedure r_Common_SetLoading (const text: String; maxval
: Integer);
69 procedure r_Common_StepLoading (incval
: Integer);
70 procedure r_Common_DrawLoading (force
: Boolean);
72 function r_Common_LoadTextureFromFile (const filename
: AnsiString; hints
: TGLHintsSet
; log
: Boolean = True): TGLTexture
;
73 function r_Common_LoadTextureMultiFromFile (const filename
: AnsiString; hints
: TGLHintsSet
; log
: Boolean = True): TGLMultiTexture
;
74 function r_Common_LoadTextureMultiFromFileAndInfo (const filename
: AnsiString; w
, h
, count
: Integer; hints
: TGLHintsSet
; log
: Boolean = True): TGLMultiTexture
;
75 function r_Common_LoadTextureMultiTextFromFile (const filename
: AnsiString; var txt
: TAnimTextInfo
; hints
: TGLHintsSet
; log
: Boolean = True): TGLMultiTexture
;
76 function r_Common_LoadTextureStreamFromFile (const filename
: AnsiString; w
, h
, count
, cw
: Integer; st
: TGLTextureArray
; rs
: TRectArray
; hints
: TGLHintsSet
; log
: Boolean = True): Boolean;
77 function r_Common_LoadTextureFontFromFile (const filename
: AnsiString; constref f
: TFontInfo
; font2enc
: TConvProc
; log
: Boolean = true): TGLFont
;
79 procedure r_Common_Load
;
80 procedure r_Common_Free
;
87 g_base
, g_basic
, g_options
, g_game
, g_map
,
88 {$IFDEF ENABLE_CORPSES}
95 BackgroundTexture
: THereTexture
;
97 procedure r_Common_FreeAndNil (var obj
);
100 temp
:= TObject(obj
);
106 procedure r_Common_FreeMemAndNil (var p
);
115 procedure r_Common_GetPanelPos (const p
: TPanel
; out x
, y
, w
, h
: Integer);
118 if p
.OldMovingActive
then
120 x
:= nlerp(p
.oldX
, p
.x
, gLerpFactor
);
121 y
:= nlerp(p
.oldY
, p
.y
, gLerpFactor
);
122 w
:= nlerp(p
.oldWidth
, p
.width
, gLerpFactor
);
123 h
:= nlerp(p
.oldHeight
, p
.height
, gLerpFactor
);
134 procedure r_Common_GetObjectPos (constref obj
: TObj
; out x
, y
: Integer);
136 x
:= nlerp(obj
.oldx
, obj
.x
, gLerpFactor
);
137 y
:= nlerp(obj
.oldy
, obj
.y
, gLerpFactor
) + obj
.slopeUpLeft
;
140 procedure r_Common_GetPlayerPos (const p
: TPlayer
; out x
, y
: Integer);
143 x
:= nlerp(p
.obj
.oldx
, p
.obj
.x
, gLerpFactor
);
144 y
:= nlerp(p
.obj
.oldy
+ p
.SlopeOld
, p
.obj
.y
+ p
.obj
.slopeUpLeft
, gLerpFactor
);
147 {$IFDEF ENABLE_CORPSES}
148 function r_Common_GetPlayerCorpse (const p
: TPlayer
): TCorpse
;
151 if (p
<> nil) and (p
.Alive
= false) and (p
.Spectator
= false) and (p
.Corpse
>= 0) then
152 if (gCorpses
<> nil) and (gCorpses
[p
.Corpse
] <> nil) and (gCorpses
[p
.Corpse
].PlayerUID
= p
.UID
) then
153 result
:= gCorpses
[p
.Corpse
];
157 procedure r_Common_GetCameraPos (const p
: TPlayer
; center
: Boolean; out x
, y
: Integer);
158 {$IFDEF ENABLE_CORPSES}
162 {$IFDEF ENABLE_CORPSES}
163 corpse
:= r_Common_GetPlayerCorpse(p
);
164 if corpse
<> nil then
166 r_Common_GetObjectPos(corpse
.obj
, x
, y
);
169 x
:= x
+ corpse
.obj
.rect
.width
div 2;
170 y
:= y
+ corpse
.obj
.rect
.height
div 2;
177 r_Common_GetPlayerPos(p
, x
, y
);
178 y
:= y
- nlerp(p
.IncCamOld
, p
.IncCam
, gLerpFactor
);
181 x
:= x
+ p
.obj
.rect
.width
div 2;
182 y
:= y
+ p
.obj
.rect
.height
div 2;
191 x
:= x
+ gMapInfo
.Width
div 2;
192 y
:= y
+ gMapInfo
.Height
div 2;
197 function r_Common_GetPosByUID (uid
: WORD; out obj
: TObj
; out x
, y
: Integer): Boolean;
198 var p
: TPlayer
; found
: Boolean;
201 if g_GetUIDType(uid
) = UID_PLAYER
then
203 p
:= g_Player_Get(uid
);
207 r_Common_GetPlayerPos(p
, x
, y
);
211 else if GetPos(uid
, @obj
) then
214 r_Common_GetObjectPos(obj
, x
, y
);
219 procedure r_Common_GetBasePoint (x
, y
, w
, h
: Integer; p
: TBasePoint
; out xx
, yy
: Integer);
222 TBasePoint
.BP_LEFTUP
, TBasePoint
.BP_LEFT
, TBasePoint
.BP_LEFTDOWN
: xx
:= x
;
223 TBasePoint
.BP_UP
, TBasePoint
.BP_CENTER
, TBasePoint
.BP_DOWN
: xx
:= x
- w
div 2;
224 TBasePoint
.BP_RIGHTUP
, TBasePoint
.BP_RIGHT
, TBasePoint
.BP_RIGHTDOWN
: xx
:= x
- w
;
227 TBasePoint
.BP_LEFTUP
, TBasePoint
.BP_UP
, TBasePoint
.BP_RIGHTUP
: yy
:= y
;
228 TBasePoint
.BP_LEFT
, TBasePoint
.BP_CENTER
, TBasePoint
.BP_RIGHT
: yy
:= y
- h
div 2;
229 TBasePoint
.BP_LEFTDOWN
, TBasePoint
.BP_DOWN
, TBasePoint
.BP_RIGHTDOWN
: yy
:= y
- h
;
233 procedure r_Common_DrawText (const text: AnsiString; x
, y
: Integer; r
, g
, b
, a
: Byte; f
: TGLFont
; p
: TBasePoint
);
234 var xx
, yy
, w
, h
: Integer;
237 if p
<> TBasePoint
.BP_LEFTUP
then
239 r_Draw_GetTextSize(text, f
, w
, h
);
240 r_Common_GetBasePoint(x
, y
, w
, h
, p
, xx
, yy
);
242 r_Draw_Text(text, xx
, yy
, r
, g
, b
, a
, f
);
245 procedure r_Common_DrawTexture (img
: TGLTexture
; x
, y
, w
, h
: Integer; p
: TBasePoint
);
247 r_Common_GetBasePoint(x
, y
, w
, h
, p
, x
, y
);
248 r_Draw_TextureRepeat(img
, x
, y
, w
, h
, false, 255, 255, 255, 255, false);
251 procedure r_Common_GetFormatTextSize (const text: AnsiString; f
: TGLFont
; out w
, h
: Integer);
252 var i
, cw
, ch
, cln
, curw
, curh
, maxw
, maxh
: Integer;
254 curw
:= 0; curh
:= 0; maxw
:= 0; maxh
:= 0;
255 r_Draw_GetTextSize('W', f
, cw
, cln
);
256 for i
:= 1 to Length(text) do
261 maxw
:= MAX(maxw
, curw
);
265 #1, #2, #3, #4, #18, #19, #20, #21:
267 // skip color modifiers
271 r_Draw_GetTextSize(text[i
], f
, cw
, ch
);
272 maxh
:= MAX(maxh
, curh
+ ch
);
277 w
:= MAX(maxw
, curw
);
278 h
:= MAX(maxh
, curh
);
281 procedure r_Common_DrawFormatText (const text: AnsiString; x
, y
: Integer; a
: Byte; f
: TGLFont
; p
: TBasePoint
);
283 colors
: array [boolean, 0..5] of TRGB
= (
284 ((R
:$00; G
:$00; B
:$00), (R
:$FF; G
:$00; B
:$00), (R
:$00; G
:$FF; B
:$00), (R
:$FF; G
:$FF; B
:$00), (R
:$00; G
:$00; B
:$FF), (R
:$FF; G
:$FF; B
:$FF)),
285 ((R
:$00; G
:$00; B
:$00), (R
:$7F; G
:$00; B
:$00), (R
:$00; G
:$7F; B
:$00), (R
:$FF; G
:$7F; B
:$00), (R
:$00; G
:$00; B
:$7F), (R
:$7F; G
:$7F; B
:$7F))
288 i
, xx
, yy
, cx
, cy
, w
, h
, cw
, ch
, cln
, color
: Integer; dark
: Boolean;
291 if p
<> TBasePoint
.BP_LEFTUP
then
293 r_Common_GetFormatTextSize(text, f
, w
, h
);
294 r_Common_GetBasePoint(x
, y
, w
, h
, p
, xx
, yy
);
296 cx
:= xx
; cy
:= yy
; color
:= 5; dark
:= false;
297 r_Draw_GetTextSize('W', f
, cw
, cln
);
298 for i
:= 1 to Length(text) do
316 r_Draw_GetTextSize(text[i
], f
, cw
, ch
);
317 r_Draw_Text(text[i
], cx
, cy
, colors
[dark
, color
].R
, colors
[dark
, color
].G
, colors
[dark
, color
].B
, a
, f
);
324 function r_Common_TimeToStr (t
: LongWord): AnsiString;
325 var h
, m
, s
: Integer;
327 h
:= t
div 1000 div 3600;
328 m
:= t
div 1000 div 60 mod 60;
329 s
:= t
div 1000 mod 60;
330 result
:= Format('%d:%.2d:%.2d', [h
, m
, s
]);
333 (* --------- --------- *)
335 procedure r_Common_FreeThis (var here
: THereTexture
);
338 r_Common_FreeAndNil(here
.id
);
341 function r_Common_LoadThis (const name
: AnsiString; var here
: THereTexture
): Boolean;
343 if name
<> here
.name
then
344 r_Common_FreeThis(here
);
345 if (name
<> '') and (here
.name
<> name
) then
346 here
.id
:= r_Textures_LoadFromFile(name
, []); // !!!
348 result
:= here
.id
<> nil;
354 procedure r_Common_CalcAspect (ow
, oh
, nw
, nh
: LongInt; horizontal
: Boolean; out ww
, hh
: LongInt);
359 hh
:= nw
* oh
div ow
;
363 ww
:= nh
* ow
div oh
;
368 procedure r_Common_DrawBackgroundImage (img
: TGLTexture
);
369 var fw
, w
, h
: LongInt; OldFilter
: Boolean;
373 img
:= BackgroundTexture
.id
;
374 OldFilter
:= img
.filter
;
375 r_Draw_SetFilter(img
, gTextureFilter
);
376 if img
.width
= img
.height
then fw
:= img
.width
* 4 div 3 else fw
:= img
.width
; // fix aspect 4:3
377 r_Common_CalcAspect(fw
, img
.height
, gScreenWidth
, gScreenHeight
, false, w
, h
);
378 r_Draw_Texture(img
, gScreenWidth
div 2 - w
div 2, 0, w
, h
, false, 255, 255, 255, 255, false);
379 r_Draw_SetFilter(img
, OldFilter
);
383 procedure r_Common_DrawBackground (const name
: AnsiString);
385 if r_Common_LoadThis(name
, BackgroundTexture
) then
386 r_Common_DrawBackgroundImage(BackgroundTexture
.id
)
389 function r_Common_Std2Win (i
: Integer): Integer;
392 0..223: result
:= i
+ 32;
393 224..255: result
:= i
- 224;
394 otherwise result
:= -1;
398 function r_Common_LoadFont (const name
: AnsiString): TGLFont
;
399 var info
: TFontInfo
; p
: TConvProc
;
402 if name
= 'STD' then p
:= @r_Common_Std2Win
else p
:= nil;
403 if r_Font_LoadInfoFromFile(GameWad
+ ':FONTS/' + name
+ 'TXT', info
) then
404 result
:= r_Common_LoadTextureFontFromFile(GameWad
+ ':FONTS/' + name
+ 'FONT', info
, p
, true);
406 e_logwritefln('failed to load font %s', [name
]);
409 procedure r_Common_Load
;
411 r_Common_SetLoading('Fonts', 3);
412 menufont
:= r_Common_LoadFont('MENU');
413 smallfont
:= r_Common_LoadFont('SMALL');
414 stdfont
:= r_Common_LoadFont('STD');
415 BackgroundTexture
:= DEFAULT(THereTexture
);
418 procedure r_Common_Free
;
420 r_Common_FreeThis(BackgroundTexture
);
421 FreeAndNil(menufont
);
422 FreeAndNil(smallfont
);
426 (* --------- Loading screen helpers --------- *)
428 procedure r_Common_ProcessLoading
;
430 if @r_Common_ProcessLoadingCallback
<> nil then
431 r_Common_ProcessLoadingCallback
;
434 procedure r_Common_DrawLoading (force
: Boolean);
436 r_LoadScreen_Draw(force
);
437 r_Common_ProcessLoading
;
440 procedure r_Common_ClearLoading
;
443 r_Common_DrawLoading(true);
446 procedure r_Common_SetLoading (const text: String; maxval
: Integer);
448 r_LoadScreen_Set(text, maxval
);
449 r_Common_DrawLoading(true);
452 procedure r_Common_StepLoading (incval
: Integer);
454 r_LoadScreen_Step(incval
);
455 r_Common_DrawLoading(false);
458 function r_Common_LoadTextureFromFile (const filename
: AnsiString; hints
: TGLHintsSet
; log
: Boolean = True): TGLTexture
;
460 result
:= r_Textures_LoadFromFile(filename
, hints
, log
);
461 r_Common_StepLoading(1);
464 function r_Common_LoadTextureMultiFromFile (const filename
: AnsiString; hints
: TGLHintsSet
; log
: Boolean = True): TGLMultiTexture
;
466 result
:= r_Textures_LoadMultiFromFile(filename
, hints
, log
);
467 r_Common_StepLoading(1);
470 function r_Common_LoadTextureMultiFromFileAndInfo (const filename
: AnsiString; w
, h
, count
: Integer; hints
: TGLHintsSet
; log
: Boolean = True): TGLMultiTexture
;
472 result
:= r_Textures_LoadMultiFromFileAndInfo(filename
, w
, h
, count
, hints
, log
);
473 r_Common_StepLoading(1);
476 function r_Common_LoadTextureMultiTextFromFile (const filename
: AnsiString; var txt
: TAnimTextInfo
; hints
: TGLHintsSet
; log
: Boolean = True): TGLMultiTexture
;
478 result
:= r_Textures_LoadMultiTextFromFile(filename
, txt
, hints
, log
);
479 r_Common_StepLoading(1);
482 function r_Common_LoadTextureStreamFromFile (const filename
: AnsiString; w
, h
, count
, cw
: Integer; st
: TGLTextureArray
; rs
: TRectArray
; hints
: TGLHintsSet
; log
: Boolean = True): Boolean;
484 result
:= r_Textures_LoadStreamFromFile(filename
, w
, h
, count
, cw
, st
, rs
, hints
, log
);
485 r_Common_StepLoading(1);
488 function r_Common_LoadTextureFontFromFile (const filename
: AnsiString; constref f
: TFontInfo
; font2enc
: TConvProc
; log
: Boolean = true): TGLFont
;
490 result
:= r_Textures_LoadFontFromFile (filename
, f
, font2enc
, log
);
491 r_Common_StepLoading(1);