primary.inc 26 KB

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