directxconsole.inc 31 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315
  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. {$MACRO ON}
  18. {$DEFINE DEFAULT_WIDTH:=320}
  19. {$DEFINE DEFAULT_HEIGHT:=200}
  20. {$DEFINE DEFAULT_FORMAT:=TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF)}
  21. {$IFDEF DEBUG}
  22. {$DEFINE DEFAULT_OUTPUT:=WINDOWED}
  23. {$ELSE}
  24. {$DEFINE DEFAULT_OUTPUT:=DEFAULT}
  25. {$ENDIF}
  26. {$IFNDEF DEBUG}
  27. {$DEFINE CHECK_OPEN:=//}
  28. {$DEFINE CHECK_LOCK:=//}
  29. {$ENDIF}
  30. Const
  31. {Output}
  32. DEFAULT = 0;
  33. WINDOWED = 1;
  34. FULLSCREEN = 2;
  35. {Window}
  36. RESIZABLE = 0;
  37. FIXED = 1;
  38. {Primary}
  39. DIRECT = 0;
  40. SECONDARY = 1;
  41. {Nearest}
  42. NEAREST_DEFAULT = 0;
  43. NEAREST_CENTERING = 1;
  44. NEAREST_STRETCHING = 2;
  45. {Cursor}
  46. CURSOR_DEFAULT = 0;
  47. CURSOR_SHOW = 1;
  48. CURSOR_HIDE = 2;
  49. Function PChar2String(Q : PChar) : String;
  50. Var
  51. I : Integer;
  52. S : String;
  53. Begin
  54. S := '';
  55. I := 0;
  56. While Q[I] <> #0 Do
  57. Begin
  58. S := S + Q[I];
  59. Inc(I);
  60. End;
  61. PChar2String := S;
  62. End;
  63. Constructor TDirectXConsole.Create;
  64. Begin
  65. { clear objects }
  66. m_default_format := Nil;
  67. m_hook := Nil;
  68. m_window := Nil;
  69. m_keyboard := Nil;
  70. m_copy := Nil;
  71. m_library := Nil;
  72. m_display := Nil;
  73. m_primary := Nil;
  74. m_copy := TPTCCopy.Create;
  75. m_library := TDirectXLibrary.Create;
  76. m_display := TDirectXDisplay.Create;
  77. m_primary := TDirectXPrimary.Create;
  78. { defaults }
  79. m_open := False;
  80. m_locked := False;
  81. m_cursor := True;
  82. { clear strings }
  83. { m_title[0] := #0;}
  84. m_title := '';
  85. { default option data }
  86. m_frequency := 0;
  87. m_default_width := DEFAULT_WIDTH;
  88. m_default_height := DEFAULT_HEIGHT;
  89. m_default_format := DEFAULT_FORMAT;
  90. m_center_window := False;
  91. m_synchronized_update := True;
  92. m_output_mode := DEFAULT_OUTPUT;
  93. m_window_mode := RESIZABLE;
  94. m_primary_mode_windowed := SECONDARY;
  95. m_primary_mode_fullscreen := DIRECT;
  96. m_nearest_mode := NEAREST_DEFAULT;
  97. m_cursor_mode := CURSOR_DEFAULT;
  98. { configure console }
  99. configure('ptc.cfg');
  100. { setup display object }
  101. m_display.setup(m_library.lpDD2);
  102. End;
  103. Destructor TDirectXConsole.Destroy;
  104. Begin
  105. { close }
  106. close;
  107. m_hook.Free;
  108. m_keyboard.Free;
  109. m_window.Free;
  110. m_primary.Free;
  111. m_display.Free;
  112. m_library.Free;
  113. m_copy.Free;
  114. m_default_format.Free;
  115. Inherited Destroy;
  116. End;
  117. Procedure TDirectXConsole.configure(Const _file : String);
  118. Var
  119. F : Text;
  120. S : String;
  121. Begin
  122. ASSignFile(F, _file);
  123. {$I-}
  124. Reset(F);
  125. {$I+}
  126. If IOResult <> 0 Then
  127. Exit;
  128. While Not EoF(F) Do
  129. Begin
  130. {$I-}
  131. Readln(F, S);
  132. {$I+}
  133. If IOResult <> 0 Then
  134. Break;
  135. option(S);
  136. End;
  137. CloseFile(F);
  138. End;
  139. Function TDirectXConsole.option(Const _option : String) : Boolean;
  140. Var
  141. tmp, tmp2 : Integer;
  142. tmpformat : TPTCFormat;
  143. Begin
  144. LOG('console option', _option);
  145. option := True;
  146. If _option = 'default output' Then
  147. Begin
  148. m_output_mode := DEFAULT;
  149. Exit;
  150. End;
  151. If _option = 'windowed output' Then
  152. Begin
  153. m_output_mode := WINDOWED;
  154. Exit;
  155. End;
  156. If _option = 'fullscreen output' Then
  157. Begin
  158. m_output_mode := FULLSCREEN;
  159. Exit;
  160. End;
  161. If System.Copy(_option, 1, 13) = 'default width' Then
  162. Begin
  163. If Length(_option) > 13 Then
  164. Begin
  165. Val(System.Copy(_option, 14, Length(_option)-13), m_default_width, tmp);
  166. If m_default_width = 0 Then
  167. m_default_width := DEFAULT_WIDTH;
  168. End
  169. Else
  170. Begin
  171. m_default_width := DEFAULT_WIDTH;
  172. End;
  173. End;
  174. If System.Copy(_option, 1, 14) = 'default height' Then
  175. Begin
  176. If Length(_option) > 14 Then
  177. Begin
  178. Val(System.Copy(_option, 15, Length(_option)-14), m_default_height, tmp);
  179. If m_default_height = 0 Then
  180. m_default_height := DEFAULT_HEIGHT;
  181. End
  182. Else
  183. Begin
  184. m_default_height := DEFAULT_HEIGHT;
  185. End;
  186. End;
  187. If System.Copy(_option, 1, 12) = 'default bits' Then
  188. Begin
  189. If Length(_option) > 12 Then
  190. Begin
  191. Val(System.Copy(_option, 13, Length(_option)-12), tmp, tmp2);
  192. Case tmp Of
  193. 8 : tmpformat := TPTCFormat.Create(8);
  194. 16 : tmpformat := TPTCFormat.Create(16, $F800, $07E0, $001F);
  195. 24 : tmpformat := TPTCFormat.Create(24, $00FF0000, $0000FF00, $000000FF);
  196. 32 : tmpformat := TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF);
  197. Else
  198. Exit(False);
  199. End;
  200. Try
  201. m_default_format.ASSign(tmpformat);
  202. Finally
  203. tmpformat.Free;
  204. End;
  205. End
  206. Else
  207. Begin
  208. tmpformat := DEFAULT_FORMAT;
  209. Try
  210. m_default_format.ASSign(tmpformat);
  211. Finally
  212. tmpformat.Free;
  213. End;
  214. End;
  215. End;
  216. If _option = 'resizable window' Then
  217. Begin
  218. m_window_mode := RESIZABLE;
  219. Exit;
  220. End;
  221. If _option = 'fixed window' Then
  222. Begin
  223. m_window_mode := FIXED;
  224. Exit;
  225. End;
  226. If _option = 'windowed primary direct' Then
  227. Begin
  228. m_primary_mode_windowed := DIRECT;
  229. Exit;
  230. End;
  231. If _option = 'windowed primary secondary' Then
  232. Begin
  233. m_primary_mode_windowed := SECONDARY;
  234. Exit;
  235. End;
  236. If _option = 'fullscreen primary direct' Then
  237. Begin
  238. m_primary_mode_fullscreen := DIRECT;
  239. Exit;
  240. End;
  241. If _option = 'fullscreen primary secondary' Then
  242. Begin
  243. m_primary_mode_fullscreen := SECONDARY;
  244. Exit;
  245. End;
  246. If _option = 'center window' Then
  247. Begin
  248. m_center_window := True;
  249. Exit;
  250. End;
  251. If _option = 'default window position' Then
  252. Begin
  253. m_center_window := False;
  254. Exit;
  255. End;
  256. If _option = 'synchronized update' Then
  257. Begin
  258. m_synchronized_update := True;
  259. Exit;
  260. End;
  261. If _option = 'unsynchronized update' Then
  262. Begin
  263. m_synchronized_update := False;
  264. Exit;
  265. End;
  266. If _option = 'default nearest' Then
  267. Begin
  268. m_nearest_mode := NEAREST_DEFAULT;
  269. Exit;
  270. End;
  271. If _option = 'center nearest' Then
  272. Begin
  273. m_nearest_mode := NEAREST_CENTERING;
  274. Exit;
  275. End;
  276. If _option = 'default stretch' Then
  277. Begin
  278. m_nearest_mode := NEAREST_STRETCHING;
  279. Exit;
  280. End;
  281. If _option = 'default cursor' Then
  282. Begin
  283. m_cursor_mode := CURSOR_DEFAULT;
  284. update_cursor;
  285. Exit;
  286. End;
  287. If _option = 'show cursor' Then
  288. Begin
  289. m_cursor_mode := CURSOR_SHOW;
  290. update_cursor;
  291. Exit;
  292. End;
  293. If _option = 'hide cursor' Then
  294. Begin
  295. m_cursor_mode := CURSOR_HIDE;
  296. update_cursor;
  297. Exit;
  298. End;
  299. If System.Copy(_option, 1, 9) = 'frequency' Then
  300. Begin
  301. If Length(_option) > 9 Then
  302. Begin
  303. Val(System.Copy(_option, 10, Length(_option)-9), m_frequency, tmp);
  304. End
  305. Else
  306. m_frequency := 0;
  307. End;
  308. If _option = 'enable key buffering' Then
  309. Begin
  310. If m_keyboard = Nil Then
  311. Begin
  312. option := False;
  313. Exit;
  314. End;
  315. m_keyboard.enable;
  316. End;
  317. If _option = 'disable key buffering' Then
  318. Begin
  319. If m_keyboard = Nil Then
  320. Begin
  321. option := False;
  322. Exit;
  323. End;
  324. m_keyboard.disable;
  325. End;
  326. If _option = 'enable blocking' Then
  327. Begin
  328. m_primary.blocking(True);
  329. Exit;
  330. End;
  331. If _option = 'disable blocking' Then
  332. Begin
  333. m_primary.blocking(False);
  334. Exit;
  335. End;
  336. {$IFDEF PTC_LOGGING}
  337. If _option = 'enable logging' Then
  338. Begin
  339. LOG_enabled := True;
  340. option := True;
  341. Exit;
  342. End;
  343. If _option = 'disable logging' Then
  344. Begin
  345. LOG_enabled := False;
  346. option := True;
  347. Exit;
  348. End;
  349. {$ENDIF}
  350. option := m_copy.option(_option);
  351. End;
  352. Function TDirectXConsole.modes : PPTCMode;
  353. Begin
  354. modes := m_display.modes;
  355. End;
  356. Procedure TDirectXConsole.open(Const _title : String; _pages : Integer);
  357. Begin
  358. open(_title, m_default_format, _pages);
  359. End;
  360. Procedure TDirectXConsole.open(Const _title : String; Const _format : TPTCFormat;
  361. _pages : Integer);
  362. Begin
  363. open(_title, m_default_width, m_default_height, _format, _pages);
  364. End;
  365. Procedure TDirectXConsole.open(Const _title : String; _width, _height : Integer;
  366. Const _format : TPTCFormat; _pages : Integer);
  367. Var
  368. m : TPTCMode;
  369. Begin
  370. { internal open nearest mode }
  371. m := TPTCMode.Create(_width, _height, _format);
  372. Try
  373. internal_open(_title, 0, m, _pages, False);
  374. Finally
  375. m.Free;
  376. End;
  377. End;
  378. Procedure TDirectXConsole.open(Const _title : String; Const _mode : TPTCMode;
  379. _pages : Integer);
  380. Begin
  381. { internal open exact mode }
  382. internal_open(_title, 0, _mode, _pages, True);
  383. End;
  384. Procedure TDirectXConsole.close;
  385. Begin
  386. If m_open Then
  387. Begin
  388. If m_locked Then
  389. Raise TPTCError.Create('console is still locked');
  390. { flush all key presses }
  391. While KeyPressed Do
  392. ReadKey;
  393. End;
  394. internal_close;
  395. Win32Cursor_resurrect;
  396. End;
  397. Procedure TDirectXConsole.flush;
  398. Begin
  399. CHECK_OPEN('TDirectXConsole.flush');
  400. CHECK_LOCK('TDirectXConsole.flush');
  401. { [platform dependent code to flush all console operations] }
  402. { handle cursor show flag }
  403. If Not m_cursor Then
  404. SetCursor(0);
  405. { update window }
  406. m_window.update;
  407. End;
  408. Procedure TDirectXConsole.finish;
  409. Begin
  410. CHECK_OPEN('TDirectXConsole.finish');
  411. CHECK_LOCK('TDirectXConsole.finish');
  412. { [platform dependent code to finish all console operations] }
  413. { handle cursor show flag }
  414. If Not m_cursor Then
  415. SetCursor(0);
  416. { update window }
  417. m_window.update;
  418. End;
  419. Procedure TDirectXConsole.update;
  420. Begin
  421. CHECK_OPEN('TDirectXConsole.update');
  422. CHECK_LOCK('TDirectXConsole.update');
  423. { update primary surface }
  424. m_primary.update;
  425. { handle cursor show flag }
  426. If Not m_cursor Then
  427. SetCursor(0);
  428. { update window }
  429. m_window.update;
  430. End;
  431. Procedure TDirectXConsole.update(Const _area : TPTCArea);
  432. Begin
  433. { update }
  434. update;
  435. End;
  436. Procedure TDirectXConsole.internal_ReadKey(k : TPTCKey);
  437. Begin
  438. CHECK_OPEN('TDirectXConsole.internal_ReadKey');
  439. m_keyboard.internal_ReadKey(m_window, k);
  440. End;
  441. Function TDirectXConsole.internal_PeekKey(k : TPTCKey) : Boolean;
  442. Begin
  443. CHECK_OPEN('TDirectXConsole.internal_PeekKey');
  444. Result := m_keyboard.internal_PeekKey(m_window, k);
  445. End;
  446. Procedure TDirectXConsole.copy(Var surface : TPTCBaseSurface);
  447. Var
  448. pixels : Pointer;
  449. Begin
  450. CHECK_OPEN('TDirectXConsole.copy(surface)');
  451. CHECK_LOCK('TDirectXConsole.copy(surface)');
  452. pixels := lock;
  453. Try
  454. surface.load(pixels, width, height, pitch, format, palette);
  455. unlock;
  456. Except
  457. On error : TPTCError Do
  458. Begin
  459. unlock;
  460. Raise TPTCError.Create('failed to copy console to surface', error);
  461. End;
  462. End;
  463. End;
  464. Procedure TDirectXConsole.copy(Var surface : TPTCBaseSurface;
  465. Const source, destination : TPTCArea);
  466. Var
  467. pixels : Pointer;
  468. Begin
  469. CHECK_OPEN('TDirectXConsole.flush(surface, source, destination)');
  470. CHECK_LOCK('TDirectXConsole.flush(surface, source, destination)');
  471. pixels := lock;
  472. Try
  473. surface.load(pixels, width, height, pitch, format, palette, source, destination);
  474. unlock;
  475. Except
  476. On error : TPTCError Do
  477. Begin
  478. unlock;
  479. Raise TPTCError.Create('failed to copy console to surface', error);
  480. End;
  481. End;
  482. End;
  483. Function TDirectXConsole.lock : Pointer;
  484. Begin
  485. CHECK_OPEN('TDirectXConsole.lock');
  486. { fail if the console is already locked }
  487. If m_locked Then
  488. Raise TPTCError.Create('console is already locked');
  489. { lock primary surface }
  490. lock := m_primary.lock;
  491. { surface is locked }
  492. m_locked := True;
  493. End;
  494. Procedure TDirectXConsole.unlock;
  495. Begin
  496. CHECK_OPEN('TDirectXConsole.unlock');
  497. { fail if the console is not locked }
  498. If Not m_locked Then
  499. Raise TPTCError.Create('console is not locked');
  500. { unlock primary surface }
  501. m_primary.unlock;
  502. { we are unlocked }
  503. m_locked := False;
  504. End;
  505. Procedure TDirectXConsole.load(Const pixels : Pointer;
  506. _width, _height, _pitch : Integer;
  507. Const _format : TPTCFormat;
  508. Const _palette : TPTCPalette);
  509. Var
  510. Area_ : TPTCArea;
  511. console_pixels : Pointer;
  512. Begin
  513. CHECK_OPEN('TDirectXConsole.load(pixels, width, height, pitch, format, palette)');
  514. CHECK_LOCK('TDirectXConsole.load(pixels, width, height, pitch, format, palette)');
  515. If clip.Equals(area) Then
  516. Begin
  517. console_pixels := lock;
  518. Try
  519. Try
  520. m_copy.request(_format, format);
  521. m_copy.palette(_palette, palette);
  522. m_copy.copy(pixels, 0, 0, _width, _height, _pitch, console_pixels, 0, 0,
  523. width, height, pitch);
  524. Except
  525. On error : TPTCError Do
  526. Begin
  527. Raise TPTCError.Create('failed to load pixels to console', error);
  528. End;
  529. End;
  530. Finally
  531. unlock;
  532. End;
  533. End
  534. Else
  535. Begin
  536. Area_ := TPTCArea.Create(0, 0, width, height);
  537. Try
  538. load(pixels, _width, _height, _pitch, _format, _palette, Area_, area);
  539. Finally
  540. Area_.Free;
  541. End;
  542. End;
  543. End;
  544. Procedure TDirectXConsole.load(Const pixels : Pointer;
  545. _width, _height, _pitch : Integer;
  546. Const _format : TPTCFormat;
  547. Const _palette : TPTCPalette;
  548. Const source, destination : TPTCArea);
  549. Var
  550. console_pixels : Pointer;
  551. clipped_source, clipped_destination : TPTCArea;
  552. tmp : TPTCArea;
  553. Begin
  554. CHECK_OPEN('TDirectXConsole.load(pixels, width, height, pitch, format, palette, source, destination)');
  555. CHECK_LOCK('TDirectXConsole.load(pixels, width, height, pitch, format, palette, source, destination)');
  556. clipped_destination := Nil;
  557. clipped_source := TPTCArea.Create;
  558. Try
  559. clipped_destination := TPTCArea.Create;
  560. console_pixels := lock;
  561. Try
  562. Try
  563. tmp := TPTCArea.Create(0, 0, _width, _height);
  564. Try
  565. TPTCClipper.clip(source, tmp, clipped_source, destination, clip, clipped_destination);
  566. Finally
  567. tmp.Free;
  568. End;
  569. m_copy.request(_format, format);
  570. m_copy.palette(_palette, palette);
  571. m_copy.copy(pixels, clipped_source.left, clipped_source.top, clipped_source.width, clipped_source.height, _pitch,
  572. console_pixels, clipped_destination.left, clipped_destination.top, clipped_destination.width, clipped_destination.height, pitch);
  573. Except
  574. On error:TPTCError Do
  575. Begin
  576. Raise TPTCError.Create('failed to load pixels to console area', error);
  577. End;
  578. End;
  579. Finally
  580. unlock;
  581. End;
  582. Finally
  583. clipped_source.Free;
  584. clipped_destination.Free;
  585. End;
  586. End;
  587. Procedure TDirectXConsole.save(pixels : Pointer;
  588. _width, _height, _pitch : Integer;
  589. Const _format : TPTCFormat;
  590. Const _palette : TPTCPalette);
  591. Var
  592. Area_ : TPTCArea;
  593. console_pixels : Pointer;
  594. Begin
  595. CHECK_OPEN('TDirectXConsole.save(pixels, width, height, pitch, format, palette)');
  596. CHECK_LOCK('TDirectXConsole.save(pixels, width, height, pitch, format, palette)');
  597. If clip.Equals(area) Then
  598. Begin
  599. console_pixels := lock;
  600. Try
  601. Try
  602. m_copy.request(format, _format);
  603. m_copy.palette(palette, _palette);
  604. m_copy.copy(console_pixels, 0, 0, width, height, pitch, pixels, 0, 0,
  605. _width, _height, _pitch);
  606. Except
  607. On error : TPTCError Do
  608. Begin
  609. Raise TPTCError.Create('failed to save console pixels', error);
  610. End;
  611. End;
  612. Finally
  613. unlock;
  614. End;
  615. End
  616. Else
  617. Begin
  618. Area_ := TPTCArea.Create(0, 0, width, height);
  619. Try
  620. save(pixels, _width, _height, _pitch, _format, _palette, area, Area_);
  621. Finally
  622. Area_.Free;
  623. End;
  624. End;
  625. End;
  626. Procedure TDirectXConsole.save(pixels : Pointer;
  627. _width, _height, _pitch : Integer;
  628. Const _format : TPTCFormat;
  629. Const _palette : TPTCPalette;
  630. Const source, destination : TPTCArea);
  631. Var
  632. console_pixels : Pointer;
  633. clipped_source, clipped_destination : TPTCArea;
  634. tmp : TPTCArea;
  635. Begin
  636. CHECK_OPEN('TDirectXConsole.save(pixels, width, height, pitch, format, palette, source, destination)');
  637. CHECK_LOCK('TDirectXConsole.save(pixels, width, height, pitch, format, palette, source, destination)');
  638. clipped_destination := Nil;
  639. clipped_source := TPTCArea.Create;
  640. Try
  641. clipped_destination := TPTCArea.Create;
  642. console_pixels := lock;
  643. Try
  644. Try
  645. tmp := TPTCArea.Create(0, 0, _width, _height);
  646. Try
  647. TPTCClipper.clip(source, clip, clipped_source, destination, tmp, clipped_destination);
  648. Finally
  649. tmp.Free;
  650. End;
  651. m_copy.request(format, _format);
  652. m_copy.palette(palette, _palette);
  653. m_copy.copy(console_pixels, clipped_source.left, clipped_source.top, clipped_source.width, clipped_source.height, pitch,
  654. pixels, clipped_destination.left, clipped_destination.top, clipped_destination.width, clipped_destination.height, _pitch);
  655. Except
  656. On error:TPTCError Do
  657. Begin
  658. Raise TPTCError.Create('failed to save console area pixels', error);
  659. End;
  660. End;
  661. Finally
  662. unlock;
  663. End;
  664. Finally
  665. clipped_source.Free;
  666. clipped_destination.Free;
  667. End;
  668. End;
  669. Procedure TDirectXConsole.clear;
  670. Var
  671. tmp : TPTCColor;
  672. Begin
  673. CHECK_OPEN('TDirectXConsole.clear');
  674. CHECK_LOCK('TDirectXConsole.clear');
  675. If format.direct Then
  676. tmp := TPTCColor.Create(0, 0, 0, 0)
  677. Else
  678. tmp := TPTCColor.Create(0);
  679. Try
  680. clear(tmp);
  681. Finally
  682. tmp.Free;
  683. End;
  684. End;
  685. Procedure TDirectXConsole.clear(Const color : TPTCColor);
  686. Var
  687. tmp : TPTCArea;
  688. Begin
  689. CHECK_OPEN('TDirectXConsole.clear(color)');
  690. CHECK_LOCK('TDirectXConsole.clear(color)');
  691. tmp := TPTCArea.Create;
  692. Try
  693. clear(color, tmp);
  694. Finally
  695. tmp.Free;
  696. End;
  697. End;
  698. Procedure TDirectXConsole.clear(Const color : TPTCColor;
  699. Const _area : TPTCArea);
  700. Begin
  701. CHECK_OPEN('TDirectXConsole.clear(color, area)');
  702. CHECK_LOCK('TDirectXConsole.clear(color, area)');
  703. m_primary.clear(color, _area);
  704. End;
  705. Procedure TDirectXConsole.palette(Const _palette : TPTCPalette);
  706. Begin
  707. CHECK_OPEN('TDirectXConsole.palette(palette)');
  708. m_primary.palette(_palette);
  709. End;
  710. Function TDirectXConsole.palette : TPTCPalette;
  711. Begin
  712. CHECK_OPEN('TDirectXConsole.palette');
  713. palette := m_primary.palette;
  714. End;
  715. Procedure TDirectXConsole.clip(Const _area : TPTCArea);
  716. Begin
  717. CHECK_OPEN('TDirectXConsole.clip(area)');
  718. m_primary.clip(_area);
  719. End;
  720. Function TDirectXConsole.width : Integer;
  721. Begin
  722. CHECK_OPEN('TDirectXConsole.width');
  723. width := m_primary.width;
  724. End;
  725. Function TDirectXConsole.height : Integer;
  726. Begin
  727. CHECK_OPEN('TDirectXConsole.height');
  728. height := m_primary.height;
  729. End;
  730. Function TDirectXConsole.pitch : Integer;
  731. Begin
  732. CHECK_OPEN('TDirectXConsole.pitch');
  733. pitch := m_primary.pitch;
  734. End;
  735. Function TDirectXConsole.pages : Integer;
  736. Begin
  737. CHECK_OPEN('TDirectXConsole.pages');
  738. pages := m_primary.pages;
  739. End;
  740. Function TDirectXConsole.area : TPTCArea;
  741. Begin
  742. CHECK_OPEN('TDirectXConsole.area');
  743. area := m_primary.area;
  744. End;
  745. Function TDirectXConsole.clip : TPTCArea;
  746. Begin
  747. CHECK_OPEN('TDirectXConsole.clip');
  748. clip := m_primary.clip;
  749. End;
  750. Function TDirectXConsole.format : TPTCFormat;
  751. Begin
  752. CHECK_OPEN('TDirectXConsole.format');
  753. format := m_primary.format;
  754. End;
  755. Function TDirectXConsole.name : String;
  756. Begin
  757. name := 'DirectX';
  758. End;
  759. Function TDirectXConsole.title : String;
  760. Begin
  761. CHECK_OPEN('TDirectXConsole.title');
  762. title := m_title;
  763. End;
  764. Function TDirectXConsole.information : String;
  765. Begin
  766. CHECK_OPEN('TDirectXConsole.information');
  767. information := m_display.information;
  768. End;
  769. Procedure TDirectXConsole.internal_open(Const _title : String; window : HWND; Const mode : TPTCMode; _pages : Integer; exact : Boolean);
  770. Var
  771. _width, _height : Integer;
  772. _format : TPTCFormat;
  773. Begin
  774. Try
  775. { recycle an already open console }
  776. internal_recycle(_title, window, mode, _pages, exact);
  777. Exit;
  778. Except
  779. On TPTCError Do
  780. { could not recycle };
  781. End;
  782. { check that the mode is valid }
  783. If Not mode.valid Then
  784. Raise TPTCError.Create('invalid mode');
  785. { get mode information }
  786. _width := mode.width;
  787. _height := mode.height;
  788. _format := mode.format;
  789. { start internal open }
  790. internal_open_start(_title, window);
  791. { check output mode }
  792. Case m_output_mode Of
  793. DEFAULT :
  794. Try
  795. { start fullscreen open }
  796. internal_open_fullscreen_start(window, mode, exact);
  797. { change fullscreen display }
  798. internal_open_fullscreen_change(mode, exact);
  799. { setup fullscreen display surfaces }
  800. internal_open_fullscreen_surface(mode, _pages);
  801. { finish fullscreen open }
  802. internal_open_fullscreen_finish;
  803. Except
  804. On TPTCError Do
  805. Begin
  806. { internal open reset }
  807. internal_open_reset;
  808. { start windowed open }
  809. internal_open_windowed_start(window, mode, exact);
  810. { change windowed display display mode }
  811. internal_open_windowed_change(mode, exact);
  812. { setup windowed display }
  813. internal_open_windowed_surface(mode, _pages);
  814. { finish windowed open }
  815. internal_open_windowed_finish;
  816. End;
  817. End;
  818. WINDOWED : Begin
  819. { start windowed open }
  820. internal_open_windowed_start(window, mode, exact);
  821. { change windowed display display mode }
  822. internal_open_windowed_change(mode, exact);
  823. { setup windowed display }
  824. internal_open_windowed_surface(mode, _pages);
  825. { finish windowed open }
  826. internal_open_windowed_finish;
  827. End;
  828. FULLSCREEN : Begin
  829. { start fullscreen open }
  830. internal_open_fullscreen_start(window, mode, exact);
  831. { change fullscreen display }
  832. internal_open_fullscreen_change(mode, exact);
  833. { setup fullscreen display surfaces }
  834. internal_open_fullscreen_surface(mode, _pages);
  835. { finish fullscreen open }
  836. internal_open_fullscreen_finish;
  837. End;
  838. End;
  839. { finish internal open }
  840. internal_open_finish;
  841. End;
  842. Procedure TDirectXConsole.internal_recycle(Const _title : String; window : HWND; Const mode : TPTCMode; _pages : Integer; exact : Boolean);
  843. Begin
  844. { Check if the console is open }
  845. If not m_open Then
  846. Raise TPTCError.Create('cannot recycle because it is not already open');
  847. If window <> 0 Then
  848. Begin
  849. If (m_window.handle <> window) Or (Not (m_window.managed)) Then
  850. Raise TPTCError.Create('cannot recycle with this user window');
  851. End;
  852. Case m_output_mode Of
  853. DEFAULT :
  854. If m_display.fullscreen Then
  855. Begin
  856. Try
  857. internal_recycle_fullscreen(_title, window, mode, _pages, exact);
  858. Except
  859. On TPTCError Do
  860. Raise TPTCError.Create('recycling fullscreen to windowed is not implemented');
  861. End;
  862. End
  863. Else
  864. Raise TPTCError.Create('recycling windowed to fullscreen is not implemented');
  865. FULLSCREEN : internal_recycle_fullscreen(_title, window, mode, _pages, exact);
  866. WINDOWED : internal_recycle_fullscreen(_title, window, mode, _pages, exact);
  867. End;
  868. End;
  869. Procedure TDirectXConsole.internal_close;
  870. Begin
  871. m_open := False;
  872. FreeAndNil(m_keyboard);
  873. FreeAndNil(m_hook);
  874. If m_primary <> Nil Then
  875. m_primary.close;
  876. If m_display <> Nil Then
  877. m_display.close;
  878. FreeAndNil(m_window);
  879. If m_display <> Nil Then
  880. m_display.restore;
  881. End;
  882. Procedure TDirectXConsole.internal_shutdown;
  883. Begin
  884. m_library.close;
  885. End;
  886. Procedure TDirectXConsole.internal_open_start(Const _title : String; window : HWND);
  887. Var
  888. tmp : Array[0..1023] Of Char;
  889. Begin
  890. { close_down }
  891. internal_close;
  892. { check window }
  893. If window = 0 Then
  894. Begin
  895. m_title := _title;
  896. End
  897. Else
  898. Begin
  899. GetWindowText(window, @tmp, SizeOf(tmp));
  900. m_title := PChar2String(@tmp);
  901. End;
  902. End;
  903. Procedure TDirectXConsole.internal_open_finish;
  904. Begin
  905. FreeAndNil(m_keyboard);
  906. m_keyboard := TWin32Keyboard.Create(m_window.handle, m_window.thread, False);
  907. m_window.update;
  908. m_open := True;
  909. End;
  910. Procedure TDirectXConsole.internal_open_reset;
  911. Begin
  912. FreeAndNil(m_keyboard);
  913. FreeAndNil(m_hook);
  914. m_primary.close;
  915. FreeAndNil(m_window);
  916. m_display.restore;
  917. End;
  918. Procedure TDirectXConsole.internal_open_fullscreen_start(window : HWND; Const mode : TPTCMode; exact : Boolean);
  919. Begin
  920. { test if display mode exists... }
  921. If Not m_display.test(mode, exact) Then
  922. Raise TPTCError.Create('display mode test failed!');
  923. { handle cursor show mode }
  924. If m_cursor_mode = CURSOR_SHOW Then
  925. m_cursor := True
  926. Else
  927. m_cursor := False;
  928. { save display }
  929. m_display.save;
  930. { check window }
  931. If window = 0 Then
  932. m_window := TWin32Window.Create('PTC_DIRECTX_FULLSCREEN', m_title, WS_EX_TOPMOST, WS_POPUP Or WS_SYSMENU Or WS_VISIBLE, SW_NORMAL, 0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN), False, False)
  933. Else
  934. m_window := TWin32Window.Create(window);
  935. { set window cursor }
  936. m_window.cursor(m_cursor);
  937. { set cooperative level }
  938. m_display.cooperative(m_window.handle, True);
  939. End;
  940. Procedure TDirectXConsole.internal_open_fullscreen_change(Const mode : TPTCMode; exact : Boolean);
  941. Begin
  942. m_display.open(mode, exact, m_frequency);
  943. m_primary.blocking(True);
  944. End;
  945. Procedure TDirectXConsole.internal_open_fullscreen_surface(Const mode : TPTCMode; _pages : Integer);
  946. Var
  947. primary : Boolean;
  948. _secondary : Boolean;
  949. _palette : Boolean;
  950. complex : Boolean;
  951. Begin
  952. _secondary := (m_primary_mode_fullscreen = SECONDARY) Or (Not m_display.mode.Equals(mode));
  953. _palette := m_display.mode.format.indexed;
  954. m_primary.initialize(m_window, m_library.lpDD2);
  955. complex := False;
  956. primary := False;
  957. { randy heit's primary setup }
  958. While (Not primary) And (Not complex) Do
  959. Begin
  960. If _pages >= 1 Then
  961. Try
  962. m_primary.primary(_pages, True, True, _palette, complex);
  963. primary := True;
  964. Except
  965. On TPTCError Do;
  966. End;
  967. If Not primary Then
  968. Try
  969. m_primary.primary(3, True, True, _palette, complex);
  970. primary := True;
  971. Except
  972. On TPTCError Do
  973. Try
  974. m_primary.primary(2, True, True, _palette, complex);
  975. primary := True;
  976. Except
  977. On TPTCError Do
  978. Try
  979. If Not _secondary Then
  980. m_primary.primary(2, False, True, _palette, complex)
  981. Else
  982. m_primary.primary(1, False, True, _palette, complex);
  983. primary := True;
  984. Except
  985. On TPTCError Do
  986. complex := Not complex;
  987. End;
  988. End;
  989. End;
  990. End;
  991. If _secondary Then
  992. m_primary.secondary(mode.width, mode.height);
  993. If m_nearest_mode = NEAREST_CENTERING Then
  994. m_primary.centering(True);
  995. If m_nearest_mode = NEAREST_STRETCHING Then
  996. m_primary.centering(False);
  997. {
  998. original primary setup code (1.0.17)
  999. ...
  1000. }
  1001. m_primary.synchronize(m_synchronized_update);
  1002. End;
  1003. Procedure TDirectXConsole.internal_open_fullscreen_finish;
  1004. Begin
  1005. FreeAndNil(m_hook);
  1006. { create hook on window }
  1007. m_hook := TDirectXHook.Create(Self, m_window.handle, GetCurrentThreadId, m_cursor, m_window.managed, True);
  1008. End;
  1009. Procedure TDirectXConsole.internal_open_windowed_start(window : HWND; Const mode : TPTCMode; exact : Boolean);
  1010. Var
  1011. extended : Integer;
  1012. Begin
  1013. If m_cursor_mode = CURSOR_HIDE Then
  1014. m_cursor := False
  1015. Else
  1016. m_cursor := True;
  1017. FreeAndNil(m_window);
  1018. If window <> 0 Then
  1019. Begin
  1020. m_window := TWin32Window.Create(window);
  1021. End
  1022. Else
  1023. Begin
  1024. extended := 0;
  1025. If m_primary_mode_windowed = DIRECT Then
  1026. extended := WS_EX_TOPMOST;
  1027. Case m_window_mode Of
  1028. RESIZABLE : m_window := TWin32Window.Create('PTC_DIRECTX_WINDOWED_RESIZABLE', m_title,
  1029. extended, WS_OVERLAPPEDWINDOW Or WS_VISIBLE, SW_NORMAL, CW_USEDEFAULT, CW_USEDEFAULT, mode.width, mode.height, m_center_window, False);
  1030. FIXED : m_window := TWin32Window.Create('PTC_DIRECTX_WINDOWED_FIXED', m_title,
  1031. extended, WS_VISIBLE Or WS_SYSMENU Or WS_CAPTION Or WS_MINIMIZE, SW_NORMAL, CW_USEDEFAULT, CW_USEDEFAULT, mode.width, mode.height, m_center_window, False);
  1032. End;
  1033. End;
  1034. m_window.cursor(m_cursor);
  1035. m_display.cooperative(m_window.handle, False);
  1036. End;
  1037. Procedure TDirectXConsole.internal_open_windowed_change(Const mode : TPTCMode; exact : Boolean);
  1038. Begin
  1039. m_display.open;
  1040. If m_primary_mode_windowed = DIRECT Then
  1041. m_primary.blocking(True)
  1042. Else
  1043. m_primary.blocking(False);
  1044. End;
  1045. Procedure TDirectXConsole.internal_open_windowed_surface(Const mode : TPTCMode; _pages : Integer);
  1046. Begin
  1047. m_primary.initialize(m_window, m_library.lpDD2);
  1048. m_primary.primary(1, False, False, False, False);
  1049. If m_primary_mode_windowed = SECONDARY Then
  1050. m_primary.secondary(mode.width, mode.height);
  1051. End;
  1052. Procedure TDirectXConsole.internal_open_windowed_finish;
  1053. Begin
  1054. FreeAndNil(m_hook);
  1055. { create hook on window }
  1056. m_hook := TDirectXHook.Create(Self, m_window.handle, GetCurrentThreadId, m_cursor, m_window.managed, False);
  1057. End;
  1058. Procedure TDirectXConsole.internal_recycle_fullscreen(Const _title : String; window : HWND; Const mode : TPTCMode; _pages : Integer; exact : Boolean);
  1059. Begin
  1060. LOG('fullscreen open recycle');
  1061. m_primary.close;
  1062. internal_open_fullscreen_change(mode, exact);
  1063. internal_open_fullscreen_surface(mode, _pages);
  1064. End;
  1065. Procedure TDirectXConsole.internal_recycle_windowed(Const _title : String; window : HWND; Const mode : TPTCMode; _pages : Integer; exact : Boolean);
  1066. Begin
  1067. LOG('windowed open recycle');
  1068. m_primary.close;
  1069. m_window.resize(mode.width, mode.height);
  1070. internal_open_windowed_change(mode, exact);
  1071. internal_open_windowed_surface(mode, _pages);
  1072. End;
  1073. Procedure TDirectXConsole.paint;
  1074. Begin
  1075. If m_locked Or (Not m_open) Then
  1076. Exit;
  1077. m_primary.paint;
  1078. End;
  1079. Procedure TDirectXConsole.update_cursor;
  1080. Begin
  1081. If Not m_open Then
  1082. Exit;
  1083. If m_display.fullscreen Then
  1084. If m_cursor_mode = CURSOR_SHOW Then
  1085. m_cursor := True
  1086. Else
  1087. m_cursor := False
  1088. Else
  1089. If m_cursor_mode = CURSOR_HIDE Then
  1090. m_cursor := False
  1091. Else
  1092. m_cursor := True;
  1093. { update hook cursor }
  1094. m_hook.cursor(m_cursor);
  1095. { update window cursor }
  1096. m_window.cursor(m_cursor);
  1097. End;
  1098. {$IFDEF DEBUG}
  1099. Procedure TDirectXConsole.CHECK_OPEN(msg : String);
  1100. Begin
  1101. If Not m_open Then
  1102. Try
  1103. Raise TPTCError.Create('console is not open');
  1104. Except
  1105. On error : TPTCError Do
  1106. Raise TPTCError.Create(msg, error);
  1107. End;
  1108. End;
  1109. Procedure TDirectXConsole.CHECK_LOCK(msg : String);
  1110. Begin
  1111. If m_locked Then
  1112. Try
  1113. Raise TPTCError.Create('console is locked');
  1114. Except
  1115. On error : TPTCError Do
  1116. Raise TPTCError.Create(msg, error);
  1117. End;
  1118. End;
  1119. {$ENDIF}