/packages/ptc/src/dos/cga/cgaconsolei.inc

https://github.com/slibre/freepascal · Pascal · 592 lines · 475 code · 70 blank · 47 comment · 16 complexity · b4d0ea50d616285998392b86af6f6837 MD5 · raw file

  1. {
  2. This file is part of the PTCPas framebuffer library
  3. Copyright (C) 2001-2011 Nikolay Nikolov (nickysn@users.sourceforge.net)
  4. This library is free software; you can redistribute it and/or
  5. modify it under the terms of the GNU Lesser General Public
  6. License as published by the Free Software Foundation; either
  7. version 2.1 of the License, or (at your option) any later version
  8. with the following modification:
  9. As a special exception, the copyright holders of this library give you
  10. permission to link this library with independent modules to produce an
  11. executable, regardless of the license terms of these independent modules,and
  12. to copy and distribute the resulting executable under terms of your choice,
  13. provided that you also meet, for each linked independent module, the terms
  14. and conditions of the license of that module. An independent module is a
  15. module which is not derived from or based on this library. If you modify
  16. this library, you may extend this exception to your version of the library,
  17. but you are not obligated to do so. If you do not wish to do so, delete this
  18. exception statement from your version.
  19. This library is distributed in the hope that it will be useful,
  20. but WITHOUT ANY WARRANTY; without even the implied warranty of
  21. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  22. Lesser General Public License for more details.
  23. You should have received a copy of the GNU Lesser General Public
  24. License along with this library; if not, write to the Free Software
  25. Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  26. }
  27. {$MACRO ON}
  28. {$DEFINE DEFAULT_WIDTH:=320}
  29. {$DEFINE DEFAULT_HEIGHT:=200}
  30. {$DEFINE DEFAULT_FORMAT:=TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF)}
  31. constructor TCGAConsole.Create;
  32. begin
  33. inherited Create;
  34. m_open := False;
  35. m_locked := False;
  36. m_title := '';
  37. m_information := '';
  38. m_default_width := DEFAULT_WIDTH;
  39. m_default_height := DEFAULT_HEIGHT;
  40. m_default_format := DEFAULT_FORMAT;
  41. m_copy := TPTCCopy.Create;
  42. m_clear := TPTCClear.Create;
  43. Configure('ptcpas.cfg');
  44. end;
  45. destructor TCGAConsole.Destroy;
  46. begin
  47. close;
  48. m_keyboard.Free;
  49. FMouse.Free;
  50. FEventQueue.Free;
  51. m_copy.Free;
  52. m_clear.Free;
  53. inherited Destroy;
  54. end;
  55. procedure TCGAConsole.Configure(const AFileName: string);
  56. var
  57. F: TextFile;
  58. S: string;
  59. begin
  60. AssignFile(F, AFileName);
  61. {$push}{$I-}
  62. Reset(F);
  63. {$pop}
  64. if IOResult <> 0 then
  65. exit;
  66. while not EoF(F) do
  67. begin
  68. {$push}{$I-}
  69. Readln(F, S);
  70. {$pop}
  71. if IOResult <> 0 then
  72. Break;
  73. Option(S);
  74. end;
  75. CloseFile(F);
  76. end;
  77. function TCGAConsole.option(const _option: string): Boolean;
  78. begin
  79. {...}
  80. if _option = 'enable logging' then
  81. begin
  82. LOG_enabled := True;
  83. Result := True;
  84. exit;
  85. end;
  86. if _option = 'disable logging' then
  87. begin
  88. LOG_enabled := False;
  89. Result := True;
  90. exit;
  91. end;
  92. Result := m_copy.option(_option);
  93. end;
  94. function TCGAConsole.modes: TPTCModeList;
  95. begin
  96. Result := m_modes;
  97. end;
  98. procedure TCGAConsole.Open(const _title: string; _pages: Integer); overload;
  99. begin
  100. open(_title, m_default_format, _pages);
  101. end;
  102. procedure TCGAConsole.open(const _title: string; _format: IPTCFormat;
  103. _pages: Integer); overload;
  104. begin
  105. open(_title, m_default_width, m_default_height, _format, _pages);
  106. end;
  107. procedure TCGAConsole.open(const _title: string; _width, _height: Integer;
  108. _format: IPTCFormat; _pages: Integer); overload;
  109. begin
  110. open(_title, TPTCMode.Create(_width, _height, _format), _pages);
  111. end;
  112. procedure TCGAConsole.open(const _title: string; _mode: IPTCMode;
  113. _pages: Integer); overload;
  114. var
  115. _width, _height: Integer;
  116. _format: IPTCFormat;
  117. begin
  118. if not _mode.valid then
  119. raise TPTCError.Create('invalid mode');
  120. _width := _mode.width;
  121. _height := _mode.height;
  122. _format := _mode.format;
  123. internal_pre_open_setup(_title);
  124. internal_open_fullscreen_start;
  125. internal_open_fullscreen(_width, _height, _format);
  126. internal_open_fullscreen_finish(_pages);
  127. internal_post_open_setup;
  128. end;
  129. procedure TCGAConsole.close;
  130. begin
  131. if m_open then
  132. begin
  133. if m_locked then
  134. raise TPTCError.Create('console is still locked');
  135. {flush all key presses}
  136. while KeyPressed do ReadKey;
  137. internal_close;
  138. m_open := False;
  139. end;
  140. end;
  141. procedure TCGAConsole.flush;
  142. begin
  143. check_open;
  144. check_unlocked;
  145. end;
  146. procedure TCGAConsole.finish;
  147. begin
  148. check_open;
  149. check_unlocked;
  150. end;
  151. procedure TCGAConsole.update;
  152. var
  153. framebuffer: PByte;
  154. begin
  155. check_open;
  156. check_unlocked;
  157. framebuffer := m_primary.lock;
  158. try
  159. { vrc;}
  160. CGADump(framebuffer);
  161. finally
  162. m_primary.unlock;
  163. end;
  164. end;
  165. procedure TCGAConsole.update(_area: IPTCArea);
  166. begin
  167. update;
  168. end;
  169. procedure TCGAConsole.Copy(surface: IPTCSurface);
  170. var
  171. pixels: Pointer;
  172. begin
  173. check_open;
  174. check_unlocked;
  175. pixels := lock;
  176. try
  177. try
  178. surface.load(pixels, width, height, pitch, format, palette);
  179. finally
  180. unlock;
  181. end;
  182. except
  183. on error: TPTCError do
  184. raise TPTCError.Create('failed to copy console to surface', error);
  185. end;
  186. end;
  187. procedure TCGAConsole.Copy(surface: IPTCSurface;
  188. source, destination: IPTCArea);
  189. var
  190. pixels: Pointer;
  191. begin
  192. check_open;
  193. check_unlocked;
  194. pixels := lock;
  195. try
  196. try
  197. surface.load(pixels, width, height, pitch, format, palette, source, destination);
  198. finally
  199. unlock;
  200. end;
  201. except
  202. on error: TPTCError do
  203. raise TPTCError.Create('failed to copy console to surface', error);
  204. end;
  205. end;
  206. function TCGAConsole.lock: Pointer;
  207. var
  208. pixels: Pointer;
  209. begin
  210. check_open;
  211. if m_locked then
  212. raise TPTCError.Create('console is already locked');
  213. pixels := m_primary.lock;
  214. m_locked := True;
  215. Result := pixels;
  216. end;
  217. procedure TCGAConsole.unlock;
  218. begin
  219. check_open;
  220. if not m_locked then
  221. raise TPTCError.Create('console is not locked');
  222. m_primary.unlock;
  223. m_locked := False;
  224. end;
  225. procedure TCGAConsole.load(const pixels: Pointer;
  226. _width, _height, _pitch: Integer;
  227. _format: IPTCFormat;
  228. _palette: IPTCPalette);
  229. var
  230. console_pixels: Pointer;
  231. begin
  232. check_open;
  233. check_unlocked;
  234. if clip.Equals(area) then
  235. begin
  236. try
  237. console_pixels := lock;
  238. try
  239. m_copy.request(_format, format);
  240. m_copy.palette(_palette, palette);
  241. m_copy.copy(pixels, 0, 0, _width, _height, _pitch, console_pixels, 0, 0,
  242. width, height, pitch);
  243. finally
  244. unlock;
  245. end;
  246. except
  247. on error: TPTCError do
  248. raise TPTCError.Create('failed to load pixels to console', error);
  249. end;
  250. end
  251. else
  252. Load(pixels, _width, _height, _pitch, _format, _palette, TPTCArea.Create(0, 0, width, height), area);
  253. end;
  254. procedure TCGAConsole.load(const pixels: Pointer;
  255. _width, _height, _pitch: Integer;
  256. _format: IPTCFormat;
  257. _palette: IPTCPalette;
  258. source, destination: IPTCArea);
  259. var
  260. console_pixels: Pointer;
  261. clipped_source, clipped_destination: IPTCArea;
  262. begin
  263. check_open;
  264. check_unlocked;
  265. try
  266. console_pixels := lock;
  267. try
  268. TPTCClipper.clip(source, TPTCArea.Create(0, 0, _width, _height), clipped_source, destination, clip, clipped_destination);
  269. m_copy.request(_format, format);
  270. m_copy.palette(_palette, palette);
  271. m_copy.copy(pixels, clipped_source.left, clipped_source.top, clipped_source.width, clipped_source.height, _pitch,
  272. console_pixels, clipped_destination.left, clipped_destination.top, clipped_destination.width, clipped_destination.height, pitch);
  273. finally
  274. unlock;
  275. end;
  276. except
  277. on error:TPTCError do
  278. raise TPTCError.Create('failed to load pixels to console area', error);
  279. end;
  280. end;
  281. procedure TCGAConsole.save(pixels: Pointer;
  282. _width, _height, _pitch: Integer;
  283. _format: IPTCFormat;
  284. _palette: IPTCPalette);
  285. var
  286. console_pixels: Pointer;
  287. begin
  288. check_open;
  289. check_unlocked;
  290. if clip.Equals(area) then
  291. begin
  292. try
  293. console_pixels := lock;
  294. try
  295. m_copy.request(format, _format);
  296. m_copy.palette(palette, _palette);
  297. m_copy.copy(console_pixels, 0, 0, width, height, pitch, pixels, 0, 0,
  298. _width, _height, _pitch);
  299. finally
  300. unlock;
  301. end;
  302. except
  303. on error: TPTCError do
  304. raise TPTCError.Create('failed to save console pixels', error);
  305. end;
  306. end
  307. else
  308. Save(pixels, _width, _height, _pitch, _format, _palette, area, TPTCArea.Create(0, 0, width, height));
  309. end;
  310. procedure TCGAConsole.save(pixels: Pointer;
  311. _width, _height, _pitch: Integer;
  312. _format: IPTCFormat;
  313. _palette: IPTCPalette;
  314. source, destination: IPTCArea);
  315. var
  316. console_pixels: Pointer;
  317. clipped_source, clipped_destination: IPTCArea;
  318. begin
  319. check_open;
  320. check_unlocked;
  321. try
  322. console_pixels := lock;
  323. try
  324. TPTCClipper.clip(source, clip, clipped_source, destination, TPTCArea.Create(0, 0, _width, _height), clipped_destination);
  325. m_copy.request(format, _format);
  326. m_copy.palette(palette, _palette);
  327. m_copy.copy(console_pixels, clipped_source.left, clipped_source.top, clipped_source.width, clipped_source.height, pitch,
  328. pixels, clipped_destination.left, clipped_destination.top, clipped_destination.width, clipped_destination.height, _pitch);
  329. finally
  330. unlock;
  331. end;
  332. except
  333. on error:TPTCError do
  334. raise TPTCError.Create('failed to save console area pixels', error);
  335. end;
  336. end;
  337. procedure TCGAConsole.Clear;
  338. var
  339. Color: IPTCColor;
  340. begin
  341. check_open;
  342. check_unlocked;
  343. if format.direct then
  344. Color := TPTCColor.Create(0, 0, 0, 0)
  345. else
  346. Color := TPTCColor.Create(0);
  347. Clear(Color);
  348. end;
  349. procedure TCGAConsole.Clear(color: IPTCColor);
  350. begin
  351. check_open;
  352. check_unlocked;
  353. Clear(color, TPTCArea.Create);
  354. end;
  355. procedure TCGAConsole.clear(color: IPTCColor;
  356. _area: IPTCArea);
  357. var
  358. pixels: Pointer;
  359. clipped_area: IPTCArea;
  360. begin
  361. check_open;
  362. check_unlocked;
  363. try
  364. pixels := lock;
  365. try
  366. clipped_area := TPTCClipper.clip(_area, clip);
  367. m_clear.request(format);
  368. m_clear.clear(pixels, clipped_area.left, clipped_area.right, clipped_area.width, clipped_area.height, pitch, color);
  369. finally
  370. unlock;
  371. end;
  372. except
  373. on error: TPTCError do
  374. raise TPTCError.Create('failed to clear console area', error);
  375. end;
  376. end;
  377. procedure TCGAConsole.Palette(_palette: IPTCPalette);
  378. begin
  379. check_open;
  380. m_primary.palette(_palette);
  381. end;
  382. function TCGAConsole.Palette: IPTCPalette;
  383. begin
  384. check_open;
  385. Result := m_primary.palette;
  386. end;
  387. procedure TCGAConsole.Clip(_area: IPTCArea);
  388. begin
  389. check_open;
  390. m_primary.clip(_area);
  391. end;
  392. function TCGAConsole.GetWidth: Integer;
  393. begin
  394. check_open;
  395. Result := m_primary.width;
  396. end;
  397. function TCGAConsole.GetHeight: Integer;
  398. begin
  399. check_open;
  400. Result := m_primary.height;
  401. end;
  402. function TCGAConsole.GetPitch: Integer;
  403. begin
  404. check_open;
  405. Result := m_primary.pitch;
  406. end;
  407. function TCGAConsole.GetPages: Integer;
  408. begin
  409. check_open;
  410. Result := 2;
  411. end;
  412. function TCGAConsole.GetArea: IPTCArea;
  413. begin
  414. check_open;
  415. Result := m_primary.area;
  416. end;
  417. function TCGAConsole.Clip: IPTCArea;
  418. begin
  419. check_open;
  420. Result := m_primary.clip;
  421. end;
  422. function TCGAConsole.GetFormat: IPTCFormat;
  423. begin
  424. check_open;
  425. Result := m_primary.format;
  426. end;
  427. function TCGAConsole.GetName: string;
  428. begin
  429. Result := 'CGA';
  430. end;
  431. function TCGAConsole.GetTitle: string;
  432. begin
  433. Result := m_title;
  434. end;
  435. function TCGAConsole.GetInformation: string;
  436. begin
  437. Result := m_information;
  438. end;
  439. procedure TCGAConsole.internal_pre_open_setup(const _title: string);
  440. begin
  441. m_title := _title;
  442. end;
  443. procedure TCGAConsole.internal_open_fullscreen_start;
  444. begin
  445. CGAPrecalc;
  446. m_primary := TPTCSurface.Create(320, 200, TPTCFormat.Create(32, $FF0000, $00FF00, $0000FF));
  447. CGA320;
  448. end;
  449. procedure TCGAConsole.internal_open_fullscreen(_width, _height: Integer; const _format: IPTCFormat);
  450. begin
  451. end;
  452. procedure TCGAConsole.internal_open_fullscreen_finish(_pages: Integer);
  453. begin
  454. end;
  455. procedure TCGAConsole.internal_post_open_setup;
  456. begin
  457. FreeAndNil(m_keyboard);
  458. FreeAndNil(FMouse);
  459. FreeAndNil(FEventQueue);
  460. m_keyboard := TDosKeyboard.Create;
  461. FMouse := TDosMouse.Create(m_primary.width, m_primary.height);
  462. FEventQueue := TEventQueue.Create;
  463. { temporary platform dependent information fudge }
  464. m_information := 'dos version x.xx.x, CGA, 320x200 - 4 colors';
  465. { set open flag }
  466. m_open := True;
  467. end;
  468. procedure TCGAConsole.internal_reset;
  469. begin
  470. FreeAndNil(m_primary);
  471. FreeAndNil(m_keyboard);
  472. FreeAndNil(FMouse);
  473. FreeAndNil(FEventQueue);
  474. end;
  475. procedure TCGAConsole.internal_close;
  476. begin
  477. FreeAndNil(m_primary);
  478. FreeAndNil(m_keyboard);
  479. FreeAndNil(FMouse);
  480. FreeAndNil(FEventQueue);
  481. CGAText;
  482. end;
  483. procedure TCGAConsole.HandleEvents;
  484. begin
  485. m_keyboard.GetPendingEvents(FEventQueue);
  486. FMouse.GetPendingEvents(FEventQueue);
  487. end;
  488. function TCGAConsole.NextEvent(out event: IPTCEvent; wait: Boolean; const EventMask: TPTCEventMask): Boolean;
  489. begin
  490. check_open;
  491. repeat
  492. { get events }
  493. HandleEvents;
  494. { try to find an event that matches the EventMask }
  495. event := FEventQueue.NextEvent(EventMask);
  496. until (not Wait) or (event <> Nil);
  497. Result := event <> nil;
  498. end;
  499. function TCGAConsole.PeekEvent(wait: Boolean; const EventMask: TPTCEventMask): IPTCEvent;
  500. begin
  501. check_open;
  502. repeat
  503. { get events }
  504. HandleEvents;
  505. { try to find an event that matches the EventMask }
  506. Result := FEventQueue.PeekEvent(EventMask);
  507. until (not Wait) or (Result <> Nil);
  508. end;
  509. procedure TCGAConsole.check_open;
  510. begin
  511. if not m_open then
  512. raise TPTCError.Create('console is not open');
  513. end;
  514. procedure TCGAConsole.check_unlocked;
  515. begin
  516. if m_locked then
  517. raise TPTCError.Create('console is not unlocked');
  518. end;