diff options
Diffstat (limited to 'packages/ptc/src/win32/directx/directxconsole.inc')
| -rw-r--r-- | packages/ptc/src/win32/directx/directxconsole.inc | 1315 |
1 files changed, 1315 insertions, 0 deletions
diff --git a/packages/ptc/src/win32/directx/directxconsole.inc b/packages/ptc/src/win32/directx/directxconsole.inc new file mode 100644 index 0000000000..a775448538 --- /dev/null +++ b/packages/ptc/src/win32/directx/directxconsole.inc @@ -0,0 +1,1315 @@ +{ + Free Pascal port of the OpenPTC C++ library. + Copyright (C) 2001-2003 Nikolay Nikolov (nickysn@users.sourceforge.net) + Original C++ version by Glenn Fiedler (ptc@gaffer.org) + + 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} |