1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315 |
- {
- Free Pascal port of the OpenPTC C++ library.
- Copyright (C) 2001-2003 Nikolay Nikolov ([email protected])
- Original C++ version by Glenn Fiedler ([email protected])
- This library is free software; you can redistribute it and/or
- modify it under the terms of the GNU Lesser General Public
- License as published by the Free Software Foundation; either
- version 2.1 of the License, or (at your option) any later version.
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- Lesser General Public License for more details.
- You should have received a copy of the GNU Lesser General Public
- License along with this library; if not, write to the Free Software
- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
- }
- {$MACRO ON}
- {$DEFINE DEFAULT_WIDTH:=320}
- {$DEFINE DEFAULT_HEIGHT:=200}
- {$DEFINE DEFAULT_FORMAT:=TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF)}
- {$IFDEF DEBUG}
- {$DEFINE DEFAULT_OUTPUT:=WINDOWED}
- {$ELSE}
- {$DEFINE DEFAULT_OUTPUT:=DEFAULT}
- {$ENDIF}
- {$IFNDEF DEBUG}
- {$DEFINE CHECK_OPEN:=//}
- {$DEFINE CHECK_LOCK:=//}
- {$ENDIF}
- Const
- {Output}
- DEFAULT = 0;
- WINDOWED = 1;
- FULLSCREEN = 2;
- {Window}
- RESIZABLE = 0;
- FIXED = 1;
- {Primary}
- DIRECT = 0;
- SECONDARY = 1;
- {Nearest}
- NEAREST_DEFAULT = 0;
- NEAREST_CENTERING = 1;
- NEAREST_STRETCHING = 2;
- {Cursor}
- CURSOR_DEFAULT = 0;
- CURSOR_SHOW = 1;
- CURSOR_HIDE = 2;
- Function PChar2String(Q : PChar) : String;
- Var
- I : Integer;
- S : String;
- Begin
- S := '';
- I := 0;
- While Q[I] <> #0 Do
- Begin
- S := S + Q[I];
- Inc(I);
- End;
- PChar2String := S;
- End;
- Constructor TDirectXConsole.Create;
- Begin
- { clear objects }
- m_default_format := Nil;
- m_hook := Nil;
- m_window := Nil;
- m_keyboard := Nil;
- m_copy := Nil;
- m_library := Nil;
- m_display := Nil;
- m_primary := Nil;
- m_copy := TPTCCopy.Create;
- m_library := TDirectXLibrary.Create;
- m_display := TDirectXDisplay.Create;
- m_primary := TDirectXPrimary.Create;
- { defaults }
- m_open := False;
- m_locked := False;
- m_cursor := True;
- { clear strings }
- { m_title[0] := #0;}
- m_title := '';
- { default option data }
- m_frequency := 0;
- m_default_width := DEFAULT_WIDTH;
- m_default_height := DEFAULT_HEIGHT;
- m_default_format := DEFAULT_FORMAT;
- m_center_window := False;
- m_synchronized_update := True;
- m_output_mode := DEFAULT_OUTPUT;
- m_window_mode := RESIZABLE;
- m_primary_mode_windowed := SECONDARY;
- m_primary_mode_fullscreen := DIRECT;
- m_nearest_mode := NEAREST_DEFAULT;
- m_cursor_mode := CURSOR_DEFAULT;
- { configure console }
- configure('ptc.cfg');
- { setup display object }
- m_display.setup(m_library.lpDD2);
- End;
- Destructor TDirectXConsole.Destroy;
- Begin
- { close }
- close;
- m_hook.Free;
- m_keyboard.Free;
- m_window.Free;
- m_primary.Free;
- m_display.Free;
- m_library.Free;
- m_copy.Free;
- m_default_format.Free;
- Inherited Destroy;
- End;
- Procedure TDirectXConsole.configure(Const _file : String);
- Var
- F : Text;
- S : String;
- Begin
- ASSignFile(F, _file);
- {$I-}
- Reset(F);
- {$I+}
- If IOResult <> 0 Then
- Exit;
- While Not EoF(F) Do
- Begin
- {$I-}
- Readln(F, S);
- {$I+}
- If IOResult <> 0 Then
- Break;
- option(S);
- End;
- CloseFile(F);
- End;
- Function TDirectXConsole.option(Const _option : String) : Boolean;
- Var
- tmp, tmp2 : Integer;
- tmpformat : TPTCFormat;
- Begin
- LOG('console option', _option);
- option := True;
- If _option = 'default output' Then
- Begin
- m_output_mode := DEFAULT;
- Exit;
- End;
- If _option = 'windowed output' Then
- Begin
- m_output_mode := WINDOWED;
- Exit;
- End;
- If _option = 'fullscreen output' Then
- Begin
- m_output_mode := FULLSCREEN;
- Exit;
- End;
- If System.Copy(_option, 1, 13) = 'default width' Then
- Begin
- If Length(_option) > 13 Then
- Begin
- Val(System.Copy(_option, 14, Length(_option)-13), m_default_width, tmp);
- If m_default_width = 0 Then
- m_default_width := DEFAULT_WIDTH;
- End
- Else
- Begin
- m_default_width := DEFAULT_WIDTH;
- End;
- End;
- If System.Copy(_option, 1, 14) = 'default height' Then
- Begin
- If Length(_option) > 14 Then
- Begin
- Val(System.Copy(_option, 15, Length(_option)-14), m_default_height, tmp);
- If m_default_height = 0 Then
- m_default_height := DEFAULT_HEIGHT;
- End
- Else
- Begin
- m_default_height := DEFAULT_HEIGHT;
- End;
- End;
- If System.Copy(_option, 1, 12) = 'default bits' Then
- Begin
- If Length(_option) > 12 Then
- Begin
- Val(System.Copy(_option, 13, Length(_option)-12), tmp, tmp2);
- Case tmp Of
- 8 : tmpformat := TPTCFormat.Create(8);
- 16 : tmpformat := TPTCFormat.Create(16, $F800, $07E0, $001F);
- 24 : tmpformat := TPTCFormat.Create(24, $00FF0000, $0000FF00, $000000FF);
- 32 : tmpformat := TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF);
- Else
- Exit(False);
- End;
- Try
- m_default_format.ASSign(tmpformat);
- Finally
- tmpformat.Free;
- End;
- End
- Else
- Begin
- tmpformat := DEFAULT_FORMAT;
- Try
- m_default_format.ASSign(tmpformat);
- Finally
- tmpformat.Free;
- End;
- End;
- End;
- If _option = 'resizable window' Then
- Begin
- m_window_mode := RESIZABLE;
- Exit;
- End;
- If _option = 'fixed window' Then
- Begin
- m_window_mode := FIXED;
- Exit;
- End;
- If _option = 'windowed primary direct' Then
- Begin
- m_primary_mode_windowed := DIRECT;
- Exit;
- End;
- If _option = 'windowed primary secondary' Then
- Begin
- m_primary_mode_windowed := SECONDARY;
- Exit;
- End;
- If _option = 'fullscreen primary direct' Then
- Begin
- m_primary_mode_fullscreen := DIRECT;
- Exit;
- End;
- If _option = 'fullscreen primary secondary' Then
- Begin
- m_primary_mode_fullscreen := SECONDARY;
- Exit;
- End;
- If _option = 'center window' Then
- Begin
- m_center_window := True;
- Exit;
- End;
- If _option = 'default window position' Then
- Begin
- m_center_window := False;
- Exit;
- End;
- If _option = 'synchronized update' Then
- Begin
- m_synchronized_update := True;
- Exit;
- End;
- If _option = 'unsynchronized update' Then
- Begin
- m_synchronized_update := False;
- Exit;
- End;
- If _option = 'default nearest' Then
- Begin
- m_nearest_mode := NEAREST_DEFAULT;
- Exit;
- End;
- If _option = 'center nearest' Then
- Begin
- m_nearest_mode := NEAREST_CENTERING;
- Exit;
- End;
- If _option = 'default stretch' Then
- Begin
- m_nearest_mode := NEAREST_STRETCHING;
- Exit;
- End;
- If _option = 'default cursor' Then
- Begin
- m_cursor_mode := CURSOR_DEFAULT;
- update_cursor;
- Exit;
- End;
- If _option = 'show cursor' Then
- Begin
- m_cursor_mode := CURSOR_SHOW;
- update_cursor;
- Exit;
- End;
- If _option = 'hide cursor' Then
- Begin
- m_cursor_mode := CURSOR_HIDE;
- update_cursor;
- Exit;
- End;
- If System.Copy(_option, 1, 9) = 'frequency' Then
- Begin
- If Length(_option) > 9 Then
- Begin
- Val(System.Copy(_option, 10, Length(_option)-9), m_frequency, tmp);
- End
- Else
- m_frequency := 0;
- End;
- If _option = 'enable key buffering' Then
- Begin
- If m_keyboard = Nil Then
- Begin
- option := False;
- Exit;
- End;
- m_keyboard.enable;
- End;
- If _option = 'disable key buffering' Then
- Begin
- If m_keyboard = Nil Then
- Begin
- option := False;
- Exit;
- End;
- m_keyboard.disable;
- End;
- If _option = 'enable blocking' Then
- Begin
- m_primary.blocking(True);
- Exit;
- End;
- If _option = 'disable blocking' Then
- Begin
- m_primary.blocking(False);
- Exit;
- End;
- {$IFDEF PTC_LOGGING}
- If _option = 'enable logging' Then
- Begin
- LOG_enabled := True;
- option := True;
- Exit;
- End;
- If _option = 'disable logging' Then
- Begin
- LOG_enabled := False;
- option := True;
- Exit;
- End;
- {$ENDIF}
- option := m_copy.option(_option);
- End;
- Function TDirectXConsole.modes : PPTCMode;
- Begin
- modes := m_display.modes;
- End;
- Procedure TDirectXConsole.open(Const _title : String; _pages : Integer);
- Begin
- open(_title, m_default_format, _pages);
- End;
- Procedure TDirectXConsole.open(Const _title : String; Const _format : TPTCFormat;
- _pages : Integer);
- Begin
- open(_title, m_default_width, m_default_height, _format, _pages);
- End;
- Procedure TDirectXConsole.open(Const _title : String; _width, _height : Integer;
- Const _format : TPTCFormat; _pages : Integer);
- Var
- m : TPTCMode;
- Begin
- { internal open nearest mode }
- m := TPTCMode.Create(_width, _height, _format);
- Try
- internal_open(_title, 0, m, _pages, False);
- Finally
- m.Free;
- End;
- End;
- Procedure TDirectXConsole.open(Const _title : String; Const _mode : TPTCMode;
- _pages : Integer);
- Begin
- { internal open exact mode }
- internal_open(_title, 0, _mode, _pages, True);
- End;
- Procedure TDirectXConsole.close;
- Begin
- If m_open Then
- Begin
- If m_locked Then
- Raise TPTCError.Create('console is still locked');
- { flush all key presses }
- While KeyPressed Do
- ReadKey;
- End;
- internal_close;
- Win32Cursor_resurrect;
- End;
- Procedure TDirectXConsole.flush;
- Begin
- CHECK_OPEN('TDirectXConsole.flush');
- CHECK_LOCK('TDirectXConsole.flush');
- { [platform dependent code to flush all console operations] }
- { handle cursor show flag }
- If Not m_cursor Then
- SetCursor(0);
- { update window }
- m_window.update;
- End;
- Procedure TDirectXConsole.finish;
- Begin
- CHECK_OPEN('TDirectXConsole.finish');
- CHECK_LOCK('TDirectXConsole.finish');
- { [platform dependent code to finish all console operations] }
- { handle cursor show flag }
- If Not m_cursor Then
- SetCursor(0);
- { update window }
- m_window.update;
- End;
- Procedure TDirectXConsole.update;
- Begin
- CHECK_OPEN('TDirectXConsole.update');
- CHECK_LOCK('TDirectXConsole.update');
- { update primary surface }
- m_primary.update;
- { handle cursor show flag }
- If Not m_cursor Then
- SetCursor(0);
- { update window }
- m_window.update;
- End;
- Procedure TDirectXConsole.update(Const _area : TPTCArea);
- Begin
- { update }
- update;
- End;
- Procedure TDirectXConsole.internal_ReadKey(k : TPTCKey);
- Begin
- CHECK_OPEN('TDirectXConsole.internal_ReadKey');
- m_keyboard.internal_ReadKey(m_window, k);
- End;
- Function TDirectXConsole.internal_PeekKey(k : TPTCKey) : Boolean;
- Begin
- CHECK_OPEN('TDirectXConsole.internal_PeekKey');
- Result := m_keyboard.internal_PeekKey(m_window, k);
- End;
- Procedure TDirectXConsole.copy(Var surface : TPTCBaseSurface);
- Var
- pixels : Pointer;
- Begin
- CHECK_OPEN('TDirectXConsole.copy(surface)');
- CHECK_LOCK('TDirectXConsole.copy(surface)');
- pixels := lock;
- Try
- surface.load(pixels, width, height, pitch, format, palette);
- unlock;
- Except
- On error : TPTCError Do
- Begin
- unlock;
- Raise TPTCError.Create('failed to copy console to surface', error);
- End;
- End;
- End;
- Procedure TDirectXConsole.copy(Var surface : TPTCBaseSurface;
- Const source, destination : TPTCArea);
- Var
- pixels : Pointer;
- Begin
- CHECK_OPEN('TDirectXConsole.flush(surface, source, destination)');
- CHECK_LOCK('TDirectXConsole.flush(surface, source, destination)');
- pixels := lock;
- Try
- surface.load(pixels, width, height, pitch, format, palette, source, destination);
- unlock;
- Except
- On error : TPTCError Do
- Begin
- unlock;
- Raise TPTCError.Create('failed to copy console to surface', error);
- End;
- End;
- End;
- Function TDirectXConsole.lock : Pointer;
- Begin
- CHECK_OPEN('TDirectXConsole.lock');
- { fail if the console is already locked }
- If m_locked Then
- Raise TPTCError.Create('console is already locked');
- { lock primary surface }
- lock := m_primary.lock;
- { surface is locked }
- m_locked := True;
- End;
- Procedure TDirectXConsole.unlock;
- Begin
- CHECK_OPEN('TDirectXConsole.unlock');
- { fail if the console is not locked }
- If Not m_locked Then
- Raise TPTCError.Create('console is not locked');
- { unlock primary surface }
- m_primary.unlock;
- { we are unlocked }
- m_locked := False;
- End;
- Procedure TDirectXConsole.load(Const pixels : Pointer;
- _width, _height, _pitch : Integer;
- Const _format : TPTCFormat;
- Const _palette : TPTCPalette);
- Var
- Area_ : TPTCArea;
- console_pixels : Pointer;
- Begin
- CHECK_OPEN('TDirectXConsole.load(pixels, width, height, pitch, format, palette)');
- CHECK_LOCK('TDirectXConsole.load(pixels, width, height, pitch, format, palette)');
- If clip.Equals(area) Then
- Begin
- console_pixels := lock;
- Try
- Try
- m_copy.request(_format, format);
- m_copy.palette(_palette, palette);
- m_copy.copy(pixels, 0, 0, _width, _height, _pitch, console_pixels, 0, 0,
- width, height, pitch);
- Except
- On error : TPTCError Do
- Begin
- Raise TPTCError.Create('failed to load pixels to console', error);
- End;
- End;
- Finally
- unlock;
- End;
- End
- Else
- Begin
- Area_ := TPTCArea.Create(0, 0, width, height);
- Try
- load(pixels, _width, _height, _pitch, _format, _palette, Area_, area);
- Finally
- Area_.Free;
- End;
- End;
- End;
- Procedure TDirectXConsole.load(Const pixels : Pointer;
- _width, _height, _pitch : Integer;
- Const _format : TPTCFormat;
- Const _palette : TPTCPalette;
- Const source, destination : TPTCArea);
- Var
- console_pixels : Pointer;
- clipped_source, clipped_destination : TPTCArea;
- tmp : TPTCArea;
- Begin
- CHECK_OPEN('TDirectXConsole.load(pixels, width, height, pitch, format, palette, source, destination)');
- CHECK_LOCK('TDirectXConsole.load(pixels, width, height, pitch, format, palette, source, destination)');
- clipped_destination := Nil;
- clipped_source := TPTCArea.Create;
- Try
- clipped_destination := TPTCArea.Create;
- console_pixels := lock;
- Try
- Try
- tmp := TPTCArea.Create(0, 0, _width, _height);
- Try
- TPTCClipper.clip(source, tmp, clipped_source, destination, clip, clipped_destination);
- Finally
- tmp.Free;
- End;
- m_copy.request(_format, format);
- m_copy.palette(_palette, palette);
- m_copy.copy(pixels, clipped_source.left, clipped_source.top, clipped_source.width, clipped_source.height, _pitch,
- console_pixels, clipped_destination.left, clipped_destination.top, clipped_destination.width, clipped_destination.height, pitch);
- Except
- On error:TPTCError Do
- Begin
- Raise TPTCError.Create('failed to load pixels to console area', error);
- End;
- End;
- Finally
- unlock;
- End;
- Finally
- clipped_source.Free;
- clipped_destination.Free;
- End;
- End;
- Procedure TDirectXConsole.save(pixels : Pointer;
- _width, _height, _pitch : Integer;
- Const _format : TPTCFormat;
- Const _palette : TPTCPalette);
- Var
- Area_ : TPTCArea;
- console_pixels : Pointer;
- Begin
- CHECK_OPEN('TDirectXConsole.save(pixels, width, height, pitch, format, palette)');
- CHECK_LOCK('TDirectXConsole.save(pixels, width, height, pitch, format, palette)');
- If clip.Equals(area) Then
- Begin
- console_pixels := lock;
- Try
- Try
- m_copy.request(format, _format);
- m_copy.palette(palette, _palette);
- m_copy.copy(console_pixels, 0, 0, width, height, pitch, pixels, 0, 0,
- _width, _height, _pitch);
- Except
- On error : TPTCError Do
- Begin
- Raise TPTCError.Create('failed to save console pixels', error);
- End;
- End;
- Finally
- unlock;
- End;
- End
- Else
- Begin
- Area_ := TPTCArea.Create(0, 0, width, height);
- Try
- save(pixels, _width, _height, _pitch, _format, _palette, area, Area_);
- Finally
- Area_.Free;
- End;
- End;
- End;
- Procedure TDirectXConsole.save(pixels : Pointer;
- _width, _height, _pitch : Integer;
- Const _format : TPTCFormat;
- Const _palette : TPTCPalette;
- Const source, destination : TPTCArea);
- Var
- console_pixels : Pointer;
- clipped_source, clipped_destination : TPTCArea;
- tmp : TPTCArea;
- Begin
- CHECK_OPEN('TDirectXConsole.save(pixels, width, height, pitch, format, palette, source, destination)');
- CHECK_LOCK('TDirectXConsole.save(pixels, width, height, pitch, format, palette, source, destination)');
- clipped_destination := Nil;
- clipped_source := TPTCArea.Create;
- Try
- clipped_destination := TPTCArea.Create;
- console_pixels := lock;
- Try
- Try
- tmp := TPTCArea.Create(0, 0, _width, _height);
- Try
- TPTCClipper.clip(source, clip, clipped_source, destination, tmp, clipped_destination);
- Finally
- tmp.Free;
- End;
- m_copy.request(format, _format);
- m_copy.palette(palette, _palette);
- m_copy.copy(console_pixels, clipped_source.left, clipped_source.top, clipped_source.width, clipped_source.height, pitch,
- pixels, clipped_destination.left, clipped_destination.top, clipped_destination.width, clipped_destination.height, _pitch);
- Except
- On error:TPTCError Do
- Begin
- Raise TPTCError.Create('failed to save console area pixels', error);
- End;
- End;
- Finally
- unlock;
- End;
- Finally
- clipped_source.Free;
- clipped_destination.Free;
- End;
- End;
- Procedure TDirectXConsole.clear;
- Var
- tmp : TPTCColor;
- Begin
- CHECK_OPEN('TDirectXConsole.clear');
- CHECK_LOCK('TDirectXConsole.clear');
- If format.direct Then
- tmp := TPTCColor.Create(0, 0, 0, 0)
- Else
- tmp := TPTCColor.Create(0);
- Try
- clear(tmp);
- Finally
- tmp.Free;
- End;
- End;
- Procedure TDirectXConsole.clear(Const color : TPTCColor);
- Var
- tmp : TPTCArea;
- Begin
- CHECK_OPEN('TDirectXConsole.clear(color)');
- CHECK_LOCK('TDirectXConsole.clear(color)');
- tmp := TPTCArea.Create;
- Try
- clear(color, tmp);
- Finally
- tmp.Free;
- End;
- End;
- Procedure TDirectXConsole.clear(Const color : TPTCColor;
- Const _area : TPTCArea);
- Begin
- CHECK_OPEN('TDirectXConsole.clear(color, area)');
- CHECK_LOCK('TDirectXConsole.clear(color, area)');
- m_primary.clear(color, _area);
- End;
- Procedure TDirectXConsole.palette(Const _palette : TPTCPalette);
- Begin
- CHECK_OPEN('TDirectXConsole.palette(palette)');
- m_primary.palette(_palette);
- End;
- Function TDirectXConsole.palette : TPTCPalette;
- Begin
- CHECK_OPEN('TDirectXConsole.palette');
- palette := m_primary.palette;
- End;
- Procedure TDirectXConsole.clip(Const _area : TPTCArea);
- Begin
- CHECK_OPEN('TDirectXConsole.clip(area)');
- m_primary.clip(_area);
- End;
- Function TDirectXConsole.width : Integer;
- Begin
- CHECK_OPEN('TDirectXConsole.width');
- width := m_primary.width;
- End;
- Function TDirectXConsole.height : Integer;
- Begin
- CHECK_OPEN('TDirectXConsole.height');
- height := m_primary.height;
- End;
- Function TDirectXConsole.pitch : Integer;
- Begin
- CHECK_OPEN('TDirectXConsole.pitch');
- pitch := m_primary.pitch;
- End;
- Function TDirectXConsole.pages : Integer;
- Begin
- CHECK_OPEN('TDirectXConsole.pages');
- pages := m_primary.pages;
- End;
- Function TDirectXConsole.area : TPTCArea;
- Begin
- CHECK_OPEN('TDirectXConsole.area');
- area := m_primary.area;
- End;
- Function TDirectXConsole.clip : TPTCArea;
- Begin
- CHECK_OPEN('TDirectXConsole.clip');
- clip := m_primary.clip;
- End;
- Function TDirectXConsole.format : TPTCFormat;
- Begin
- CHECK_OPEN('TDirectXConsole.format');
- format := m_primary.format;
- End;
- Function TDirectXConsole.name : String;
- Begin
- name := 'DirectX';
- End;
- Function TDirectXConsole.title : String;
- Begin
- CHECK_OPEN('TDirectXConsole.title');
- title := m_title;
- End;
- Function TDirectXConsole.information : String;
- Begin
- CHECK_OPEN('TDirectXConsole.information');
- information := m_display.information;
- End;
- Procedure TDirectXConsole.internal_open(Const _title : String; window : HWND; Const mode : TPTCMode; _pages : Integer; exact : Boolean);
- Var
- _width, _height : Integer;
- _format : TPTCFormat;
- Begin
- Try
- { recycle an already open console }
- internal_recycle(_title, window, mode, _pages, exact);
- Exit;
- Except
- On TPTCError Do
- { could not recycle };
- End;
- { check that the mode is valid }
- If Not mode.valid Then
- Raise TPTCError.Create('invalid mode');
- { get mode information }
- _width := mode.width;
- _height := mode.height;
- _format := mode.format;
- { start internal open }
- internal_open_start(_title, window);
- { check output mode }
- Case m_output_mode Of
- DEFAULT :
- Try
- { start fullscreen open }
- internal_open_fullscreen_start(window, mode, exact);
- { change fullscreen display }
- internal_open_fullscreen_change(mode, exact);
- { setup fullscreen display surfaces }
- internal_open_fullscreen_surface(mode, _pages);
- { finish fullscreen open }
- internal_open_fullscreen_finish;
- Except
- On TPTCError Do
- Begin
- { internal open reset }
- internal_open_reset;
- { start windowed open }
- internal_open_windowed_start(window, mode, exact);
- { change windowed display display mode }
- internal_open_windowed_change(mode, exact);
- { setup windowed display }
- internal_open_windowed_surface(mode, _pages);
- { finish windowed open }
- internal_open_windowed_finish;
- End;
- End;
- WINDOWED : Begin
- { start windowed open }
- internal_open_windowed_start(window, mode, exact);
- { change windowed display display mode }
- internal_open_windowed_change(mode, exact);
- { setup windowed display }
- internal_open_windowed_surface(mode, _pages);
- { finish windowed open }
- internal_open_windowed_finish;
- End;
- FULLSCREEN : Begin
- { start fullscreen open }
- internal_open_fullscreen_start(window, mode, exact);
- { change fullscreen display }
- internal_open_fullscreen_change(mode, exact);
- { setup fullscreen display surfaces }
- internal_open_fullscreen_surface(mode, _pages);
- { finish fullscreen open }
- internal_open_fullscreen_finish;
- End;
- End;
- { finish internal open }
- internal_open_finish;
- End;
- Procedure TDirectXConsole.internal_recycle(Const _title : String; window : HWND; Const mode : TPTCMode; _pages : Integer; exact : Boolean);
- Begin
- { Check if the console is open }
- If not m_open Then
- Raise TPTCError.Create('cannot recycle because it is not already open');
- If window <> 0 Then
- Begin
- If (m_window.handle <> window) Or (Not (m_window.managed)) Then
- Raise TPTCError.Create('cannot recycle with this user window');
- End;
- Case m_output_mode Of
- DEFAULT :
- If m_display.fullscreen Then
- Begin
- Try
- internal_recycle_fullscreen(_title, window, mode, _pages, exact);
- Except
- On TPTCError Do
- Raise TPTCError.Create('recycling fullscreen to windowed is not implemented');
- End;
- End
- Else
- Raise TPTCError.Create('recycling windowed to fullscreen is not implemented');
- FULLSCREEN : internal_recycle_fullscreen(_title, window, mode, _pages, exact);
- WINDOWED : internal_recycle_fullscreen(_title, window, mode, _pages, exact);
- End;
- End;
- Procedure TDirectXConsole.internal_close;
- Begin
- m_open := False;
- FreeAndNil(m_keyboard);
- FreeAndNil(m_hook);
- If m_primary <> Nil Then
- m_primary.close;
- If m_display <> Nil Then
- m_display.close;
- FreeAndNil(m_window);
- If m_display <> Nil Then
- m_display.restore;
- End;
- Procedure TDirectXConsole.internal_shutdown;
- Begin
- m_library.close;
- End;
- Procedure TDirectXConsole.internal_open_start(Const _title : String; window : HWND);
- Var
- tmp : Array[0..1023] Of Char;
- Begin
- { close_down }
- internal_close;
- { check window }
- If window = 0 Then
- Begin
- m_title := _title;
- End
- Else
- Begin
- GetWindowText(window, @tmp, SizeOf(tmp));
- m_title := PChar2String(@tmp);
- End;
- End;
- Procedure TDirectXConsole.internal_open_finish;
- Begin
- FreeAndNil(m_keyboard);
- m_keyboard := TWin32Keyboard.Create(m_window.handle, m_window.thread, False);
- m_window.update;
- m_open := True;
- End;
- Procedure TDirectXConsole.internal_open_reset;
- Begin
- FreeAndNil(m_keyboard);
- FreeAndNil(m_hook);
- m_primary.close;
- FreeAndNil(m_window);
- m_display.restore;
- End;
- Procedure TDirectXConsole.internal_open_fullscreen_start(window : HWND; Const mode : TPTCMode; exact : Boolean);
- Begin
- { test if display mode exists... }
- If Not m_display.test(mode, exact) Then
- Raise TPTCError.Create('display mode test failed!');
- { handle cursor show mode }
- If m_cursor_mode = CURSOR_SHOW Then
- m_cursor := True
- Else
- m_cursor := False;
- { save display }
- m_display.save;
- { check window }
- If window = 0 Then
- 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)
- Else
- m_window := TWin32Window.Create(window);
- { set window cursor }
- m_window.cursor(m_cursor);
- { set cooperative level }
- m_display.cooperative(m_window.handle, True);
- End;
- Procedure TDirectXConsole.internal_open_fullscreen_change(Const mode : TPTCMode; exact : Boolean);
- Begin
- m_display.open(mode, exact, m_frequency);
- m_primary.blocking(True);
- End;
- Procedure TDirectXConsole.internal_open_fullscreen_surface(Const mode : TPTCMode; _pages : Integer);
- Var
- primary : Boolean;
- _secondary : Boolean;
- _palette : Boolean;
- complex : Boolean;
- Begin
- _secondary := (m_primary_mode_fullscreen = SECONDARY) Or (Not m_display.mode.Equals(mode));
- _palette := m_display.mode.format.indexed;
- m_primary.initialize(m_window, m_library.lpDD2);
- complex := False;
- primary := False;
- { randy heit's primary setup }
- While (Not primary) And (Not complex) Do
- Begin
- If _pages >= 1 Then
- Try
- m_primary.primary(_pages, True, True, _palette, complex);
- primary := True;
- Except
- On TPTCError Do;
- End;
- If Not primary Then
- Try
- m_primary.primary(3, True, True, _palette, complex);
- primary := True;
- Except
- On TPTCError Do
- Try
- m_primary.primary(2, True, True, _palette, complex);
- primary := True;
- Except
- On TPTCError Do
- Try
- If Not _secondary Then
- m_primary.primary(2, False, True, _palette, complex)
- Else
- m_primary.primary(1, False, True, _palette, complex);
- primary := True;
- Except
- On TPTCError Do
- complex := Not complex;
- End;
- End;
- End;
- End;
- If _secondary Then
- m_primary.secondary(mode.width, mode.height);
- If m_nearest_mode = NEAREST_CENTERING Then
- m_primary.centering(True);
- If m_nearest_mode = NEAREST_STRETCHING Then
- m_primary.centering(False);
- {
- original primary setup code (1.0.17)
- ...
- }
- m_primary.synchronize(m_synchronized_update);
- End;
- Procedure TDirectXConsole.internal_open_fullscreen_finish;
- Begin
- FreeAndNil(m_hook);
- { create hook on window }
- m_hook := TDirectXHook.Create(Self, m_window.handle, GetCurrentThreadId, m_cursor, m_window.managed, True);
- End;
- Procedure TDirectXConsole.internal_open_windowed_start(window : HWND; Const mode : TPTCMode; exact : Boolean);
- Var
- extended : Integer;
- Begin
- If m_cursor_mode = CURSOR_HIDE Then
- m_cursor := False
- Else
- m_cursor := True;
- FreeAndNil(m_window);
- If window <> 0 Then
- Begin
- m_window := TWin32Window.Create(window);
- End
- Else
- Begin
- extended := 0;
- If m_primary_mode_windowed = DIRECT Then
- extended := WS_EX_TOPMOST;
- Case m_window_mode Of
- RESIZABLE : m_window := TWin32Window.Create('PTC_DIRECTX_WINDOWED_RESIZABLE', m_title,
- extended, WS_OVERLAPPEDWINDOW Or WS_VISIBLE, SW_NORMAL, CW_USEDEFAULT, CW_USEDEFAULT, mode.width, mode.height, m_center_window, False);
- FIXED : m_window := TWin32Window.Create('PTC_DIRECTX_WINDOWED_FIXED', m_title,
- 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);
- End;
- End;
- m_window.cursor(m_cursor);
- m_display.cooperative(m_window.handle, False);
- End;
- Procedure TDirectXConsole.internal_open_windowed_change(Const mode : TPTCMode; exact : Boolean);
- Begin
- m_display.open;
- If m_primary_mode_windowed = DIRECT Then
- m_primary.blocking(True)
- Else
- m_primary.blocking(False);
- End;
- Procedure TDirectXConsole.internal_open_windowed_surface(Const mode : TPTCMode; _pages : Integer);
- Begin
- m_primary.initialize(m_window, m_library.lpDD2);
- m_primary.primary(1, False, False, False, False);
- If m_primary_mode_windowed = SECONDARY Then
- m_primary.secondary(mode.width, mode.height);
- End;
- Procedure TDirectXConsole.internal_open_windowed_finish;
- Begin
- FreeAndNil(m_hook);
- { create hook on window }
- m_hook := TDirectXHook.Create(Self, m_window.handle, GetCurrentThreadId, m_cursor, m_window.managed, False);
- End;
- Procedure TDirectXConsole.internal_recycle_fullscreen(Const _title : String; window : HWND; Const mode : TPTCMode; _pages : Integer; exact : Boolean);
- Begin
- LOG('fullscreen open recycle');
- m_primary.close;
- internal_open_fullscreen_change(mode, exact);
- internal_open_fullscreen_surface(mode, _pages);
- End;
- Procedure TDirectXConsole.internal_recycle_windowed(Const _title : String; window : HWND; Const mode : TPTCMode; _pages : Integer; exact : Boolean);
- Begin
- LOG('windowed open recycle');
- m_primary.close;
- m_window.resize(mode.width, mode.height);
- internal_open_windowed_change(mode, exact);
- internal_open_windowed_surface(mode, _pages);
- End;
- Procedure TDirectXConsole.paint;
- Begin
- If m_locked Or (Not m_open) Then
- Exit;
- m_primary.paint;
- End;
- Procedure TDirectXConsole.update_cursor;
- Begin
- If Not m_open Then
- Exit;
- If m_display.fullscreen Then
- If m_cursor_mode = CURSOR_SHOW Then
- m_cursor := True
- Else
- m_cursor := False
- Else
- If m_cursor_mode = CURSOR_HIDE Then
- m_cursor := False
- Else
- m_cursor := True;
- { update hook cursor }
- m_hook.cursor(m_cursor);
- { update window cursor }
- m_window.cursor(m_cursor);
- End;
- {$IFDEF DEBUG}
- Procedure TDirectXConsole.CHECK_OPEN(msg : String);
- Begin
- If Not m_open Then
- Try
- Raise TPTCError.Create('console is not open');
- Except
- On error : TPTCError Do
- Raise TPTCError.Create(msg, error);
- End;
- End;
- Procedure TDirectXConsole.CHECK_LOCK(msg : String);
- Begin
- If m_locked Then
- Try
- Raise TPTCError.Create('console is locked');
- Except
- On error : TPTCError Do
- Raise TPTCError.Create(msg, error);
- End;
- End;
- {$ENDIF}
|