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

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