← Back to branch summary

~ubuntu-branches/ubuntu/lucid/fpc/lucid-proposed

« back to all changes in this revision

Viewing changes to fpcsrc/packages/extra/ptc/win32/directx/primary.inc

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-10-09 23:29:00 UTC
  • mfrom: (4.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20081009232900-553f61m37jkp6upv
Tags: 2.2.2-4
http://bugs.debian.org/498882
[ Torsten Werner ]
* Update ABI version in fpc-depends automatically.
* Remove empty directories from binary package fpc-source.

[ Mazen Neifer ]
* Removed leading path when calling update-alternatives to remove a Linitian
  error.
* Fixed clean target.
* Improved description of packages. (Closes: #498882)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/extra/ptc/win32/directx/primary.inc
1
 
{
2
 
    Free Pascal port of the OpenPTC C++ library.
3
 
    Copyright (C) 2001-2003  Nikolay Nikolov (nickysn@users.sourceforge.net)
4
 
    Original C++ version by Glenn Fiedler (ptc@gaffer.org)
5
 
 
6
 
    This library is free software; you can redistribute it and/or
7
 
    modify it under the terms of the GNU Lesser General Public
8
 
    License as published by the Free Software Foundation; either
9
 
    version 2.1 of the License, or (at your option) any later version.
10
 
 
11
 
    This library is distributed in the hope that it will be useful,
12
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
13
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14
 
    Lesser General Public License for more details.
15
 
 
16
 
    You should have received a copy of the GNU Lesser General Public
17
 
    License along with this library; if not, write to the Free Software
18
 
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
19
 
}
20
 
 
21
 
Constructor TDirectXPrimary.Create;
22
 
 
23
 
Begin
24
 
  m_area := Nil;
25
 
  m_clip := Nil;
26
 
  m_format := Nil;
27
 
  m_clear := Nil;
28
 
  m_palette := Nil;
29
 
  m_area := TPTCArea.Create;
30
 
  m_clip := TPTCArea.Create;
31
 
  m_format := TPTCFormat.Create;
32
 
  m_clear := TPTCClear.Create;
33
 
  m_palette := TPTCPalette.Create;
34
 
 
35
 
  m_locked := Nil;
36
 
  m_window := Nil;
37
 
  m_width := 0;
38
 
  m_height := 0;
39
 
  m_back := Nil;
40
 
  m_front := Nil;
41
 
  m_pages := 0;
42
 
  m_lpDD2 := Nil;
43
 
  m_lpDDC := Nil;
44
 
  m_lpDDS_primary := Nil;
45
 
  m_lpDDS_primary_back := Nil;
46
 
  m_lpDDS_secondary := Nil;
47
 
  m_active := True;
48
 
  m_blocking := True;
49
 
  m_centering := True;
50
 
  m_synchronize := True;
51
 
  m_fullscreen := False;
52
 
  m_primary_width := 0;
53
 
  m_primary_height := 0;
54
 
  m_secondary_width := 0;
55
 
  m_secondary_height := 0;
56
 
  FillChar(m_lpDDS_primary_page, SizeOf(m_lpDDS_primary_page), 0);
57
 
End;
58
 
 
59
 
Destructor TDirectXPrimary.Destroy;
60
 
 
61
 
Begin
62
 
  { close }
63
 
  close;
64
 
  m_area.Free;
65
 
  m_clip.Free;
66
 
  m_format.Free;
67
 
  m_clear.Free;
68
 
  m_palette.Free;
69
 
  Inherited Destroy;
70
 
End;
71
 
 
72
 
Procedure TDirectXPrimary.initialize(window : TWin32Window; lpDD2 : LPDIRECTDRAW2);
73
 
 
74
 
Begin
75
 
  LOG('initializing primary surface');
76
 
  close;
77
 
  m_window := window;
78
 
  m_lpDD2 := lpDD2;
79
 
End;
80
 
 
81
 
Procedure TDirectXPrimary.primary(_pages : Integer; video, fullscreen, _palette, complex : Boolean);
82
 
 
83
 
Var
84
 
  attach_primary_pages : Boolean;
85
 
  descriptor : DDSURFACEDESC;
86
 
  ddpf : DDPIXELFORMAT;
87
 
  capabilities : DDSCAPS;
88
 
  tmp : TPTCPalette;
89
 
  i : Integer;
90
 
  rectangle : RECT;
91
 
 
92
 
Begin
93
 
  Try
94
 
    LOG('creating primary surface');
95
 
    LOG('pages', _pages);
96
 
    LOG('video', video);
97
 
    LOG('fullscreen', fullscreen);
98
 
    LOG('palette', _palette);
99
 
    LOG('complex', complex);
100
 
    If _pages <= 0 Then
101
 
      Raise TPTCError.Create('invalid number of pages');
102
 
    m_fullscreen := fullscreen;
103
 
    attach_primary_pages := False;
104
 
    If complex Or (Not _palette) Or (_pages = 1) Then
105
 
    Begin
106
 
      LOG('creating a complex primary flipping surface');
107
 
      FillChar(descriptor, SizeOf(descriptor), 0);
108
 
      descriptor.dwSize := SizeOf(descriptor);
109
 
      descriptor.dwFlags := DDSD_CAPS;
110
 
      If _pages > 1 Then
111
 
        descriptor.dwFlags := descriptor.dwFlags Or DDSD_BACKBUFFERCOUNT;
112
 
      descriptor.dwBackBufferCount := _pages - 1;
113
 
      descriptor.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
114
 
      If video Then
115
 
        descriptor.ddsCaps.dwCaps := descriptor.ddsCaps.dwCaps Or DDSCAPS_VIDEOMEMORY;
116
 
      If _pages > 1 Then
117
 
        descriptor.ddsCaps.dwCaps := descriptor.ddsCaps.dwCaps Or DDSCAPS_COMPLEX Or DDSCAPS_FLIP;
118
 
      DirectXCheck(m_lpDD2^.lpVtbl^.CreateSurface(m_lpDD2, @descriptor, @m_lpDDS_primary, Nil), 'm_lpDD2^.CreateSurface failed in TDirectXPrimary.primary');
119
 
    End
120
 
    Else
121
 
    Begin
122
 
      LOG('creating a simple primary surface');
123
 
      FillChar(descriptor, SizeOf(descriptor), 0);
124
 
      descriptor.dwSize := SizeOf(descriptor);
125
 
      descriptor.dwFlags := DDSD_CAPS;
126
 
      descriptor.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
127
 
      If video Then
128
 
        descriptor.ddsCaps.dwCaps := descriptor.ddsCaps.dwCaps Or DDSCAPS_VIDEOMEMORY;
129
 
      DirectXCheck(m_lpDD2^.lpVtbl^.CreateSurface(m_lpDD2, @descriptor, @m_lpDDS_primary, Nil), 'm_lpDD2^.CreateSurface failed in TDirectXPrimary.primary (palette)');
130
 
      attach_primary_pages := True;
131
 
    End;
132
 
    FillChar(descriptor, SizeOf(descriptor), 0);
133
 
    descriptor.dwSize := SizeOf(descriptor);
134
 
    DirectXCheck(m_lpDDS_primary^.lpVtbl^.GetSurfaceDesc(m_lpDDS_primary, @descriptor), 'm_lpDDS_primary^.GetSurfaceDesc failed in TDirectXPrimary.primary');
135
 
    If (descriptor.ddsCaps.dwCaps And DDSCAPS_VIDEOMEMORY) <> 0 Then
136
 
    Begin
137
 
      LOG('primary surface is in video memory');
138
 
    End
139
 
    Else
140
 
    Begin
141
 
      LOG('primary surface is in system memory');
142
 
    End;
143
 
    FillChar(ddpf, SizeOf(ddpf), 0);
144
 
    ddpf.dwSize := SizeOf(ddpf);
145
 
    DirectXCheck(m_lpDDS_primary^.lpVtbl^.GetPixelFormat(m_lpDDS_primary, @ddpf), 'm_lpDDS_primary^.GetPixelFormat failed in TDirectXPrimary.primary');
146
 
    m_front := m_lpDDS_primary;
147
 
    m_pages := _pages;
148
 
    m_width := descriptor.dwWidth;
149
 
    m_height := descriptor.dwHeight;
150
 
    FreeAndNil(m_format);
151
 
    m_format := DirectXTranslate(ddpf);
152
 
    LOG('primary width', m_width);
153
 
    LOG('primary height', m_height);
154
 
    LOG('primary pages', m_pages);
155
 
    LOG('primary format', m_format);
156
 
    If _palette Then
157
 
    Begin
158
 
      LOG('clearing primary palette');
159
 
      tmp := TPTCPalette.Create;
160
 
      Try
161
 
        palette(tmp);
162
 
      Finally
163
 
        tmp.Free;
164
 
      End;
165
 
    End;
166
 
    If attach_primary_pages Then
167
 
    Begin
168
 
      If (_pages - 1) > High(m_lpDDS_primary_page) Then
169
 
        Raise TPTCError.Create('too many primary pages');
170
 
      For i := 0 To _pages - 2 Do
171
 
      Begin
172
 
        LOG('creating primary page surface');
173
 
        FillChar(descriptor, SizeOf(descriptor), 0);
174
 
        descriptor.dwSize := SizeOf(descriptor);
175
 
        descriptor.dwFlags := DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT;
176
 
        descriptor.dwWidth := m_width;
177
 
        descriptor.dwHeight := m_height;
178
 
        descriptor.ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
179
 
        If video Then
180
 
          descriptor.ddsCaps.dwCaps := descriptor.ddsCaps.dwCaps Or DDSCAPS_VIDEOMEMORY;
181
 
        DirectXCheck(m_lpDD2^.lpVtbl^.CreateSurface(m_lpDD2, @descriptor, @m_lpDDS_primary_page[i], Nil), 'm_lpDD2^.CreateSurface failed in TDirectXPrimary.primary (primary page)');
182
 
 
183
 
        FillChar(descriptor, SizeOf(descriptor), 0);
184
 
        descriptor.dwSize := SizeOf(descriptor);
185
 
        DirectXCheck(m_lpDDS_primary_page[i]^.lpVtbl^.GetSurfaceDesc(m_lpDDS_primary_page[i], @descriptor), 'm_lpDDS_primary_page^.GetSurfaceDesc failed in TDirectXPrimary.primary');
186
 
 
187
 
        If (descriptor.ddsCaps.dwCaps And DDSCAPS_VIDEOMEMORY) <> 0 Then
188
 
        Begin
189
 
          LOG('primary surface page is in video memory');
190
 
        End
191
 
        Else
192
 
        Begin
193
 
          LOG('primary surface page is in system memory');
194
 
        End;
195
 
        LOG('attaching page to primary surface');
196
 
        DirectXCheck(m_lpDDS_primary^.lpVtbl^.AddAttachedSurface(m_lpDDS_primary, m_lpDDS_primary_page[i]), 'm_lpDDS_primary^.AddAttachedSurface failed in TDirectXPrimary.primary');
197
 
      End;
198
 
    End;
199
 
    m_primary_width := m_width;
200
 
    m_primary_height := m_height;
201
 
    If Not fullscreen Then
202
 
    Begin
203
 
      GetClientRect(m_window.handle, rectangle);
204
 
      m_width := rectangle.right;
205
 
      m_height := rectangle.bottom;
206
 
    End;
207
 
    FreeAndNil(m_area);
208
 
    m_area := TPTCArea.Create(0, 0, m_width, m_height);
209
 
    FreeAndNil(m_clip);
210
 
    m_clip := TPTCArea.Create(m_area);
211
 
    If _pages > 1 Then
212
 
    Begin
213
 
      capabilities.dwCaps := DDSCAPS_BACKBUFFER;
214
 
      DirectXCheck(m_front^.lpVtbl^.GetAttachedSurface(m_front, @capabilities, @m_lpDDS_primary_back), 'm_front^.GetAttachedSurface failed in TDirectXPrimary.primary');
215
 
 
216
 
      FillChar(descriptor, SizeOf(descriptor), 0);
217
 
      descriptor.dwSize := SizeOf(descriptor);
218
 
      DirectXCheck(m_lpDDS_primary_back^.lpVtbl^.GetSurfaceDesc(m_lpDDS_primary_back, @descriptor), 'm_lpDDS_primary_back^.GetSurfaceDesc failed in TDirectXPrimary.primary');
219
 
 
220
 
      If (descriptor.ddsCaps.dwCaps And DDSCAPS_VIDEOMEMORY) <> 0 Then
221
 
      Begin
222
 
        LOG('primary back surface is in video memory');
223
 
      End
224
 
      Else
225
 
      Begin
226
 
        LOG('primary back surface is in system memory');
227
 
      End;
228
 
    End
229
 
    Else
230
 
      m_lpDDS_primary_back := m_front;
231
 
    m_back := m_lpDDS_primary_back;
232
 
    If fullscreen Then
233
 
      While _pages > 0 Do
234
 
      Begin
235
 
        Dec(_pages);
236
 
        LOG('clearing primary page');
237
 
        clear;
238
 
        update;
239
 
      End;
240
 
  Except
241
 
    On error : TPTCError Do
242
 
    Begin
243
 
      If m_lpDDS_primary <> Nil Then
244
 
      Begin
245
 
        m_lpDDS_primary^.lpVtbl^.Release(m_lpDDS_primary);
246
 
        m_lpDDS_primary := Nil;
247
 
      End;
248
 
      Raise TPTCError.Create('could not create primary surface', error);
249
 
    End;
250
 
  End;
251
 
End;
252
 
 
253
 
Procedure TDirectXPrimary.secondary(_width, _height : Integer);
254
 
 
255
 
Var
256
 
  descriptor : DDSURFACEDESC;
257
 
  hel : DDCAPS;
258
 
  driver : DDCAPS;
259
 
  capabilities : DDSCAPS;
260
 
 
261
 
Begin
262
 
  LOG('creating secondary surface');
263
 
  LOG('width', _width);
264
 
  LOG('height', _height);
265
 
  FillChar(descriptor, SizeOf(descriptor), 0);
266
 
  descriptor.dwSize := SizeOf(descriptor);
267
 
  descriptor.dwFlags := DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH;
268
 
  descriptor.ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
269
 
  descriptor.dwHeight := _height;
270
 
  descriptor.dwWidth := _width;
271
 
  DirectXCheck(m_lpDD2^.lpVtbl^.CreateSurface(m_lpDD2, @descriptor, @m_lpDDS_secondary, Nil), 'm_lpDD2^.CreateSurface failed in TDirectXPrimary.secondary');
272
 
 
273
 
  FillChar(descriptor, SizeOf(descriptor), 0);
274
 
  descriptor.dwSize := SizeOf(descriptor);
275
 
  DirectXCheck(m_lpDDS_secondary^.lpVtbl^.GetSurfaceDesc(m_lpDDS_secondary, @descriptor), 'm_lpDDS_secondary^.GetSurfaceDesc failed in TDirectXPrimary.secondary');
276
 
 
277
 
  If (descriptor.ddsCaps.dwCaps And DDSCAPS_VIDEOMEMORY) <> 0 Then
278
 
  Begin
279
 
    LOG('secondary surface is in video memory');
280
 
  End
281
 
  Else
282
 
  Begin
283
 
    LOG('secondary surface is in system memory');
284
 
  End;
285
 
 
286
 
  If Not m_fullscreen Then
287
 
  Begin
288
 
    LOG('attaching clipper to primary surface');
289
 
    DirectXCheck(m_lpDD2^.lpVtbl^.CreateClipper(m_lpDD2, 0, @m_lpDDC, Nil), 'm_lpDD2^.CreateClipper failed in TDirectXPrimary.secondary');
290
 
    DirectXCheck(m_lpDDC^.lpVtbl^.SetHWnd(m_lpDDC, 0, m_window.handle), 'm_lpDDC^.SetHWnd failed in TDirectXPrimary.secondary');
291
 
    DirectXCheck(m_lpDDS_primary^.lpVtbl^.SetClipper(m_lpDDS_primary, m_lpDDC), 'm_lpDDS_primary^.SetClipper failed in TDirectXPrimary.secondary');
292
 
  End;
293
 
  m_width := _width;
294
 
  m_height := _height;
295
 
  FreeAndNil(m_area);
296
 
  m_area := TPTCArea.Create(0, 0, m_width, m_height);
297
 
  FreeAndNil(m_clip);
298
 
  m_clip := TPTCArea.Create(m_area);
299
 
  m_secondary_width := m_width;
300
 
  m_secondary_height := m_height;
301
 
  m_back := m_lpDDS_secondary;
302
 
 
303
 
{  hel.dwSize := SizeOf(hel);
304
 
  driver.dwSize := SizeOf(driver);
305
 
  DirectXCheck(m_lpDD2^.GetCaps(@driver, @hel));}
306
 
  {
307
 
    auto stretching support is disabled below because in almost 100% of cases
308
 
    centering is faster and we must choose the fastest option by default!
309
 
  }
310
 
  {todo: DDCAPS!!!!!!!!!!!}
311
 
{  If ((driver.dwCaps And DDCAPS_BLTSTRETCH) <> 0) And
312
 
     ((driver.dwFXCaps And DDFXCAPS_BLTSTRETCHY) <> 0) Then
313
 
  Begin
314
 
    LOG('found hardware stretching support');
315
 
  End
316
 
  Else
317
 
  Begin
318
 
    LOG('no hardware stretching support');
319
 
  End;}
320
 
 
321
 
  m_lpDDS_secondary^.lpVtbl^.GetCaps(m_lpDDS_secondary, @capabilities);
322
 
  If (capabilities.dwCaps And DDSCAPS_SYSTEMMEMORY) <> 0 Then
323
 
  Begin
324
 
    LOG('secondary surface is in system memory');
325
 
  End;
326
 
 
327
 
  centering(True);
328
 
 
329
 
  LOG('clearing secondary page');
330
 
 
331
 
  clear;
332
 
 
333
 
  update;
334
 
End;
335
 
 
336
 
Procedure TDirectXPrimary.synchronize(_update : Boolean);
337
 
 
338
 
Begin
339
 
  m_synchronize := _update;
340
 
  If m_pages > 1 Then
341
 
    m_synchronize := False;
342
 
  LOG('primary synchronize', _update);
343
 
End;
344
 
 
345
 
Procedure TDirectXPrimary.centering(center : Boolean);
346
 
 
347
 
Begin
348
 
  m_centering := center;
349
 
  LOG('primary centering', m_centering);
350
 
End;
351
 
 
352
 
Procedure TDirectXPrimary.close;
353
 
 
354
 
Var
355
 
  i : Integer;
356
 
  lost : Boolean;
357
 
  tmp : TPTCPalette;
358
 
 
359
 
Begin
360
 
  Try
361
 
    LOG('closing primary surface');
362
 
    lost := False;
363
 
    If (m_lpDDS_primary <> Nil) And (m_lpDDS_primary^.lpVtbl^.IsLost(m_lpDDS_primary) <> DD_OK) Then
364
 
      lost := True;
365
 
    If (m_lpDDS_secondary <> Nil) And (m_lpDDS_secondary^.lpVtbl^.IsLost(m_lpDDS_secondary) <> DD_OK) Then
366
 
      lost := True;
367
 
    If (m_back <> Nil) And (m_lpDDS_primary <> Nil) And m_fullscreen And (Not lost) Then
368
 
    Begin
369
 
      tmp := TPTCPalette.Create;
370
 
      Try
371
 
        LOG('clearing primary palette');
372
 
        palette(tmp);
373
 
      Finally
374
 
        tmp.Free;
375
 
      End;
376
 
      LOG('clearing primary pages');
377
 
      For i := 0 To m_pages - 1 Do
378
 
      Begin
379
 
        clear;
380
 
        update;
381
 
      End;
382
 
    End;
383
 
  Except
384
 
    On TPTCError Do
385
 
    Begin
386
 
      LOG('primary close clearing failed');
387
 
    End;
388
 
  End;
389
 
 
390
 
  If m_lpDDC <> Nil Then
391
 
  Begin
392
 
    LOG('releasing clipper');
393
 
    m_lpDDC^.lpVtbl^.Release(m_lpDDC);
394
 
    m_lpDDC := Nil;
395
 
  End;
396
 
  If m_lpDDS_secondary <> Nil Then
397
 
  Begin
398
 
    LOG('releasing secondary surface');
399
 
    m_lpDDS_secondary^.lpVtbl^.Release(m_lpDDS_secondary);
400
 
    m_lpDDS_secondary := Nil;
401
 
  End;
402
 
  i := 0;
403
 
  While m_lpDDS_primary_page[i] <> Nil Do
404
 
  Begin
405
 
    LOG('releasing attached primary surface page');
406
 
    m_lpDDS_primary_page[i]^.lpVtbl^.Release(m_lpDDS_primary_page[i]);
407
 
    m_lpDDS_primary_page[i] := Nil;
408
 
    Inc(i);
409
 
  End;
410
 
  If m_lpDDS_primary <> Nil Then
411
 
  Begin
412
 
    LOG('releasing primary surface');
413
 
    m_lpDDS_primary^.lpVtbl^.Release(m_lpDDS_primary);
414
 
    m_lpDDS_primary := Nil;
415
 
  End;
416
 
 
417
 
  m_back := Nil;
418
 
  m_front := Nil;
419
 
  m_lpDDS_primary_back := Nil;
420
 
End;
421
 
 
422
 
Procedure TDirectXPrimary.update;
423
 
 
424
 
Begin
425
 
  block;
426
 
  paint;
427
 
  If m_pages > 1 Then
428
 
    DirectXCheck(m_front^.lpVtbl^.Flip(m_front, Nil, DDFLIP_WAIT), 'm_front^.Flip failed in TDirectXPrimary.update');
429
 
End;
430
 
 
431
 
Function TDirectXPrimary.lock : Pointer;
432
 
 
433
 
Var
434
 
  descriptor : DDSURFACEDESC;
435
 
  pnt : POINT;
436
 
  rct : RECT;
437
 
 
438
 
Begin
439
 
  block;
440
 
  descriptor.dwSize := SizeOf(descriptor);
441
 
  If m_fullscreen Or (m_back = m_lpDDS_secondary) Then
442
 
  Begin
443
 
    DirectXCheck(m_back^.lpVtbl^.Lock(m_back, Nil, @descriptor, DDLOCK_WAIT, 0), 'm_back^.Lock failed in TDirectXPrimary.lock');
444
 
    m_locked := descriptor.lpSurface;
445
 
  End
446
 
  Else
447
 
  Begin
448
 
    pnt.x := 0;
449
 
    pnt.y := 0;
450
 
    ClientToScreen(m_window.handle, pnt);
451
 
    rct.left := pnt.x;
452
 
    rct.top := pnt.y;
453
 
    rct.right := pnt.x + m_width;
454
 
    rct.bottom := pnt.y + m_height;
455
 
    DirectXCheck(m_back^.lpVtbl^.Lock(m_back, @rct, @descriptor, DDLOCK_WAIT, 0), 'm_back^.Lock(rect) failed in TDirectXPrimary.lock');
456
 
    m_locked := descriptor.lpSurface;
457
 
  End;
458
 
  lock := m_locked;
459
 
End;
460
 
 
461
 
Procedure TDirectXPrimary.unlock;
462
 
 
463
 
Begin
464
 
  block;
465
 
  DirectXCheck(m_back^.lpVtbl^.Unlock(m_back, m_locked), 'm_back^.Unlock failed in TDirectXPrimary.unlock');
466
 
End;
467
 
 
468
 
Procedure TDirectXPrimary.clear;
469
 
 
470
 
Var
471
 
  fx : DDBLTFX;
472
 
  tmp : TPTCColor;
473
 
 
474
 
Begin
475
 
  block;
476
 
  If m_fullscreen Or (m_back = m_lpDDS_secondary) Then
477
 
  Begin
478
 
    fx.dwSize := SizeOf(fx);
479
 
    fx.dwFillColor := 0;
480
 
    DirectXCheck(m_back^.lpVtbl^.Blt(m_back, Nil, Nil, Nil, DDBLT_COLORFILL Or DDBLT_WAIT, @fx), 'm_back^.Blt failed in TDirectXPrimary.clear');
481
 
  End
482
 
  Else
483
 
  Begin
484
 
    { todo: replace with hardware clear! }
485
 
    If format.direct Then
486
 
    Begin
487
 
      tmp := TPTCColor.Create(0, 0, 0, 0);
488
 
      Try
489
 
        clear(tmp, m_area);
490
 
      Finally
491
 
        tmp.Free;
492
 
      End;
493
 
    End
494
 
    Else
495
 
    Begin
496
 
      tmp := TPTCColor.Create(0);
497
 
      Try
498
 
        clear(tmp, m_area);
499
 
      Finally
500
 
        tmp.Free;
501
 
      End;
502
 
    End;
503
 
  End;
504
 
End;
505
 
 
506
 
Procedure TDirectXPrimary.clear(Const color : TPTCColor; Const _area : TPTCArea);
507
 
 
508
 
Var
509
 
  clipped, clipped_area : TPTCArea;
510
 
  clear_color : DWord;
511
 
  rct : RECT;
512
 
  fx : DDBLTFX;
513
 
  pixels : Pointer;
514
 
 
515
 
 
516
 
Begin
517
 
  block;
518
 
  If m_fullscreen Or (m_back = m_lpDDS_secondary) Then
519
 
  Begin
520
 
    clipped := TPTCClipper.clip(_area, m_clip);
521
 
    Try
522
 
      clear_color := pack(color, m_format);
523
 
      With rct Do
524
 
      Begin
525
 
        left := clipped.left;
526
 
        top := clipped.top;
527
 
        right := clipped.right;
528
 
        bottom := clipped.bottom;
529
 
      End;
530
 
      fx.dwSize := SizeOf(fx);
531
 
      fx.dwFillColor := clear_color;
532
 
      DirectXCheck(m_back^.lpVtbl^.Blt(m_back, @rct, Nil, Nil, DDBLT_COLORFILL Or DDBLT_WAIT, @fx), 'm_back^.Blt(rect) failed in TDirectXPrimary.clear');
533
 
    Finally
534
 
      clipped.Free;
535
 
    End;
536
 
  End
537
 
  Else
538
 
  Begin
539
 
    { todo: replace with accelerated clearing code! }
540
 
    pixels := lock;
541
 
    clipped_area := Nil;
542
 
    Try
543
 
      Try
544
 
        clipped_area := TPTCClipper.clip(_area, clip);
545
 
        m_clear.request(format);
546
 
        m_clear.clear(pixels, clipped_area.left, clipped_area.right, clipped_area.width, clipped_area.height, pitch, color);
547
 
        unlock;
548
 
      Except
549
 
        On error : TPTCError Do
550
 
        Begin
551
 
          unlock;
552
 
          Raise TPTCError.Create('failed to clear console area', error);
553
 
        End;
554
 
      End;
555
 
    Finally
556
 
      If clipped_area <> Nil Then
557
 
        clipped_area.Free;
558
 
    End;
559
 
  End;
560
 
End;
561
 
 
562
 
Procedure TDirectXPrimary.palette(Const _palette : TPTCPalette);
563
 
 
564
 
Var
565
 
  data : Pint32;
566
 
  temp : Array[0..255] Of PALETTEENTRY;
567
 
  i : Integer;
568
 
  lpDDP : LPDIRECTDRAWPALETTE;
569
 
 
570
 
Begin
571
 
  block;
572
 
 
573
 
  m_palette.load(_palette.data);
574
 
  If Not m_format.indexed Then
575
 
  Begin
576
 
    LOG('palette set in direct color');
577
 
  End
578
 
  Else
579
 
  Begin
580
 
    data := _palette.data;
581
 
    For i := 0 To 255 Do
582
 
    Begin
583
 
      temp[i].peRed := (data[i] And $00FF0000) Shr 16;
584
 
      temp[i].peGreen := (data[i] And $0000FF00) Shr 8;
585
 
      temp[i].peBlue := data[i] And $000000FF;
586
 
      temp[i].peFlags := 0;
587
 
    End;
588
 
    lpDDP := Nil;
589
 
    If m_lpDDS_primary^.lpVtbl^.GetPalette(m_lpDDS_primary, @lpDDP) <> DD_OK Then
590
 
    Begin
591
 
      DirectXCheck(m_lpDD2^.lpVtbl^.CreatePalette(m_lpDD2, DDPCAPS_8BIT Or DDPCAPS_ALLOW256 Or DDPCAPS_INITIALIZE, @temp, @lpDDP, Nil), 'm_lpDD2^.CreatePalette failed in TDirectXPrimary.palette');
592
 
      DirectXCheck(m_lpDDS_primary^.lpVtbl^.SetPalette(m_lpDDS_primary, lpDDP), 'm_lpDDS_primary^.SetPalette failed in TDirectXPrimary.palette');
593
 
    End
594
 
    Else
595
 
      DirectXCheck(lpDDP^.lpVtbl^.SetEntries(lpDDP, 0, 0, 256, @temp), 'lpDDP^.SetEntries failed in TDirectXPrimary.palette');
596
 
  End;
597
 
End;
598
 
 
599
 
Function TDirectXPrimary.palette : TPTCPalette;
600
 
 
601
 
Begin
602
 
  palette := m_palette;
603
 
End;
604
 
 
605
 
Procedure TDirectXPrimary.clip(Const _area : TPTCArea);
606
 
 
607
 
Var
608
 
  tmp : TPTCArea;
609
 
 
610
 
Begin
611
 
  tmp := TPTCClipper.clip(_area, m_area);
612
 
  Try
613
 
    m_clip.ASSign(tmp);
614
 
  Finally
615
 
    tmp.Free;
616
 
  End;
617
 
End;
618
 
 
619
 
Function TDirectXPrimary.width : Integer;
620
 
 
621
 
Begin
622
 
  width := m_width;
623
 
End;
624
 
 
625
 
Function TDirectXPrimary.height : Integer;
626
 
 
627
 
Begin
628
 
  height := m_height;
629
 
End;
630
 
 
631
 
Function TDirectXPrimary.pages : Integer;
632
 
 
633
 
Begin
634
 
  pages := m_pages;
635
 
End;
636
 
 
637
 
Function TDirectXPrimary.pitch : Integer;
638
 
 
639
 
Var
640
 
  descriptor : DDSURFACEDESC;
641
 
 
642
 
Begin
643
 
  Block;
644
 
  descriptor.dwSize := SizeOf(descriptor);
645
 
  DirectXCheck(m_back^.lpVtbl^.GetSurfaceDesc(m_back, @descriptor), 'm_back^.GetSurfaceDesc failed in TDirectXPrimary.pitch');
646
 
  pitch := descriptor.lPitch;
647
 
End;
648
 
 
649
 
Function TDirectXPrimary.area : TPTCArea;
650
 
 
651
 
Begin
652
 
  area := m_area;
653
 
End;
654
 
 
655
 
Function TDirectXPrimary.clip : TPTCArea;
656
 
 
657
 
Begin
658
 
  clip := m_clip;
659
 
End;
660
 
 
661
 
Function TDirectXPrimary.format : TPTCFormat;
662
 
 
663
 
Begin
664
 
  format := m_format;
665
 
End;
666
 
 
667
 
Function TDirectXPrimary.lpDDS : LPDIRECTDRAWSURFACE;
668
 
 
669
 
Begin
670
 
  If m_lpDDS_secondary <> Nil Then
671
 
    lpDDS := m_lpDDS_secondary
672
 
  Else
673
 
    lpDDS := m_lpDDS_primary_back;
674
 
End;
675
 
 
676
 
Function TDirectXPrimary.lpDDS_primary : LPDIRECTDRAWSURFACE;
677
 
 
678
 
Begin
679
 
  lpDDS_primary := m_lpDDS_primary;
680
 
End;
681
 
 
682
 
Function TDirectXPrimary.lpDDS_secondary : LPDIRECTDRAWSURFACE;
683
 
 
684
 
Begin
685
 
  lpDDS_secondary := m_lpDDS_secondary;
686
 
End;
687
 
 
688
 
Procedure TDirectXPrimary.activate;
689
 
 
690
 
Begin
691
 
  LOG('primary activated');
692
 
  m_active := True;
693
 
End;
694
 
 
695
 
Procedure TDirectXPrimary.deactivate;
696
 
 
697
 
Begin
698
 
  LOG('primary deactivated');
699
 
  If m_blocking Then
700
 
    m_active := False
701
 
  Else
702
 
    {no deactivation when not blocking};
703
 
End;
704
 
 
705
 
Function TDirectXPrimary.active : Boolean;
706
 
 
707
 
Begin
708
 
  active := m_active;
709
 
End;
710
 
 
711
 
Procedure TDirectXPrimary.block;
712
 
 
713
 
Var
714
 
  restored : Boolean;
715
 
 
716
 
Begin
717
 
  If Not m_blocking Then
718
 
    Exit;
719
 
  If Not active Then
720
 
  Begin
721
 
    restored := False;
722
 
    While Not restored Do
723
 
    Begin
724
 
      LOG('blocking until activated');
725
 
      While Not active Do
726
 
      Begin
727
 
        m_window.update(True);
728
 
        Sleep(10);
729
 
      End;
730
 
      LOG('primary is active');
731
 
      m_window.update(True);
732
 
      Try
733
 
        restore;
734
 
        restored := True;
735
 
        LOG('successful restore');
736
 
      Except
737
 
        On TPTCError Do
738
 
        Begin
739
 
          LOG('application is active but cannot restore');
740
 
        End;
741
 
      End;
742
 
      Sleep(10);
743
 
    End;
744
 
  End;
745
 
  If m_lpDDS_primary^.lpVtbl^.IsLost(m_lpDDS_primary) <> DD_OK Then
746
 
    Raise TPTCError.Create('primary surface lost unexpectedly!');
747
 
  If (m_lpDDS_secondary <> Nil) And (m_lpDDS_secondary^.lpVtbl^.IsLost(m_lpDDS_secondary) <> DD_OK) Then
748
 
    Raise TPTCError.Create('secondary surface lost unexpectedly!');
749
 
End;
750
 
 
751
 
Procedure TDirectXPrimary.save;
752
 
 
753
 
Begin
754
 
  If m_lpDDS_primary^.lpVtbl^.IsLost(m_lpDDS_primary) = DD_OK Then
755
 
  Begin
756
 
    LOG('saving contents of primary surface');
757
 
 
758
 
    { todo: save contents of primary surface }
759
 
  End
760
 
  Else
761
 
  Begin
762
 
    LOG('could not save primary surface');
763
 
  End;
764
 
 
765
 
  If (m_lpDDS_secondary <> Nil) And (m_lpDDS_secondary^.lpVtbl^.IsLost(m_lpDDS_secondary) = DD_OK) Then
766
 
  Begin
767
 
    LOG('saving contents of secondary surface');
768
 
 
769
 
    { todo: save contents of secondary surface }
770
 
  End
771
 
  Else
772
 
    If m_lpDDS_secondary <> Nil Then
773
 
    Begin
774
 
      LOG('could not save secondary surface');
775
 
    End;
776
 
End;
777
 
 
778
 
Procedure TDirectXPrimary.restore;
779
 
 
780
 
Var
781
 
  i : Integer;
782
 
  rct : RECT;
783
 
  fx : DDBLTFX;
784
 
 
785
 
Begin
786
 
  DirectXCheck(m_lpDDS_primary^.lpVtbl^.Restore(m_lpDDS_primary), 'm_lpDDS_primary^.Restore failed in TDirectXConsole.restore');
787
 
  If m_lpDDS_secondary <> Nil Then
788
 
    DirectXCheck(m_lpDDS_secondary^.lpVtbl^.Restore(m_lpDDS_secondary), 'm_lpDDS_secondary^.Restore failed in TDirectXConsole.restore');
789
 
  LOG('restoring contents of primary surface');
790
 
  { todo: restore palette object on primary surface ? }
791
 
  { todo: restore contents of primary surface }
792
 
  If m_lpDDS_primary_page[0] <> Nil Then
793
 
  Begin
794
 
    LOG('restoring attached pages');
795
 
    For i := 0 To m_pages - 2 Do
796
 
      DirectXCheck(m_lpDDS_primary_page[i]^.lpVtbl^.Restore(m_lpDDS_primary_page[i]), 'm_lpDDS_primary_page^.Restore failed in TDirectXConsole.restore');
797
 
  End;
798
 
 
799
 
  If m_lpDDS_secondary <> Nil Then
800
 
  Begin
801
 
    If m_fullscreen Then
802
 
    Begin
803
 
      LOG('temporary primary surface clear');
804
 
 
805
 
      { temporary: clear primary surface }
806
 
      With rct Do
807
 
      Begin
808
 
        left := 0;
809
 
        top := 0;
810
 
        right := m_primary_width;
811
 
        bottom := m_primary_height;
812
 
      End;
813
 
      fx.dwSize := SizeOf(fx);
814
 
      fx.dwFillColor := 0;
815
 
      DirectXCheck(m_lpDDS_primary^.lpVtbl^.Blt(m_lpDDS_primary, @rct, Nil, Nil, DDBLT_COLORFILL Or DDBLT_WAIT, @fx), 'm_lpDDS_primary^.Blt failed in TDirectXPrimary.restore');
816
 
    End;
817
 
    LOG('restoring contents of secondary surface');
818
 
    { todo: restore contents of secondary surface }
819
 
  End;
820
 
End;
821
 
 
822
 
Procedure TDirectXPrimary.paint;
823
 
 
824
 
Var
825
 
  source, destination : RECT;
826
 
  pnt : POINT;
827
 
  x, y : Integer;
828
 
  fx : DDBLTFX;
829
 
 
830
 
Begin
831
 
  If Not active Then
832
 
  Begin
833
 
    LOG('paint when not active');
834
 
    Exit;
835
 
  End;
836
 
  If m_lpDDS_secondary <> Nil Then
837
 
  Begin
838
 
    If (m_lpDDS_primary^.lpVtbl^.IsLost(m_lpDDS_primary) <> DD_OK) Or
839
 
       (m_lpDDS_secondary^.lpVtbl^.IsLost(m_lpDDS_secondary) <> DD_OK) Then
840
 
    Begin
841
 
      LOG('paint when surfaces are lost');
842
 
      Exit;
843
 
    End;
844
 
    source.left := 0;
845
 
    source.top := 0;
846
 
    source.right := m_secondary_width;
847
 
    source.bottom := m_secondary_height;
848
 
    destination.left := 0;
849
 
    destination.top := 0;
850
 
    destination.right := m_primary_width;
851
 
    destination.bottom := m_primary_height;
852
 
 
853
 
    { note: code below assumes secondary is smaller than primary }
854
 
    If m_centering And m_fullscreen Then
855
 
    Begin
856
 
      x := (destination.right - source.right) Div 2;
857
 
      y := (destination.bottom - source.bottom) Div 2;
858
 
 
859
 
      destination.left := x;
860
 
      destination.top := y;
861
 
      destination.right := x + source.right;
862
 
      destination.bottom := y + source.bottom;
863
 
    End;
864
 
    If Not m_fullscreen Then
865
 
    Begin
866
 
      pnt.x := 0;
867
 
      pnt.y := 0;
868
 
      ClientToScreen(m_window.handle, pnt);
869
 
 
870
 
      GetClientRect(m_window.handle, destination);
871
 
      Inc(destination.left, pnt.x);
872
 
      Inc(destination.top, pnt.y);
873
 
      Inc(destination.right, pnt.x);
874
 
      Inc(destination.bottom, pnt.y);
875
 
    End;
876
 
 
877
 
    If ((source.right - source.left) = 0) Or
878
 
       ((source.bottom - source.top) = 0) Or
879
 
       ((destination.right - destination.left) = 0) Or
880
 
       ((destination.bottom - destination.top) = 0) Then
881
 
    Begin
882
 
      LOG('zero area in primary paint');
883
 
      Exit;
884
 
    End;
885
 
 
886
 
    If m_synchronize Then
887
 
    Begin
888
 
      fx.dwSize := SizeOf(fx);
889
 
      fx.dwDDFX := DDBLTFX_NOTEARING;
890
 
      Try
891
 
        DirectXCheck(m_lpDDS_primary_back^.lpVtbl^.Blt(m_lpDDS_primary_back, @destination, m_lpDDS_secondary, @source, DDBLT_WAIT Or DDBLT_DDFX, @fx), 'm_lpDDS_primary^.Blt (synchronized) failed in TDirectXPrimary.paint');
892
 
      Except
893
 
        On TPTCError Do
894
 
        Begin
895
 
          LOG('falling back to unsynchronized blt');
896
 
          m_synchronize := False;
897
 
        End;
898
 
      End;
899
 
    End;
900
 
    If Not m_synchronize Then
901
 
      DirectXCheck(m_lpDDS_primary_back^.lpVtbl^.Blt(m_lpDDS_primary_back, @destination, m_lpDDS_secondary, @source, DDBLT_WAIT, Nil), 'm_lpDDS_primary^.Blt (unsynchronized) failed in TDirectXPrimary.paint');
902
 
  End;
903
 
End;
904
 
 
905
 
Procedure TDirectXPrimary.blocking(_blocking : Boolean);
906
 
 
907
 
Begin
908
 
  m_blocking := _blocking;
909
 
End;
910
 
 
911
 
Function TDirectXPrimary.pack(Const color : TPTCColor; Const _format : TPTCFormat) : int32;
912
 
 
913
 
Var
914
 
  r_base, g_base, b_base, a_base : Integer;
915
 
  r_size, g_size, b_size, a_size : Integer;
916
 
  r_scale, g_scale, b_scale, a_scale : Single;
917
 
 
918
 
Begin
919
 
  If color.direct And _format.direct Then
920
 
  Begin
921
 
    r_base := 0;
922
 
    g_base := 0;
923
 
    b_base := 0;
924
 
    a_base := 0;
925
 
    r_size := 0;
926
 
    g_size := 0;
927
 
    b_size := 0;
928
 
    a_size := 0;
929
 
    analyse(_format.r, r_base, r_size);
930
 
    analyse(_format.g, g_base, g_size);
931
 
    analyse(_format.b, b_base, b_size);
932
 
    analyse(_format.a, a_base, a_size);
933
 
    r_scale := 1 Shl r_size;
934
 
    g_scale := 1 Shl g_size;
935
 
    b_scale := 1 Shl b_size;
936
 
    a_scale := 1 Shl a_size;
937
 
    pack := (Trunc(color.r * r_scale) Shl r_base) Or
938
 
            (Trunc(color.g * g_scale) Shl g_base) Or
939
 
            (Trunc(color.b * b_scale) Shl b_base) Or
940
 
            (Trunc(color.a * a_scale) Shl a_base);
941
 
  End
942
 
  Else
943
 
    If color.indexed And _format.indexed Then
944
 
      pack := color.index
945
 
    Else
946
 
      Raise TPTCError.Create('color format type mismatch');
947
 
End;
948
 
 
949
 
Procedure TDirectXPrimary.analyse(mask : int32; Var base, size : Integer);
950
 
 
951
 
Begin
952
 
  base := 0;
953
 
  size := 0;
954
 
  If mask = 0 Then
955
 
    Exit;
956
 
  While (mask And 1) = 0 Do
957
 
  Begin
958
 
    mask := mask Shr 1;
959
 
    Inc(base);
960
 
  End;
961
 
  While (mask And 1) <> 0 Do
962
 
  Begin
963
 
    mask := mask Shr 1;
964
 
    Inc(size);
965
 
  End;
966
 
End;