* updated ptc

git-svn-id: trunk@16018 -

.gitattributes

@@ -5016,13 +5016,14 @@ packages/proj4/fpmake.pp svneol=native#text/plain
 packages/proj4/src/proj.pas svneol=native#text/plain
 packages/ptc/Makefile svneol=native#text/plain
 packages/ptc/Makefile.fpc svneol=native#text/plain
-packages/ptc/docs/AUTHORS -text
-packages/ptc/docs/CHANGES -text
-packages/ptc/docs/INSTALL -text
-packages/ptc/docs/INTRO -text
+packages/ptc/docs/AUTHORS.txt svneol=native#text/plain
+packages/ptc/docs/CHANGES.txt svneol=native#text/plain
+packages/ptc/docs/INSTALL.txt svneol=native#text/plain
+packages/ptc/docs/INTRO.txt svneol=native#text/plain
 packages/ptc/docs/README.txt svneol=native#text/plain
 packages/ptc/docs/TODO.txt svneol=native#text/plain
-packages/ptc/docs/lgpl.txt -text
+packages/ptc/docs/lgpl.txt svneol=native#text/plain
+packages/ptc/docs/modified_lgpl.txt svneol=native#text/plain
 packages/ptc/examples/Makefile svneol=native#text/plain
 packages/ptc/examples/Makefile.fpc svneol=native#text/plain
 packages/ptc/examples/area.pp svneol=native#text/plain
@@ -5037,12 +5038,13 @@ packages/ptc/examples/hicolor.pp svneol=native#text/plain
 packages/ptc/examples/image.pp svneol=native#text/plain
 packages/ptc/examples/image.tga -text
 packages/ptc/examples/keyboard.pp svneol=native#text/plain
-packages/ptc/examples/keybrd2.pp svneol=native#text/plain
+packages/ptc/examples/keyboard2.pp svneol=native#text/plain
 packages/ptc/examples/land.pp svneol=native#text/plain
 packages/ptc/examples/lights.pp svneol=native#text/plain
 packages/ptc/examples/modes.pp svneol=native#text/plain
 packages/ptc/examples/mojo.pp svneol=native#text/plain
 packages/ptc/examples/mojo.raw -text svneol=unset#raw/binary
+packages/ptc/examples/mouse.pp svneol=native#text/plain
 packages/ptc/examples/palette.pp svneol=native#text/plain
 packages/ptc/examples/pixel.pp svneol=native#text/plain
 packages/ptc/examples/random.pp svneol=native#text/plain
@@ -5055,161 +5057,169 @@ packages/ptc/examples/tunnel.pp svneol=native#text/plain
 packages/ptc/examples/tunnel3d.pp svneol=native#text/plain
 packages/ptc/examples/tunnel3d.raw -text svneol=unset#raw/binary
 packages/ptc/fpmake_disabled.pp svneol=native#text/plain
-packages/ptc/src/aread.inc svneol=native#text/x-pascal
-packages/ptc/src/areai.inc svneol=native#text/x-pascal
-packages/ptc/src/baseconsoled.inc svneol=native#text/x-pascal
-packages/ptc/src/baseconsolei.inc svneol=native#text/x-pascal
-packages/ptc/src/basesurfaced.inc svneol=native#text/x-pascal
-packages/ptc/src/basesurfacei.inc svneol=native#text/x-pascal
-packages/ptc/src/c_api/area.inc -text
-packages/ptc/src/c_api/aread.inc -text
-packages/ptc/src/c_api/clear.inc -text
-packages/ptc/src/c_api/cleard.inc -text
-packages/ptc/src/c_api/clipper.inc -text
-packages/ptc/src/c_api/clipperd.inc -text
-packages/ptc/src/c_api/color.inc -text
-packages/ptc/src/c_api/colord.inc -text
-packages/ptc/src/c_api/console.inc -text
-packages/ptc/src/c_api/consoled.inc -text
-packages/ptc/src/c_api/copy.inc -text
-packages/ptc/src/c_api/copyd.inc -text
-packages/ptc/src/c_api/error.inc -text
-packages/ptc/src/c_api/errord.inc -text
-packages/ptc/src/c_api/except.inc -text
-packages/ptc/src/c_api/exceptd.inc -text
-packages/ptc/src/c_api/format.inc -text
-packages/ptc/src/c_api/formatd.inc -text
-packages/ptc/src/c_api/index.inc -text
-packages/ptc/src/c_api/key.inc -text
-packages/ptc/src/c_api/keyd.inc -text
-packages/ptc/src/c_api/mode.inc -text
-packages/ptc/src/c_api/moded.inc -text
-packages/ptc/src/c_api/palette.inc -text
-packages/ptc/src/c_api/paletted.inc -text
-packages/ptc/src/c_api/surface.inc -text
-packages/ptc/src/c_api/surfaced.inc -text
-packages/ptc/src/c_api/timer.inc -text
-packages/ptc/src/c_api/timerd.inc -text
-packages/ptc/src/cleard.inc svneol=native#text/x-pascal
-packages/ptc/src/cleari.inc svneol=native#text/x-pascal
-packages/ptc/src/clipperd.inc svneol=native#text/x-pascal
-packages/ptc/src/clipperi.inc svneol=native#text/x-pascal
-packages/ptc/src/colord.inc svneol=native#text/x-pascal
-packages/ptc/src/colori.inc svneol=native#text/x-pascal
-packages/ptc/src/consoled.inc svneol=native#text/x-pascal
-packages/ptc/src/consolei.inc svneol=native#text/x-pascal
-packages/ptc/src/copyd.inc svneol=native#text/x-pascal
-packages/ptc/src/copyi.inc svneol=native#text/x-pascal
-packages/ptc/src/coreimplementation.inc svneol=native#text/x-pascal
-packages/ptc/src/coreinterface.inc svneol=native#text/x-pascal
-packages/ptc/src/dos/base/kbd.inc -text
-packages/ptc/src/dos/base/kbdd.inc -text
-packages/ptc/src/dos/cga/cga.pp -text
-packages/ptc/src/dos/cga/console.inc -text
-packages/ptc/src/dos/cga/consoled.inc -text
-packages/ptc/src/dos/fakemode/console.inc -text
-packages/ptc/src/dos/fakemode/consoled.inc -text
-packages/ptc/src/dos/fakemode/vga.pp -text
-packages/ptc/src/dos/textfx2/console.inc -text
-packages/ptc/src/dos/textfx2/consoled.inc -text
-packages/ptc/src/dos/textfx2/textfx2.pp -text
-packages/ptc/src/dos/timeunit/timeunit.pp -text
-packages/ptc/src/dos/vesa/console.inc -text
-packages/ptc/src/dos/vesa/consoled.inc -text
-packages/ptc/src/dos/vesa/vesa.pp -text
-packages/ptc/src/errord.inc svneol=native#text/x-pascal
-packages/ptc/src/errori.inc svneol=native#text/x-pascal
-packages/ptc/src/eventd.inc svneol=native#text/x-pascal
-packages/ptc/src/eventi.inc svneol=native#text/x-pascal
-packages/ptc/src/formatd.inc svneol=native#text/x-pascal
-packages/ptc/src/formati.inc svneol=native#text/x-pascal
-packages/ptc/src/keyd.inc svneol=native#text/x-pascal
-packages/ptc/src/keyeventd.inc svneol=native#text/x-pascal
-packages/ptc/src/keyeventi.inc svneol=native#text/x-pascal
-packages/ptc/src/keyi.inc svneol=native#text/x-pascal
-packages/ptc/src/log.inc svneol=native#text/x-pascal
-packages/ptc/src/moded.inc svneol=native#text/x-pascal
-packages/ptc/src/modei.inc svneol=native#text/x-pascal
-packages/ptc/src/mouseeventd.inc svneol=native#text/x-pascal
-packages/ptc/src/mouseeventi.inc svneol=native#text/x-pascal
-packages/ptc/src/paletted.inc svneol=native#text/x-pascal
-packages/ptc/src/palettei.inc svneol=native#text/x-pascal
+packages/ptc/src/c_api/area.inc svneol=native#text/plain
+packages/ptc/src/c_api/aread.inc svneol=native#text/plain
+packages/ptc/src/c_api/clear.inc svneol=native#text/plain
+packages/ptc/src/c_api/cleard.inc svneol=native#text/plain
+packages/ptc/src/c_api/clipper.inc svneol=native#text/plain
+packages/ptc/src/c_api/clipperd.inc svneol=native#text/plain
+packages/ptc/src/c_api/color.inc svneol=native#text/plain
+packages/ptc/src/c_api/colord.inc svneol=native#text/plain
+packages/ptc/src/c_api/console.inc svneol=native#text/plain
+packages/ptc/src/c_api/consoled.inc svneol=native#text/plain
+packages/ptc/src/c_api/copy.inc svneol=native#text/plain
+packages/ptc/src/c_api/copyd.inc svneol=native#text/plain
+packages/ptc/src/c_api/error.inc svneol=native#text/plain
+packages/ptc/src/c_api/errord.inc svneol=native#text/plain
+packages/ptc/src/c_api/except.inc svneol=native#text/plain
+packages/ptc/src/c_api/exceptd.inc svneol=native#text/plain
+packages/ptc/src/c_api/format.inc svneol=native#text/plain
+packages/ptc/src/c_api/formatd.inc svneol=native#text/plain
+packages/ptc/src/c_api/index.inc svneol=native#text/plain
+packages/ptc/src/c_api/key.inc svneol=native#text/plain
+packages/ptc/src/c_api/keyd.inc svneol=native#text/plain
+packages/ptc/src/c_api/mode.inc svneol=native#text/plain
+packages/ptc/src/c_api/moded.inc svneol=native#text/plain
+packages/ptc/src/c_api/palette.inc svneol=native#text/plain
+packages/ptc/src/c_api/paletted.inc svneol=native#text/plain
+packages/ptc/src/c_api/surface.inc svneol=native#text/plain
+packages/ptc/src/c_api/surfaced.inc svneol=native#text/plain
+packages/ptc/src/c_api/timer.inc svneol=native#text/plain
+packages/ptc/src/c_api/timerd.inc svneol=native#text/plain
+packages/ptc/src/core/aread.inc svneol=native#text/plain
+packages/ptc/src/core/areai.inc svneol=native#text/plain
+packages/ptc/src/core/baseconsoled.inc svneol=native#text/plain
+packages/ptc/src/core/baseconsolei.inc svneol=native#text/plain
+packages/ptc/src/core/basesurfaced.inc svneol=native#text/plain
+packages/ptc/src/core/basesurfacei.inc svneol=native#text/plain
+packages/ptc/src/core/cleard.inc svneol=native#text/plain
+packages/ptc/src/core/cleari.inc svneol=native#text/plain
+packages/ptc/src/core/clipperd.inc svneol=native#text/plain
+packages/ptc/src/core/clipperi.inc svneol=native#text/plain
+packages/ptc/src/core/colord.inc svneol=native#text/plain
+packages/ptc/src/core/colori.inc svneol=native#text/plain
+packages/ptc/src/core/consoled.inc svneol=native#text/plain
+packages/ptc/src/core/consolei.inc svneol=native#text/plain
+packages/ptc/src/core/copyd.inc svneol=native#text/plain
+packages/ptc/src/core/copyi.inc svneol=native#text/plain
+packages/ptc/src/core/coreimplementation.inc svneol=native#text/plain
+packages/ptc/src/core/coreinterface.inc svneol=native#text/plain
+packages/ptc/src/core/errord.inc svneol=native#text/plain
+packages/ptc/src/core/errori.inc svneol=native#text/plain
+packages/ptc/src/core/eventd.inc svneol=native#text/plain
+packages/ptc/src/core/eventi.inc svneol=native#text/plain
+packages/ptc/src/core/formatd.inc svneol=native#text/plain
+packages/ptc/src/core/formati.inc svneol=native#text/plain
+packages/ptc/src/core/keyeventd.inc svneol=native#text/plain
+packages/ptc/src/core/keyeventi.inc svneol=native#text/plain
+packages/ptc/src/core/log.inc svneol=native#text/plain
+packages/ptc/src/core/moded.inc svneol=native#text/plain
+packages/ptc/src/core/modei.inc svneol=native#text/plain
+packages/ptc/src/core/mouseeventd.inc svneol=native#text/plain
+packages/ptc/src/core/mouseeventi.inc svneol=native#text/plain
+packages/ptc/src/core/paletted.inc svneol=native#text/plain
+packages/ptc/src/core/palettei.inc svneol=native#text/plain
+packages/ptc/src/core/surfaced.inc svneol=native#text/plain
+packages/ptc/src/core/surfacei.inc svneol=native#text/plain
+packages/ptc/src/core/timerd.inc svneol=native#text/plain
+packages/ptc/src/core/timeri.inc svneol=native#text/plain
+packages/ptc/src/dos/base/go32fix.pp svneol=native#text/plain
+packages/ptc/src/dos/base/kbd.inc svneol=native#text/plain
+packages/ptc/src/dos/base/kbdd.inc svneol=native#text/plain
+packages/ptc/src/dos/base/mouse33h.pp svneol=native#text/plain
+packages/ptc/src/dos/base/moused.inc svneol=native#text/plain
+packages/ptc/src/dos/base/mousei.inc svneol=native#text/plain
+packages/ptc/src/dos/cga/cga.pp svneol=native#text/plain
+packages/ptc/src/dos/cga/cgaconsoled.inc svneol=native#text/plain
+packages/ptc/src/dos/cga/cgaconsolei.inc svneol=native#text/plain
+packages/ptc/src/dos/includes.inc svneol=native#text/plain
+packages/ptc/src/dos/textfx2/textfx2.pp svneol=native#text/plain
+packages/ptc/src/dos/textfx2/textfx2consoled.inc svneol=native#text/plain
+packages/ptc/src/dos/textfx2/textfx2consolei.inc svneol=native#text/plain
+packages/ptc/src/dos/timeunit/timeunit.pp svneol=native#text/plain
+packages/ptc/src/dos/vesa/vesa.pp svneol=native#text/plain
+packages/ptc/src/dos/vesa/vesaconsoled.inc svneol=native#text/plain
+packages/ptc/src/dos/vesa/vesaconsolei.inc svneol=native#text/plain
+packages/ptc/src/dos/vga/vga.pp svneol=native#text/plain
+packages/ptc/src/dos/vga/vgaconsoled.inc svneol=native#text/plain
+packages/ptc/src/dos/vga/vgaconsolei.inc svneol=native#text/plain
 packages/ptc/src/ptc.pp svneol=native#text/plain
 packages/ptc/src/ptcpas.cfg svneol=native#text/plain
-packages/ptc/src/surfaced.inc svneol=native#text/x-pascal
-packages/ptc/src/surfacei.inc svneol=native#text/x-pascal
-packages/ptc/src/timerd.inc svneol=native#text/x-pascal
-packages/ptc/src/timeri.inc svneol=native#text/x-pascal
-packages/ptc/src/tinyptc/tinyptc.pp -text
-packages/ptc/src/win32/base/cursor.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/base/event.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/base/eventd.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/base/hook.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/base/hookd.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/base/kbd.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/base/kbdd.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/base/monitor.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/base/monitord.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/base/moused.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/base/mousei.inc svneol=native#text/x-pascal
+packages/ptc/src/ptcwrapper/ptceventqueue.pp svneol=native#text/plain
+packages/ptc/src/ptcwrapper/ptcwrapper.pp svneol=native#text/plain
+packages/ptc/src/tinyptc/tinyptc.pp svneol=native#text/plain
+packages/ptc/src/win32/base/cursor.inc svneol=native#text/plain
+packages/ptc/src/win32/base/cursord.inc svneol=native#text/plain
+packages/ptc/src/win32/base/cursormoded.inc svneol=native#text/plain
+packages/ptc/src/win32/base/event.inc svneol=native#text/plain
+packages/ptc/src/win32/base/eventd.inc svneol=native#text/plain
+packages/ptc/src/win32/base/hook.inc svneol=native#text/plain
+packages/ptc/src/win32/base/hookd.inc svneol=native#text/plain
+packages/ptc/src/win32/base/kbd.inc svneol=native#text/plain
+packages/ptc/src/win32/base/kbdd.inc svneol=native#text/plain
+packages/ptc/src/win32/base/monitor.inc svneol=native#text/plain
+packages/ptc/src/win32/base/monitord.inc svneol=native#text/plain
+packages/ptc/src/win32/base/moused.inc svneol=native#text/plain
+packages/ptc/src/win32/base/mousei.inc svneol=native#text/plain
 packages/ptc/src/win32/base/ptcres.rc -text
 packages/ptc/src/win32/base/ptcres.res -text
-packages/ptc/src/win32/base/window.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/base/windowd.inc svneol=native#text/x-pascal
+packages/ptc/src/win32/base/window.inc svneol=native#text/plain
+packages/ptc/src/win32/base/windowd.inc svneol=native#text/plain
 packages/ptc/src/win32/base/windows.ico -text
-packages/ptc/src/win32/directx/check.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/directx/directdr.pp -text
-packages/ptc/src/win32/directx/directxconsole.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/directx/directxconsoled.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/directx/display.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/directx/displayd.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/directx/hook.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/directx/hookd.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/directx/library.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/directx/libraryd.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/directx/primary.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/directx/primaryd.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/directx/translate.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/gdi/gdiconsoled.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/gdi/gdiconsolei.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/gdi/win32dibd.inc svneol=native#text/x-pascal
-packages/ptc/src/win32/gdi/win32dibi.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/base/wincekeyboardd.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/base/wincekeyboardi.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/base/wincemoused.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/base/wincemousei.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/base/wincewindowd.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/base/wincewindowi.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/gapi/p_gx.pp svneol=native#text/x-pascal
-packages/ptc/src/wince/gapi/wincegapiconsoled.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/gapi/wincegapiconsolei.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/gdi/wincebitmapinfod.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/gdi/wincebitmapinfoi.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/gdi/wincegdiconsoled.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/gdi/wincegdiconsolei.inc svneol=native#text/x-pascal
-packages/ptc/src/wince/includes.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/check.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/extensions.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/includes.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11consoled.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11consolei.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11dga1displayd.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11dga1displayi.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11dga2displayd.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11dga2displayi.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11dgadisplayd.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11dgadisplayi.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11displayd.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11displayi.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11imaged.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11imagei.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11modesd.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11modesi.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11windowdisplayd.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/x11windowdisplayi.inc svneol=native#text/x-pascal
-packages/ptc/src/x11/xunikey.inc svneol=native#text/x-pascal
-packages/ptc/tests/convtest.pas svneol=native#text/plain
-packages/ptc/tests/endian.pas svneol=native#text/plain
+packages/ptc/src/win32/directx/check.inc svneol=native#text/plain
+packages/ptc/src/win32/directx/directxconsoled.inc svneol=native#text/plain
+packages/ptc/src/win32/directx/directxconsolei.inc svneol=native#text/plain
+packages/ptc/src/win32/directx/display.inc svneol=native#text/plain
+packages/ptc/src/win32/directx/displayd.inc svneol=native#text/plain
+packages/ptc/src/win32/directx/hook.inc svneol=native#text/plain
+packages/ptc/src/win32/directx/hookd.inc svneol=native#text/plain
+packages/ptc/src/win32/directx/library.inc svneol=native#text/plain
+packages/ptc/src/win32/directx/libraryd.inc svneol=native#text/plain
+packages/ptc/src/win32/directx/p_ddraw.pp svneol=native#text/plain
+packages/ptc/src/win32/directx/primary.inc svneol=native#text/plain
+packages/ptc/src/win32/directx/primaryd.inc svneol=native#text/plain
+packages/ptc/src/win32/directx/translate.inc svneol=native#text/plain
+packages/ptc/src/win32/gdi/gdiconsoled.inc svneol=native#text/plain
+packages/ptc/src/win32/gdi/gdiconsolei.inc svneol=native#text/plain
+packages/ptc/src/win32/gdi/win32dibd.inc svneol=native#text/plain
+packages/ptc/src/win32/gdi/win32dibi.inc svneol=native#text/plain
+packages/ptc/src/wince/base/wincekeyboardd.inc svneol=native#text/plain
+packages/ptc/src/wince/base/wincekeyboardi.inc svneol=native#text/plain
+packages/ptc/src/wince/base/wincemoused.inc svneol=native#text/plain
+packages/ptc/src/wince/base/wincemousei.inc svneol=native#text/plain
+packages/ptc/src/wince/base/wincewindowd.inc svneol=native#text/plain
+packages/ptc/src/wince/base/wincewindowi.inc svneol=native#text/plain
+packages/ptc/src/wince/directx/ddraw.pas svneol=native#text/plain
+packages/ptc/src/wince/gapi/p_gx.pp svneol=native#text/plain
+packages/ptc/src/wince/gapi/wincegapiconsoled.inc svneol=native#text/plain
+packages/ptc/src/wince/gapi/wincegapiconsolei.inc svneol=native#text/plain
+packages/ptc/src/wince/gdi/wincebitmapinfod.inc svneol=native#text/plain
+packages/ptc/src/wince/gdi/wincebitmapinfoi.inc svneol=native#text/plain
+packages/ptc/src/wince/gdi/wincegdiconsoled.inc svneol=native#text/plain
+packages/ptc/src/wince/gdi/wincegdiconsolei.inc svneol=native#text/plain
+packages/ptc/src/wince/includes.inc svneol=native#text/plain
+packages/ptc/src/x11/check.inc svneol=native#text/plain
+packages/ptc/src/x11/extensions.inc svneol=native#text/plain
+packages/ptc/src/x11/includes.inc svneol=native#text/plain
+packages/ptc/src/x11/x11consoled.inc svneol=native#text/plain
+packages/ptc/src/x11/x11consolei.inc svneol=native#text/plain
+packages/ptc/src/x11/x11dga1displayd.inc svneol=native#text/plain
+packages/ptc/src/x11/x11dga1displayi.inc svneol=native#text/plain
+packages/ptc/src/x11/x11dga2displayd.inc svneol=native#text/plain
+packages/ptc/src/x11/x11dga2displayi.inc svneol=native#text/plain
+packages/ptc/src/x11/x11dgadisplayd.inc svneol=native#text/plain
+packages/ptc/src/x11/x11dgadisplayi.inc svneol=native#text/plain
+packages/ptc/src/x11/x11displayd.inc svneol=native#text/plain
+packages/ptc/src/x11/x11displayi.inc svneol=native#text/plain
+packages/ptc/src/x11/x11imaged.inc svneol=native#text/plain
+packages/ptc/src/x11/x11imagei.inc svneol=native#text/plain
+packages/ptc/src/x11/x11modesd.inc svneol=native#text/plain
+packages/ptc/src/x11/x11modesi.inc svneol=native#text/plain
+packages/ptc/src/x11/x11windowdisplayd.inc svneol=native#text/plain
+packages/ptc/src/x11/x11windowdisplayi.inc svneol=native#text/plain
+packages/ptc/src/x11/xunikey.inc svneol=native#text/plain
+packages/ptc/tests/convtest.pp svneol=native#text/plain
+packages/ptc/tests/endian.inc svneol=native#text/plain
 packages/ptc/tests/view.pp svneol=native#text/plain
 packages/pthreads/Makefile svneol=native#text/plain
 packages/pthreads/Makefile.fpc svneol=native#text/plain

.gitignore

@@ -5222,15 +5222,6 @@ packages/ptc/src/dos/cga/Package.fpc
 packages/ptc/src/dos/cga/build-stamp.*
 packages/ptc/src/dos/cga/fpcmade.*
 packages/ptc/src/dos/cga/units
-packages/ptc/src/dos/fakemode/*.bak
-packages/ptc/src/dos/fakemode/*.exe
-packages/ptc/src/dos/fakemode/*.o
-packages/ptc/src/dos/fakemode/*.ppu
-packages/ptc/src/dos/fakemode/*.s
-packages/ptc/src/dos/fakemode/Package.fpc
-packages/ptc/src/dos/fakemode/build-stamp.*
-packages/ptc/src/dos/fakemode/fpcmade.*
-packages/ptc/src/dos/fakemode/units
 packages/ptc/src/dos/fpcmade.*
 packages/ptc/src/dos/textfx2/*.bak
 packages/ptc/src/dos/textfx2/*.exe
@@ -5260,6 +5251,15 @@ packages/ptc/src/dos/vesa/Package.fpc
 packages/ptc/src/dos/vesa/build-stamp.*
 packages/ptc/src/dos/vesa/fpcmade.*
 packages/ptc/src/dos/vesa/units
+packages/ptc/src/dos/vga/*.bak
+packages/ptc/src/dos/vga/*.exe
+packages/ptc/src/dos/vga/*.o
+packages/ptc/src/dos/vga/*.ppu
+packages/ptc/src/dos/vga/*.s
+packages/ptc/src/dos/vga/Package.fpc
+packages/ptc/src/dos/vga/build-stamp.*
+packages/ptc/src/dos/vga/fpcmade.*
+packages/ptc/src/dos/vga/units
 packages/ptc/src/fpcmade.*
 packages/ptc/src/tinyptc/*.bak
 packages/ptc/src/tinyptc/*.exe

packages/ptc/Makefile.fpc

@@ -7,24 +7,27 @@ name=ptc
 version=2.5.1
 
 [target]
-units=ptc
-loaders=$(CPU_LOADERS)
-exampledirs=demos examples
+units=ptc ptcwrapper
+exampledirs=examples
 
 [compiler]
-unitdir=src/x11 src/dos/cga src/dos/fakemode src/dos/textfx2 src/dos/timeunit src/dos/vesa \
-        src/win32/directx src
-includedir=src
-targetdir=.
+#unitdir=src/ptcwrapper src/x11
+unitdir_go32v2=src/dos/base src/dos/cga src/dos/vga src/dos/textfx2 src/dos/timeunit src/dos/vesa
+unitdir_win32=src/win32/directx
+unitdir_win64=src/win32/directx
+unitdir_wince=src/wince/gapi
+sourcedir=src src/ptcwrapper
 
 [require]
-packages=hermes
+packages=hermes fcl-base
 packages_linux=x11
 packages_freebsd=x11
 
 [default]
 fpcdir=../..
 
+[install]
+fpcpackage=y
 
 [rules]
 .NOTPARALLEL:

packages/ptc/docs/AUTHORS → packages/ptc/docs/AUTHORS.txt

@@ -3,4 +3,4 @@ The Free Pascal port was done by:
 
 It was based on the OpenPTC C++ library by Glenn Fiedler
 (http://www.gaffer.org/ptc) and the Hermes C library by Christian Nentwich
-(http://hermes.terminal.at)
+(http://www.clanlib.org/hermes/)

packages/ptc/docs/CHANGES

@@ -1,22 +0,0 @@
-0.99.5
- - support for fpc 2.0.0. fpc 1.0.10 support dropped, except for DOS.
- - support for amd64 (the code is now 64-bit safe, but still little endian-only)
- - fix the (sometimes) missing titlebar when using the metacity window manager
-
-0.99.4
- - some X11 fixes (missing cdecl's, wrong alignments, etc.)
- - FreeBSD and NetBSD now compile and work (dga and XShm still not tested...)
- - improved exception handling in demos and examples
-
-0.99.3
- - support for fpc 1.9.2+ (adapted to use the new unix rtl)
- - the dos console uses rdtsc if available for more accurate timing
- - some vesa fixes
-
-0.99.2
- - alt, shift, ctrl modifier keys support for X11
- - key release support for win32 and X11
- - new example (keybrd2) demonstrating the use of key release events
-
-0.99.1
- - first release to sourceforge

packages/ptc/docs/CHANGES.txt

@@ -0,0 +1,107 @@
+0.99.11
+ - added ptcgraph - an implementation of FPC's BGI-compatible graph unit on top
+   of PTCPas. It should work on all platforms, supported by PTCPas,  except for
+   DOS (because it doesn't have threads)
+ - VBE console improvements:
+    - support for double buffering with video page flipping
+    - console update synchronized with the vertical retrace
+    - automatic fallback to windowed mode, if initializing LFB fails. This
+      results in better compatibility with NTVDM and other environments that
+      would otherwise require adding the 'disable lfb' option to ptcpas.cfg.
+    - support VBE 3+ separate LFB and Windowed color masks for direct color
+      modes. This might fix some wrong color bugs in LFB mode on some modern
+      VBE 3+ video cards.
+ - fixed a bug in the X11 event handling that caused unnecessary high CPU use
+   while waiting for an event
+
+0.99.10
+ - fpc 2.4.0 support
+ - Win64 DirectX support
+ - X11 DGA 2.0 support
+ - VBE 2+ LFB support. Enabled by default. Offers a great performance
+   improvement, but may fail on buggy VGA BIOSes or buggy DOS virtual
+   machines. If it causes problems, it can be disabled by adding
+   'disable lfb' to ptcpas.cfg.
+ - API changes:
+    - in the hermes unit, THermesHandle was replaced with
+      THermesConverterHandle, THermesClearerHandle and THermesPaletteHandle,
+      which should be treated as opaque pointers, not integers. This only
+      matters if you use unit hermes directly, and not ptc.
+ - various bugfixes and code cleanup.
+
+0.99.9
+ - big endian support.
+ - Win64 support (GDI only. DirectX not supported yet).
+
+0.99.8
+ - added support for Windows CE. Still in alpha stage. Tested on a Motorola
+   MPx220 smartphone.
+ - added support for fullscreen X11 using the Xrandr extension (previously
+   only the XF86VidMode extension was supported). Also fullscreen X11 now works
+   even when there aren't any mode switching X11 extensions available. A single
+   fullscreen mode, which has the size of the entire desktop is offered in this
+   case.
+ - added a new simple windowed win32 GDI console, which is able to run even
+   without any version of DirectX installed.
+ - the X11 console now returns a mode list.
+ - fixed a bug which caused win32 fixed-size windows to be non-minimizable.
+ - imported the OpenPTC 1.0.1 DOS VGA fakemode assembly routines - should give
+   a nice speed boost on ancient 386/486/Pentium machines.
+
+0.99.7
+ - A new event system + mouse support. Yes, I know I should have done this
+   earlier :) Fullscreen X11 with mouse still does not work well, I'm planning
+   to fix this in the next version.
+ - API changes:
+    - TPTCKey class renamed to TPTCKeyEvent
+    - Removed int32, short16 and char8 types.
+      Replaced with: Uint64, Uint32, Uint16, Uint8,
+                     Sint64, Sint32, Sint16, Sint8.
+ - fixed fullscreen palette modes under DirectX (was buggy on modern NVIDIA and
+   ATI video cards).
+ - a new example program, demonstrating the mouse support.
+   Use it as a reference for now, until I update the documentation with the new
+   event handling stuff (hopefully this will happen in the next release).
+ - X11 window is not resizable anymore. Maybe some day I'll implement (optional)
+   stretching as in win32 windowed mode.
+ - code cleanup. Hid some implementation details from the interface part.
+
+0.99.6
+ - Now distributed under the terms of the modified LGPL (used by the FPC RTL).
+   See the file modified_lgpl.txt distributed with the library for details.
+   Thanks to Glenn Fiedler (the author of the original OpenPTC C++ code, that
+   this library is based on) and Christian Nentwich (the author of the original
+   C code of the Hermes library and the X11 version of OpenPTC) for giving
+   permission to distribute the code under this license.
+ - The Free Pascal Development Team intends to distribute this library with the
+   Free Pascal Compiler and to base the graph unit on it, which is very cool! :)
+ - fullscreen support in xshm/ximage mode.
+ - dga support is now disabled by default.
+ - added workaround for the 'shmat' bug in fpc 2.0.0's rtl on amd64 linux.
+ - fixed some compilation-related problems with the example programs.
+ - fpc 2.0.2 - go32v2 compilation fixed. fpc 1.0.10 support dropped completely.
+ - some other DOS code fixes and cleanups.
+ - config file name changed to ptcpas.cfg (~/.ptcpas.conf on *NIX)
+
+0.99.5
+ - support for fpc 2.0.0. fpc 1.0.10 support dropped, except for DOS.
+ - support for amd64 (the code is now 64-bit safe, but still little endian-only)
+ - fix the (sometimes) missing titlebar when using the metacity window manager
+
+0.99.4
+ - some X11 fixes (missing cdecl's, wrong alignments, etc.)
+ - FreeBSD and NetBSD now compile and work (dga and XShm still not tested...)
+ - improved exception handling in demos and examples
+
+0.99.3
+ - support for fpc 1.9.2+ (adapted to use the new unix rtl)
+ - the dos console uses rdtsc if available for more accurate timing
+ - some vesa fixes
+
+0.99.2
+ - alt, shift, ctrl modifier keys support for X11
+ - key release support for win32 and X11
+ - new example (keybrd2) demonstrating the use of key release events
+
+0.99.1
+ - first release to sourceforge

packages/ptc/docs/INSTALL

@@ -1,36 +0,0 @@
-The supported platforms are Linux (on IA-32 and AMD64), Windows and DOS.
-FreeBSD and NetBSD compiles and runs fine on the SourceForge compilefarm, but
-I haven't tested it on a local machine, so any feedback (+patches) is welcome.
-(At least the basic XImage mode works, XShm and dga are not tested since they
-need to run on the same machine as the X server, so I can't test them on the
-SourceForge compilefarm.)
-
-You need Free Pascal Compiler version 2.0.0. Since there's no DOS version of
-2.0.0, you need 1.0.10 if you are going to use the DOS version of the library.
-Please note that DOS is the only platform where the 1.0.10 compiler is
-supported.
-
- - Compiling the library:
-Before starting make sure the FPCDIR environment variable is set correctly.
-For example: (windows, fpc version 2.0.0, default install dir)
-
-  set FPCDIR=c:\fpc\2.0.0
-
-To compile the library type:
-
-  fpcmake -r
-  make
-
-Then you can do:
-
-  make examples
-
-And then try to run the programs in the demos/ and examples/ dirs.
-
-If compiling the library fails, make sure you're using the GNU make and not
-some other make! (e.g. GNU make is called 'gmake' on FreeBSD and NetBSD)
-
-'make -v' should report:
-  GNU Make version x.xx.x, ... etc. :)
-
-On Windows and DOS this is the 'make' that comes with Free Pascal.

packages/ptc/docs/INSTALL.txt

@@ -0,0 +1,29 @@
+The supported platforms are Linux, FreeBSD, Windows, Windows Mobile and DOS.
+
+Generally you need the latest stable version of the Free Pascal Compiler, which
+currently means version 2.4.0. Generally FPC 2.2.4 should also work fine.
+
+ - Compiling the library:
+Before starting make sure the FPCDIR environment variable is set correctly.
+For example: (windows, fpc version 2.4.0, default install dir)
+
+  set FPCDIR=c:\fpc\2.4.0
+
+To compile the library type:
+
+  fpcmake -r
+  make
+
+Then you can do:
+
+  make examples
+
+And then try to run the programs in the demos/ and examples/ dirs.
+
+If compiling the library fails, make sure you're using the GNU make and not
+some other make! (e.g. GNU make is usually called 'gmake' on *BSD)
+
+'make -v' should report:
+  GNU Make version x.xx.x, ... etc. :)
+
+On Windows and DOS this is the 'make' that comes with Free Pascal.

packages/ptc/docs/INTRO → packages/ptc/docs/INTRO.txt

@@ -1,5 +1,5 @@
-For more complete documentation please refer to the C++ documentation of
-OpenPTC.
+For more complete documentation please see the API reference found in the
+'api-reference' directory (as well as online on the official PTCPas website).
 
 This will explain the basics of creating a simple graphics application using
 PTC for FPC. :)
@@ -38,29 +38,29 @@ How to use this TPTCConsole? Easy! First create it:
 
 This still doesn't do anything, just allocates memory and initializes stuff.
 Then you switch to the desired mode:
-  Console.open('Hello, world!', 320, 200, Format);
+  Console.Open('Hello, world!', 320, 200, Format);
 
 Note that if your hardware doesn't support the requested mode, PTC will try
 to switch to the best mode. If (for example) your card doesn't support
 320x200 in 32bpp, only in 16bpp, PTC will (probably) switch to that mode.
 To see the actual mode that PTC has set use these properties:
-  Console.width Console.height and Console.format
+  Console.Width Console.Height and Console.Format
 
 Ok, now that you have created a TPTCSurface and opened a TPTCConsole, what to
 do next? Draw stuff... The lock function of TPTCSurface will give you a pointer
 to the internal buffer.
-  ptr := Surface.lock;
+  ptr := Surface.Lock;
 
 Now you can draw your frame in the buffer, pointed by ptr. Note that this buffer
 is guaranteed to be in the format and resolution you requested.
 
 When you're done you have to unlock the surface and copy it to the console:
-  Surface.unlock;
-  Surface.copy(Console);
-  Console.update;
+  Surface.Unlock;
+  Surface.Copy(Console);
+  Console.Update;
 
-The Surface.copy(Console) will do the conversion (if necessary) to the actual
-mode. Console.update will actually show the new frame (if the console driver
+The Surface.Copy(Console) will do the conversion (if necessary) to the actual
+mode. Console.Update will actually show the new frame (if the console driver
 supports multiple pages and you have enough video RAM for that, etc... :) ).
 
 See the example programs for additional details. (keyboard input, high

packages/ptc/docs/README.txt

@@ -1,8 +1,9 @@
-PTCPas 0.99.5
+PTCPas 0.99.11
 Nikolay Nikolov ([email protected])
 
-This is a FPC port of the OpenPTC C++ library. It is distributed under the
-the terms of the GNU LGPL (see lgpl.txt).
+PTCPas is a free, portable framebuffer library, written in Free Pascal. It is
+distributed under the the terms of a modified version of the GNU LGPL (see
+modified_lgpl.txt).
 
 The latest version can be found at http://ptcpas.sourceforge.net
 
@@ -12,33 +13,46 @@ Windows, more will be added in the future)
 3d acceleration isn't supported, nor planned. If you need that, you should use
 something like OpenGL instead. :-)
 
+PTCPas initially started out as a complete Object Pascal translation of the
+OpenPTC C++ library. Since then, OpenPTC development has stalled and PTCPas
+lives on as a fully independent Object Pascal project.
+
 Supported consoles:
-  DirectX 3+ (should work on all Windows versions since Windows 95, except
-              Windows CE. This currently means 95/98/ME/NT4/2000/XP/2003.
-	      On NT4 you need SP3 or later. Also some very ancient versions of
-	      Windows 95 do not have any DirectX preinstalled, so it has to be
-	      installed separately.)
-  X11 (on linux, maybe also other unix-like OSes, supports dga and XShm
-       extensions)
-  Vesa 1.2+ (DOS. LFB and video pages not yet supported)
+  DirectX 3+ (should work on all x86 Windows versions since Windows 95, except
+              Windows CE. This currently means 95/98/ME/NT4/2000/XP/2003/Vista.
+              It is compatible with the x64 editions of XP and 2003 (although
+              only as a 32-bit application, no native win64 yet). On NT4 you
+              need SP3 or later. Also some very ancient versions of Windows 95
+              do not have any DirectX preinstalled, so it has to be installed
+              separately.)
+  Win32 GDI (no fullscreen support. Slower than DirectX, but maybe more
+             compatible.)
+  X11 (on linux and other unix-like OSes, supports XRandR, XF86VidMode, XShm
+       and xf86dga extensions)
+  Vesa 1.0+ (DOS. Supports LFB and banked video memory access. Video pages not
+             yet supported)
   VGA (DOS, fakemodes, mode13h, etc...)
   CGA (DOS, added by me just for fun ... and maybe some day I'll even add
        EGA :-) )
   Text (DOS, 80x50 - 16 colours, should work even in the most buggy dos boxes
         (2000,XP) and IMHO looks better than AALib ;-) )
+  WinCE GAPI (Windows CE 3.0 and later on devices that support GAPI. Needs
+              testing on more devices.)
+  WinCE GDI (Windows CE 3.0 and later. Slow. Needs testing on more devices.)
 
-All programs using OpenPTC look (at runtime) for a config file that may contain
+All programs using PTCPas look (at runtime) for a config file that may contain
 various (platform specific) options, so you can try different consoles, etc,
-without the need to recompile. It is called ptc.cfg and is searched in the
-current directory on DOS and Windows. On unix it is .ptc.conf in the user's
-HOME directory. There's an example ptc.cfg file with all supported options,
+without the need to recompile. It is called ptcpas.cfg and is searched in the
+current directory on DOS and Windows. On unix it is .ptcpas.conf in the user's
+HOME directory. There's an example ptcpas.cfg file with all supported options,
 prefixed with #. If you want to try an option just remove the # and put it in
-the same directory as the .exe (or copy to ~/.ptc.conf on unix :) )
+the same directory as the .exe (or copy to ~/.ptcpas.conf on unix :) )
 
 --------------------------------------------------------------------------------
 The original copyrights from the C++ version:
-The X11 classes are Copyright (c) 1998/99 Christian Nentwich ([email protected])
+The X11 classes are Copyright (c) 1998/99 Christian Nentwich
+([email protected], old mail [email protected] no longer works?)
 The OpenPTC 1.0 C++ API is (c) 1998/99 Glenn Fiedler ([email protected])
 
-The OpenPTC C++ library can be found at http://www.gaffer.org/ptc
-The Hermes C library can be found at http://hermes.terminal.at
+The OpenPTC C++ library can be found at http://sourceforge.net/projects/openptc/
+The Hermes C library can be found at http://www.clanlib.org/download/legacy/

packages/ptc/docs/TODO.txt

@@ -1,8 +1,9 @@
+ - mouse grab support
+ - add more event types (expose, focus in, focus out, etc.)
+ - mouse support for the x11 dga console
  - key release events support in dos
- - mouse support
- - multiple video pages and lfb for the vesa console
- - test the x11 console (in XShm and dga mode) under *BSD
- - big endian support in hermes
- - make hermes thread safe (in FPC 1.9.x+)
- - delphi (kylix? c++?) bindings
+ - multiple video pages support for the x11 w/dga console
+ - cross-platform opengl initialization support (like sdl or glut)
+ - make hermes thread safe
  - better timing under dos
+ - delphi (kylix? c++?) bindings

packages/ptc/docs/modified_lgpl.txt

@@ -0,0 +1,25 @@
+This is the file modified_lgpl.txt, it applies to the ptcpas library (the Free
+Pascal port of the OpenPTC C++ library) and to the Free Pascal port of the
+Hermes library.
+
+The source code of the ptcpas library and the Free Pascal port of the Hermes
+library are distributed under the Lesser GNU General Public License
+(see the file lgpl.txt) with the following modification:
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent modules,
+and to copy and distribute the resulting executable under terms of your choice,
+provided that you also meet, for each linked independent module, the terms
+and conditions of the license of that module. An independent module is a module
+which is not derived from or based on this library. If you modify this
+library, you may extend this exception to your version of the library, but you are
+not obligated to do so. If you do not wish to do so, delete this exception
+statement from your version.
+
+If you didn't receive a copy of the file lgpl.txt, contact:
+      Free Software Foundation
+      675 Mass Ave
+      Cambridge, MA  02139
+      USA
+

packages/ptc/examples/area.pp

@@ -3,35 +3,30 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Area example for OpenPTC 1.0 C++ Implementation
+ Area example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program AreaExample;
+program AreaExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Var
-  console : TPTCConsole;
-  format : TPTCFormat;
-  surface : TPTCSurface;
-  pixels : PDWord;
-  width, height : Integer;
-  i : Integer;
-  x, y, r, g, b : Integer;
-  area : TPTCArea;
-
-Begin
-  area := Nil;
-  format := Nil;
-  surface := Nil;
-  console := Nil;
-  Try
-    Try
+var
+  console: TPTCConsole = nil;
+  format: TPTCFormat = nil;
+  surface: TPTCSurface = nil;
+  pixels: PDWord;
+  width, height: Integer;
+  i: Integer;
+  x, y, r, g, b: Integer;
+  area: TPTCArea = nil;
+begin
+  try
+    try
       { create console }
       console := TPTCConsole.Create;
 
@@ -42,59 +37,59 @@ Begin
       console.open('Area example', format);
 
       { create surface half the size of the console }
-      surface := TPTCSurface.Create(console.width Div 2, console.height Div 2, format);
-      
+      surface := TPTCSurface.Create(console.width div 2, console.height div 2, format);
+
       { setup destination area }
-      x := console.width Div 4;
-      y := console.height Div 4;
+      x := console.width div 4;
+      y := console.height div 4;
       area := TPTCArea.Create(x, y, x + surface.width, y + surface.height);
 
       { loop until a key is pressed }
-      While Not console.KeyPressed Do
-      Begin
+      while not console.KeyPressed do
+      begin
         { lock surface }
         pixels := surface.lock;
-        Try
+        try
           { get surface dimensions }
           width := surface.width;
           height := surface.height;
 
           { draw random pixels }
-          For i := 1 To 100 Do
-          Begin
+          for i := 1 to 100 do
+          begin
             { get random position }
-	    x := Random(width);
-	    y := Random(height);
+            x := Random(width);
+            y := Random(height);
 
             { get random color }
-	    r := Random(256);
-	    g := Random(256);
-	    b := Random(256);
+            r := Random(256);
+            g := Random(256);
+            b := Random(256);
 
             { draw color [r,g,b] at position [x,y] }
-	    pixels[x + y * width] := (r Shl 16) + (g Shl 8) + b;
-          End;
-	Finally
+            pixels[x + y * width] := (r shl 16) + (g shl 8) + b;
+          end;
+        finally
           { unlock surface }
           surface.unlock;
-	End;
+        end;
 
         { copy surface to console destination area }
         surface.copy(console, surface.area, area);
 
         { update console area }
         console.update;
-      End;
-    Finally
+      end;
+    finally
       console.close;
       console.Free;
       surface.Free;
       format.Free;
       area.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/buffer.pp

@@ -3,34 +3,29 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Buffer example for OpenPTC 1.0 C++ Implementation
+ Buffer example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program BufferExample;
+program BufferExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Var
-  console : TPTCConsole;
-  format : TPTCFormat;
-  palette : TPTCPalette;
-  width, height : Integer;
-  pixels : Pint32;
-  x, y, r, g, b : Integer;
-  i : Integer;
-
-Begin
-  pixels := Nil;
-  format := Nil;
-  palette := Nil;
-  console := Nil;
-  Try
-    Try
+var
+  console: TPTCConsole = nil;
+  format: TPTCFormat = nil;
+  palette: TPTCPalette = nil;
+  width, height: Integer;
+  pixels: PUint32 = nil;
+  x, y, r, g, b: Integer;
+  i: Integer;
+begin
+  try
+    try
       { create console }
       console := TPTCConsole.Create;
 
@@ -45,46 +40,46 @@ Begin
       height := console.height;
 
       { allocate a buffer of pixels }
-      pixels := GetMem(width * height * SizeOf(int32));
+      pixels := GetMem(width * height * SizeOf(Uint32));
+      FillChar(pixels^, width * height * SizeOf(Uint32), 0);
       palette := TPTCPalette.Create;
 
       { loop until a key is pressed }
-      While Not console.KeyPressed Do
-      Begin
+      while not console.KeyPressed do
+      begin
         { draw random pixels }
-        For i := 1 To 100 Do
-        Begin
+        for i := 1 to 100 do
+        begin
           { get random position }
-	  x := Random(width);
-	  y := Random(height);
+          x := Random(width);
+          y := Random(height);
 
-          { get random color }	
-	  r := Random(256);
-	  g := Random(256);
-	  b := Random(256);
+          { get random color }
+          r := Random(256);
+          g := Random(256);
+          b := Random(256);
 
           { draw color [r,g,b] at position [x,y] }
-	  pixels[x + y * width] := (r Shl 16) Or (g Shl 8) Or b;
-        End;
+          pixels[x + y * width] := (r shl 16) or (g shl 8) or b;
+        end;
 
         { load pixels to console }
         console.load(pixels, width, height, width * 4, format, palette);
 
         { update console }
         console.update;
-      End;
-    Finally
+      end;
+    finally
       { free pixels buffer }
-      If Assigned(pixels) Then
-        FreeMem(pixels);
+      FreeMem(pixels);
       console.close;
       palette.Free;
       format.Free;
       console.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/clear.pp

@@ -3,30 +3,29 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Clear example for OpenPTC 1.0 C++ Implementation
+ Clear example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program ClearExample;
+program ClearExample;
 
 {$MODE objfpc}
 
-Uses
-  ptc;
-
-Var
-  console : TPTCConsole;
-  format : TPTCFormat;
-  surface : TPTCSurface;
-  width, height : Integer;
-  x, y : Integer;
-  size : Integer;
-  area : TPTCArea;
-  color : TPTCColor;
-
-Begin
-  Try
+uses
+  SysUtils, ptc;
+
+var
+  console: TPTCConsole = nil;
+  format: TPTCFormat = nil;
+  surface: TPTCSurface = nil;
+  width, height: Integer;
+  x, y: Integer;
+  size: Integer;
+  area: TPTCArea = nil;
+  color: TPTCColor = nil;
+begin
+  try
     { create console }
     console := TPTCConsole.Create;
 
@@ -40,8 +39,8 @@ Begin
     surface := TPTCSurface.Create(console.width, console.height, format);
 
     { loop until a key is pressed }
-    While Not console.KeyPressed Do
-    Begin
+    while not console.KeyPressed do
+    begin
       { get surface dimensions }
       width := surface.width;
       height := surface.height;
@@ -51,31 +50,35 @@ Begin
       y := Random(height);
 
       { get random area size }
-      size := Random(width Div 8);
+      size := Random(width div 8);
 
-      { setup clear area }
-      area := TPTCArea.Create(x-size, y-size, x+size, y+size);
+      try
+        { setup clear area }
+        area := TPTCArea.Create(x-size, y-size, x+size, y+size);
 
-      { create random color }
-      color := TPTCColor.Create(Random, Random, Random);
+        { create random color }
+        color := TPTCColor.Create(Random, Random, Random);
 
-      { clear surface area with color }
-      surface.clear(color, area);
+        { clear surface area with color }
+        surface.clear(color, area);
 
-      { copy to console }
-      surface.copy(console);
+        { copy to console }
+        surface.copy(console);
 
-      { update console }
-      console.update;
-      area.Free;
-      color.Free;
-    End;
+        { update console }
+        console.update;
+      finally
+        FreeAndNil(area);
+        FreeAndNil(color);
+      end;
+    end;
     console.close;
     console.Free;
     surface.Free;
-  Except
-    On error : TPTCError Do
+    format.Free;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/clip.pp

@@ -3,35 +3,31 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Clip example for OpenPTC 1.0 C++ Implementation
+ Clip example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program ClipExample;
+program ClipExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Var
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  format : TPTCFormat;
-  area : TPTCArea;
-  x1, y1, x2, y2 : Integer;
-  pixels : Pint32;
-  width, height : Integer;
-  i : Integer;
-  x, y, r, g, b : Integer;
-
-Begin
-  format := Nil;
-  surface := Nil;
-  console := Nil;
-  Try
-    Try
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+  area: TPTCArea;
+  x1, y1, x2, y2: Integer;
+  pixels: PUint32;
+  width, height: Integer;
+  i: Integer;
+  x, y, r, g, b: Integer;
+begin
+  try
+    try
       { create console }
       console := TPTCConsole.Create;
 
@@ -45,65 +41,65 @@ Begin
       surface := TPTCSurface.Create(console.width, console.height, format);
 
       { calculate clip coordinates }
-      x1 := console.width Div 4;
-      y1 := console.height Div 4;
+      x1 := console.width div 4;
+      y1 := console.height div 4;
       x2 := console.width - x1;
       y2 := console.height - y1;
 
       { setup clip area }
       area := TPTCArea.Create(x1, y1, x2, y2);
-      Try
+      try
         { set clip area }
         console.clip(area);
-      Finally
+      finally
         area.Free;
-      End;
+      end;
 
       { loop until a key is pressed }
-      While Not console.KeyPressed Do
-      Begin
+      while not console.KeyPressed do
+      begin
         { lock surface }
         pixels := surface.lock;
-        Try
+        try
           { get surface dimensions }
           width := surface.width;
           height := surface.height;
 
           { draw random pixels }
-          For i := 1 To 100 Do
-          Begin
+          for i := 1 to 100 do
+          begin
             { get random position }
-	    x := Random(width);
-	    y := Random(height);
+            x := Random(width);
+            y := Random(height);
 
             { get random color }
-	    r := Random(256);
-	    g := Random(256);
-	    b := Random(256);
+            r := Random(256);
+            g := Random(256);
+            b := Random(256);
 
             { draw color [r,g,b] at position [x,y] }
-	    pixels[x + y * width] := (r Shl 16) + (g Shl 8) + b;
-          End;
-	Finally
+            pixels[x + y * width] := (r shl 16) + (g shl 8) + b;
+          end;
+        finally
           { unlock surface }
           surface.unlock;
-	End;
+        end;
 
         { copy to console }
         surface.copy(console);
 
         { update console }
         console.update;
-      End;
-    Finally
+      end;
+    finally
       console.close;
       console.Free;
       surface.Free;
       format.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/con_info.pp

@@ -3,45 +3,42 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Info example for OpenPTC 1.0 C++ Implementation
+ Info example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program InfoExample;
+program InfoExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Procedure print(Const format : TPTCFormat);
-
-Begin
+procedure print(const format: TPTCFormat);
+begin
   { check format type }
-  If format.direct Then
+  if format.direct then
     { check alpha }
-    If format.a = 0 Then
+    if format.a = 0 then
       { direct color format without alpha }
       Write('Format(', format.bits:2, ',$', HexStr(format.r, 8), ',$', HexStr(format.g, 8), ',$', HexStr(format.b, 8), ')')
-    Else
+    else
       { direct color format with alpha }
       Write('Format(', format.bits:2, ',$', HexStr(format.r, 8), ',$', HexStr(format.g, 8), ',$', HexStr(format.b, 8), ',$', HexStr(format.a, 8), ')')
-  Else
+  else
     { indexed color format }
     Write('Format(', format.bits:2, ')');
-End;
-
-Var
-  console : TPTCConsole;
+end;
 
-Begin
-  console := Nil;
-  Try
-    Try
-      Writeln('[ptc version]');
-      { print ptc version string define }
-      Writeln(PTC_VERSION);
+var
+  console: TPTCConsole = nil;
+begin
+  try
+    try
+      Writeln('[ptcpas version]');
+      { print ptcpas version string define }
+      Writeln(PTCPAS_VERSION);
       Writeln;
 
       { create console }
@@ -66,13 +63,13 @@ Begin
       { print console information }
       Writeln('[console information]');
       Writeln(console.information);
-    Finally
+    finally
       console.close;
       console.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/console.pp

@@ -3,117 +3,121 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Console example for OpenPTC 1.0 C++ Implementation
+ Console example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program ConsoleExample;
+program ConsoleExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Var
-  console : TPTCConsole;
-  palette : TPTCPalette;
-  data : Array[0..255] Of DWord;
-  i : Integer;
-  pixels : PByte;
-  width, height, pitch : Integer;
-  format : TPTCFormat;
-  bits, bytes : Integer;
-  x, y : Integer;
-  color : DWord;
-  pixel : PByte;
-  _data : PByte;
-
-Begin
-  Try
-    { create console }
-    console := TPTCConsole.Create;
-
-    { open the console with one page }
-    console.open('Console example', 1);
-
-    { create palette }
-    palette := TPTCPalette.Create;
-
-    { generate palette }
-    For i := 0 To 255 Do
-      data[i] := i;
-
-    { load palette data }
-    palette.load(data);
-
-    { set console palette }
-    console.palette(palette);
-
-    { loop until a key is pressed }
-    While Not console.KeyPressed Do
-    Begin
-      { lock console }
-      pixels := console.lock;
-
-      { get console dimensions }
-      width := console.width;
-      height := console.height;
-      pitch := console.pitch;
-
-      { get console format }
-      format := console.format;
-
-      { get format information }
-      bits := format.bits;
-      bytes := format.bytes;
-
-      { draw random pixels }
-      For i := 1 To 100 Do
-      Begin
-        { get random position }
-	x := Random(width);
-	y := Random(height);
-
-        { generate random color integer }
-	color := (Random(256) Shl 0) Or
-		 (Random(256) Shl 8) Or
-		 (Random(256) Shl 16) Or
-		 (Random(256) Shl 24);
-
-        { calculate pointer to pixel [x,y] }
-	pixel := pixels + y * pitch + x * bytes;
-
-        { check bits }
-	Case bits Of
-               { 32 bits per pixel }
-	  32 : PDWord(pixel)^ := color;
-	  24 : Begin
-            { 24 bits per pixel }
-	    _data := pixel;
-	    _data[0] := (color And $000000FF) Shr 0;
-	    _data[1] := (color And $0000FF00) Shr 8;
-	    _data[2] := (color And $00FF0000) Shr 16;
-	  End;
-               { 16 bits per pixel }
-	  16 : PWord(pixel)^ := color;
-              { 8 bits per pixel }
-	  8 : PByte(pixel)^ := color;
-	End;
-      End;
-
-      { unlock console }
-      console.unlock;
-
-      { update console }
-      console.update;
-    End;
-    palette.Free;
-    console.close;
-    console.Free;
-  Except
-    On error : TPTCError Do
+var
+  console: TPTCConsole = nil;
+  palette: TPTCPalette = nil;
+  data: array [0..255] of DWord;
+  i: Integer;
+  pixels: PByte;
+  width, height, pitch: Integer;
+  format: TPTCFormat;
+  bits, bytes: Integer;
+  x, y: Integer;
+  color: DWord;
+  pixel: PByte;
+  _data: PByte;
+begin
+  try
+    try
+      { create console }
+      console := TPTCConsole.Create;
+
+      { open the console with one page }
+      console.open('Console example', 1);
+
+      { create palette }
+      palette := TPTCPalette.Create;
+
+      { generate palette }
+      for i := 0 to 255 do
+        data[i] := i;
+
+      { load palette data }
+      palette.load(data);
+
+      { set console palette }
+      console.palette(palette);
+
+      { loop until a key is pressed }
+      while not console.KeyPressed do
+      begin
+        { lock console }
+        pixels := console.lock;
+
+        try
+          { get console dimensions }
+          width := console.width;
+          height := console.height;
+          pitch := console.pitch;
+
+          { get console format }
+          format := console.format;
+
+          { get format information }
+          bits := format.bits;
+          bytes := format.bytes;
+
+          { draw random pixels }
+          for i := 1 to 100 do
+          begin
+            { get random position }
+            x := Random(width);
+            y := Random(height);
+
+            { generate random color integer }
+            color := (DWord(Random(256)) shl 0) or
+                     (DWord(Random(256)) shl 8) or
+                     (DWord(Random(256)) shl 16) or
+                     (DWord(Random(256)) shl 24);
+
+            { calculate pointer to pixel [x,y] }
+            pixel := pixels + y * pitch + x * bytes;
+
+            { check bits }
+            case bits of
+                   { 32 bits per pixel }
+              32: PDWord(pixel)^ := color;
+              24: begin
+                { 24 bits per pixel }
+                _data := pixel;
+                _data[0] := (color and $000000FF) shr 0;
+                _data[1] := (color and $0000FF00) shr 8;
+                _data[2] := (color and $00FF0000) shr 16;
+              end;
+                   { 16 bits per pixel }
+              16: PWord(pixel)^ := color;
+                  { 8 bits per pixel }
+              8: PByte(pixel)^ := color;
+            end;
+          end;
+        finally
+          { unlock console }
+          console.unlock;
+        end;
+
+        { update console }
+        console.update;
+      end;
+    finally
+      palette.Free;
+      console.close;
+      console.Free;
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/fire.pp

@@ -8,95 +8,86 @@ Ported to FPC by Nikolay Nikolov ([email protected])
  This source code is licensed under the GNU GPL
 }
 
-Program Fire;
+program Fire;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Function pack(r, g, b : Uint32) : Uint32;
-
-Begin
+function pack(r, g, b: Uint32): Uint32;
+begin
   { pack color integer }
-  pack := (r Shl 16) Or (g Shl 8) Or b;
-End;
-
-Procedure generate(palette : TPTCPalette);
-
-Var
-  data : PUint32;
-  i, c : Integer;
-
-Begin
+  pack := (r shl 16) or (g shl 8) or b;
+end;
+
+procedure generate(palette: TPTCPalette);
+var
+  data: PUint32;
+  i, c: Integer;
+begin
   { lock palette data }
   data := palette.lock;
 
-  Try
+  try
     { black to red }
     i := 0;
     c := 0;
-    While i < 64 Do
-    Begin
+    while i < 64 do
+    begin
       data[i] := pack(c, 0, 0);
       Inc(c, 4);
       Inc(i);
-    End;
+    end;
 
     { red to yellow }
     c := 0;
-    While i < 128 Do
-    Begin
+    while i < 128 do
+    begin
       data[i] := pack(255, c, 0);
       Inc(c, 4);
       Inc(i);
-    End;
+    end;
 
     { yellow to white }
     c := 0;
-    While i < {192}128 Do
-    Begin
+    while i < {192}128 do
+    begin
       data[i] := pack(255, 255, c);
       Inc(c, 4);
       Inc(i);
-    End;
+    end;
 
     { white }
-    While i < 256 Do
-    Begin
+    while i < 256 do
+    begin
       data[i] := pack(255, 255, 255);
       Inc(i);
-    End;
+    end;
 
-  Finally
+  finally
     { unlock palette }
     palette.unlock;
-  End;
-End;
-
-Var
-  format : TPTCFormat;
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  palette : TPTCPalette;
-  state : Integer;
-  intensity : Single;
-  pixels, pixel, p : PUint8;
-  width, height : Integer;
-  x, y : Integer;
-  top, bottom, c1, c2 : Uint32;
-  generator : PUint8;
-  color : Integer;
-  area : TPTCArea;
-
-Begin
-  format := Nil;
-  console := Nil;
-  surface := Nil;
-  palette := Nil;
-  area := Nil;
-  Try
-    Try
+  end;
+end;
+
+var
+  format: TPTCFormat = nil;
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  palette: TPTCPalette = nil;
+  state: Integer;
+  intensity: Single;
+  pixels, pixel, p: PUint8;
+  width, height: Integer;
+  x, y: Integer;
+  top, bottom, c1, c2: Uint32;
+  generator: PUint8;
+  color: Integer;
+  area: TPTCArea = nil;
+begin
+  try
+    try
       { create format }
       format := TPTCFormat.Create(8);
 
@@ -129,71 +120,71 @@ Begin
       area := TPTCArea.Create(0, 0, 320, 200);
 
       { main loop }
-      Repeat
+      repeat
         { lower flame on keypress }
-        If console.KeyPressed Then
+        if console.KeyPressed then
           state := 2;
 
         { state machine }
-        Case state Of
-          0 : Begin
+        case state of
+          0: begin
             { raise flame }
-            intensity += 0.007;
+            intensity := intensity + 0.007;
 
             { maximum flame height }
-            If intensity > 0.8 Then
+            if intensity > 0.8 then
               state := 1;
-          End;
-          1 : Begin
+          end;
+          1: begin
             { constant flame }
-          End;
-          2 : Begin
+          end;
+          2: begin
             { lower flame }
             intensity := intensity - 0.005;
 
             { exit program when flame is out }
-            If intensity < 0.01 Then
-            Begin
+            if intensity < 0.01 then
+            begin
               console.close;
-	      Exit;
-            End;
-          End;
-        End;
+              exit;
+            end;
+          end;
+        end;
 
         { lock surface pixels }
         pixels := surface.lock;
-	
-	Try
+
+        try
           { get surface dimensions }
           width := surface.width;
           height := surface.height;
 
           { flame vertical loop }
           y := 1;
-          While y < height - 4 Do
-          Begin
+          while y < height - 4 do
+          begin
             { current pixel pointer }
             pixel := pixels + y * width;
 
             { flame horizontal loop }
-            For x := 0 To width - 1 Do
-            Begin
+            for x := 0 to width - 1 do
+            begin
               { sum top pixels }
-              p := pixel + (width Shl 1);
+              p := pixel + (width shl 1);
               top := p^;
               Inc(top, (p - 1)^);
               Inc(top, (p + 1)^);
 
               { bottom pixel }
-              bottom := (pixel + (width Shl 2))^;
+              bottom := (pixel + (width shl 2))^;
 
               { combine pixels }
-              c1 := (top + bottom) Shr 2;
-              If c1 > 1 Then
+              c1 := (top + bottom) shr 2;
+              if c1 > 1 then
                 Dec(c1);
 
               { interpolate }
-              c2 := (c1 + bottom) Shr 1;
+              c2 := (c1 + bottom) shr 1;
 
               { store pixels }
               pixel^ := c1;
@@ -201,17 +192,17 @@ Begin
 
               { next pixel }
               Inc(pixel);
-            End;
+            end;
             Inc(y, 2);
-          End;
+          end;
 
           { setup flame generator pointer }
           generator := pixels + width * (height - 4);
 
           { update flame generator bar }
           x := 0;
-          While x < width Do
-          Begin
+          while x < width do
+          begin
             { random block color taking intensity into account }
             color := random(Integer(Trunc(255 * intensity)));
 
@@ -236,30 +227,30 @@ Begin
             { next block }
             Inc(generator, 4);
             Inc(x, 4);
-          End;
+          end;
 
-        Finally
+        finally
           { unlock surface }
           surface.unlock;
-	End;
+        end;
 
         { copy surface to console }
         surface.copy(console, area, area);
 
         { update console }
         console.update;
-      Until False;
-      
-    Finally
+      until False;
+
+    finally
       console.Free;
       surface.Free;
       format.Free;
       palette.Free;
       area.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/flower.pp

@@ -8,133 +8,121 @@ Ported to FPC by Nikolay Nikolov ([email protected])
  This source code is licensed under the GNU GPL
 }
 
-Program Flower;
+program Flower;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc, Math;
 
-Function pack(r, g, b : Uint32) : Uint32;
-
-Begin
+function pack(r, g, b: Uint32): Uint32;
+begin
   { pack color integer }
-  pack := (r Shl 16) Or (g Shl 8) Or b;
-End;
-
-Procedure generate_flower(flower : TPTCSurface);
-
-Var
-  data : PUint8;
-  x, y, fx, fy, fx2, fy2 : Integer;
-  TWO_PI : Single;
-
-Begin
+  pack := (r shl 16) or (g shl 8) or b;
+end;
+
+procedure generate_flower(flower: TPTCSurface);
+var
+  data: PUint8;
+  x, y, fx, fy, fx2, fy2: Integer;
+  TWO_PI: Single;
+begin
   { lock surface }
   data := flower.lock;
-  
-  Try
+
+  try
     { surface width and height constants for cleaner code }
     fx := flower.width;
     fy := flower.height;
-    fx2 := fx Div 2;
-    fy2 := fy Div 2;
+    fx2 := fx div 2;
+    fy2 := fy div 2;
 
     { useful 2*pi constant }
     TWO_PI := 2 * PI;
 
     { generate flower image }
-    For y := 0 To fy - 1 Do
-      For x := 0 To fx - 1 Do
+    for y := 0 to fy - 1 do
+      for x := 0 to fx - 1 do
         data[x + y * fx] := Trunc(1.0 * Cos(18*ArcTan2((y - fy2),(x - fx2))) * 255 / TWO_PI +
-		                  0.3 * Sin(15*ArcTan2((y - fy2),(x - fx2))) * 255 / TWO_PI +
-                                  Sqrt((y - fy2) * (y - fy2) + (x - fx2) * (x - fx2))) And $FF;
+                                  0.3 * Sin(15*ArcTan2((y - fy2),(x - fx2))) * 255 / TWO_PI +
+                                  Sqrt((y - fy2) * (y - fy2) + (x - fx2) * (x - fx2))) and $FF;
 
     { You might want to move the 1.0 and 0.3 and the 18 and the 15
       to parameters passed to the generate function...
       the 1.0 and the 0.3 define the 'height' of the flower, while the
       18 and 15 control the number of 'petals' }
-  Finally
+  finally
     flower.unlock;
-  End;
-End;
-
-Procedure generate(palette : TPTCPalette);
-
-Var
-  data : PUint32;
-  i, c : Integer;
-
-Begin
+  end;
+end;
+
+procedure generate(palette: TPTCPalette);
+var
+  data: PUint32;
+  i, c: Integer;
+begin
   { lock palette data }
   data := palette.lock;
-  
-  Try
+
+  try
     { black to yellow }
     i := 0;
     c := 0;
-    While i < 64 Do
-    Begin
+    while i < 64 do
+    begin
       data[i] := pack(c, c, 0);
       Inc(c, 4);
       Inc(i);
-    End;
+    end;
 
     { yellow to red }
     c := 0;
-    While i < 128 Do
-    Begin
+    while i < 128 do
+    begin
       data[i] := pack(255, 255 - c, 0);
       Inc(c, 4);
       Inc(i);
-    End;
+    end;
 
     { red to white }
     c := 0;
-    While i < 192 Do
-    Begin
+    while i < 192 do
+    begin
       data[i] := pack(255, c, c);
       Inc(c, 4);
       Inc(i);
-    End;
+    end;
 
     { white to black }
     c := 0;
-    While i < 256 Do
-    Begin
+    while i < 256 do
+    begin
       data[i] := pack(255 - c, 255 - c, 255 - c);
       Inc(c, 4);
       Inc(i);
-    End;
-  Finally
+    end;
+  finally
     { unlock palette }
     palette.unlock;
-  End;
-End;
-
-Var
-  console : TPTCConsole;
-  format : TPTCFormat;
-  flower_surface : TPTCSurface;
-  surface : TPTCSurface;
-  palette : TPTCPalette;
-  area : TPTCArea;
-  time, delta : Single;
-  scr, map : PUint8;
-  width, height, mapWidth : Integer;
-  xo, yo, xo2, yo2, xo3, yo3 : Single;
-  offset1, offset2, offset3 : Integer;
-  x, y : Integer;
-
-Begin
-  area := Nil;
-  format := Nil;
-  palette := Nil;
-  surface := Nil;
-  flower_surface := Nil;
-  console := Nil;
-  Try
-    Try
+  end;
+end;
+
+var
+  console: TPTCConsole = nil;
+  format: TPTCFormat = nil;
+  flower_surface: TPTCSurface = nil;
+  surface: TPTCSurface = nil;
+  palette: TPTCPalette = nil;
+  area: TPTCArea = nil;
+  time, delta: Single;
+  scr, map: PUint8;
+  width, height, mapWidth: Integer;
+  xo, yo, xo2, yo2, xo3, yo3: Single;
+  offset1, offset2, offset3: Integer;
+  x, y: Integer;
+begin
+  try
+    try
       { create format }
       format := TPTCFormat.Create(8);
 
@@ -173,13 +161,13 @@ Begin
       delta := 0.04;
 
       { main loop }
-      While Not console.KeyPressed Do
-      Begin
+      while not console.KeyPressed do
+      begin
         { lock surface pixels }
         scr := surface.lock;
-	Try
+        try
           map := flower_surface.lock;
-	  Try
+          try
             { get surface dimensions }
             width := surface.width;
             height := surface.height;
@@ -198,20 +186,20 @@ Begin
             offset3 := Trunc(xo3) + Trunc(yo3) * mapWidth;
 
             { vertical loop }
-            For y := 0 To height - 1 Do
+            for y := 0 to height - 1 do
               { horizontal loop }
-	      For x := 0 To width - 1 Do
-	        scr[x + y * width] := (map[x + y * mapWidth + offset1] +
-				       map[x + y * mapWidth + offset2] +
-				       map[x + y * mapWidth + offset3]) And $FF;
-	  Finally
+              for x := 0 to width - 1 do
+                scr[x + y * width] := (map[x + y * mapWidth + offset1] +
+                                       map[x + y * mapWidth + offset2] +
+                                       map[x + y * mapWidth + offset3]) and $FF;
+          finally
             { unlock surface }
             flower_surface.unlock;
-	  End;
-	Finally
+          end;
+        finally
           { unlock surface }
           surface.unlock;
-	End;
+        end;
 
         { copy surface to console }
         surface.copy(console, area, area);
@@ -221,9 +209,9 @@ Begin
 
         { update time }
         time := time + delta;
-      End;
-    Finally
-      If Assigned(console) Then
+      end;
+    finally
+      if Assigned(console) then
         console.close;
       area.Free;
       format.Free;
@@ -231,10 +219,10 @@ Begin
       surface.Free;
       flower_surface.Free;
       console.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/hicolor.pp

@@ -3,33 +3,29 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- HiColor example for OpenPTC 1.0 C++ Implementation
+ HiColor example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program HiColorExample;
+program HiColorExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Var
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  format : TPTCFormat;
-  pixels : Pshort16;
-  width, height : Integer;
-  i : Integer;
-  x, y, r, g, b : Integer;
-
-Begin
-  format := Nil;
-  surface := Nil;
-  console := Nil;
-  Try
-    Try
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+  pixels: PUint16;
+  width, height: Integer;
+  i: Integer;
+  x, y, r, g, b: Integer;
+begin
+  try
+    try
       { create console }
       console := TPTCConsole.Create;
 
@@ -43,52 +39,52 @@ Begin
       surface := TPTCSurface.Create(console.width, console.height, format);
 
       { loop until a key is pressed }
-      While Not console.KeyPressed Do
-      Begin
+      while not console.KeyPressed do
+      begin
         { lock surface }
         pixels := surface.lock;
-        Try
+        try
           { get surface dimensions }
           width := surface.width;
           height := surface.height;
 
           { draw random pixels }
-          For i := 1 To 100 Do
-          Begin
+          for i := 1 to 100 do
+          begin
             { get random position }
-	    x := Random(width);
-	    y := Random(height);
+            x := Random(width);
+            y := Random(height);
 
             { get random color }
-	    r := Random(256);
-	    g := Random(256);
-	    b := Random(256);
+            r := Random(256);
+            g := Random(256);
+            b := Random(256);
 
             { draw color [r,g,b] at position [x,y] }
-	    pixels[x + y * width] := ((r And $00F8) Shl 8) Or
-				     ((g And $00FC) Shl 3) Or
-				     ((b And $00F8) Shr 3);
-          End;
-	Finally
+            pixels[x + y * width] := ((r and $00F8) shl 8) or
+                                     ((g and $00FC) shl 3) or
+                                     ((b and $00F8) shr 3);
+          end;
+        finally
           { unlock surface }
           surface.unlock;
-	End;
+        end;
 
         { copy to console }
         surface.copy(console);
 
         { update console }
         console.update;
-      End;
-    Finally
+      end;
+    finally
       console.close;
       console.Free;
       surface.Free;
       format.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/image.pp

@@ -3,104 +3,114 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Image example for OpenPTC 1.0 C++ Implementation
+ Image example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program ImageExample;
+program ImageExample;
 
 {$MODE objfpc}
 
-Uses
-  ptc;
-
-Procedure load(surface : TPTCSurface; filename : String);
-
-Var
-  F : File;
-  width, height : Integer;
-  pixels : PByte;
-  y : Integer;
-  tmp : TPTCFormat;
-  tmp2 : TPTCPalette;
-
-Begin
+uses
+  SysUtils, ptc;
+
+procedure load(surface: TPTCSurface; filename: String);
+var
+  F: File;
+  width, height: Integer;
+  pixels: PByte = nil;
+  y: Integer;
+  img_format: TPTCFormat = nil;
+  img_palette: TPTCPalette = nil;
+begin
   { open image file }
-  ASSign(F, filename);
+  AssignFile(F, filename);
   Reset(F, 1);
 
-  { skip header }
-  Seek(F, 18);
-
-  { get surface dimensions }
-  width := surface.width;
-  height := surface.height;
-
-  { allocate image pixels }
-  pixels := GetMem(width * height * 3);
-
-  { read image pixels one line at a time }
-  For y := height - 1 DownTo 0 Do
-    BlockRead(F, pixels[width * y * 3], width * 3);
-
-  { load pixels to surface }
-  tmp := TPTCFormat.Create(24, $00FF0000, $0000FF00, $000000FF);
-  tmp2 := TPTCPalette.Create;
-  surface.load(pixels, width, height, width * 3, tmp, tmp2);
-  tmp2.Free;
-  tmp.Free;
-
-  { free image pixels }
-  FreeMem(pixels);
-End;
-
-Var
-  console : TPTCConsole;
-  format : TPTCFormat;
-  surface : TPTCSurface;
-
-Begin
-  Try
-    { create console }
-    console := TPTCConsole.Create;
-
-    { create format }
-    format := TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF);
-
-    Try
-      { try to open the console matching the image resolution }
-      console.open('Image example', 320, 200, format);
-    Except
-      On TPTCError Do
-        { fallback to the default resolution }
-        console.open('Image example', format);
-    End;
-
-    { create surface }
-    surface := TPTCSurface.Create(320, 200, format);
-    format.Free;
-
-    { load image to surface }
-    load(surface, 'image.tga');
-
-    { copy surface to console }
-    surface.copy(console);
-
-    { update console }
-    console.update;
-
-    { read key }
-    console.ReadKey;
-
-    { close console }
-    console.close;
-
-    console.Free;
-    surface.Free;
-  Except
-    On error : TPTCError Do
+  try
+    { skip header }
+    Seek(F, 18);
+
+    { get surface dimensions }
+    width := surface.width;
+    height := surface.height;
+
+    { allocate image pixels }
+    pixels := GetMem(width * height * 3);
+
+    { read image pixels one line at a time }
+    for y := height - 1 DownTo 0 do
+      BlockRead(F, pixels[width * y * 3], width * 3);
+
+    { load pixels to surface }
+    {$IFDEF FPC_LITTLE_ENDIAN}
+    img_format := TPTCFormat.Create(24, $00FF0000, $0000FF00, $000000FF);
+    {$ELSE FPC_LITTLE_ENDIAN}
+    img_format := TPTCFormat.Create(24, $000000FF, $0000FF00, $00FF0000);
+    {$ENDIF FPC_LITTLE_ENDIAN}
+    img_palette := TPTCPalette.Create;
+    surface.load(pixels, width, height, width * 3, img_format, img_palette);
+
+  finally
+    CloseFile(F);
+
+    { free image pixels }
+    FreeMem(pixels);
+
+    img_palette.Free;
+    img_format.Free;
+  end;
+end;
+
+var
+  console: TPTCConsole = nil;
+  format: TPTCFormat = nil;
+  surface: TPTCSurface = nil;
+begin
+  try
+    try
+      { create console }
+      console := TPTCConsole.Create;
+
+      { create format }
+      format := TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF);
+
+      try
+        { try to open the console matching the image resolution }
+        console.open('Image example', 320, 200, format);
+      except
+        on TPTCError do
+          { fallback to the default resolution }
+          console.open('Image example', format);
+      end;
+
+      { create surface }
+      surface := TPTCSurface.Create(320, 200, format);
+
+      { load image to surface }
+      load(surface, 'image.tga');
+
+      { copy surface to console }
+      surface.copy(console);
+
+      { update console }
+      console.update;
+
+      { read key }
+      console.ReadKey;
+
+    finally
+      { close console }
+      console.close;
+
+      console.Free;
+      surface.Free;
+      format.Free;
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/keyboard.pp

@@ -3,40 +3,34 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Keyboard example for OpenPTC 1.0 C++ Implementation
+ Keyboard example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program KeyboardExample;
+program KeyboardExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Var
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  format : TPTCFormat;
-  color : TPTCColor;
-  key : TPTCKey;
-  area : TPTCArea;
-  x, y : Integer;
-  size : Integer;
-  delta : Integer;
-
-Begin
-  key := Nil;
-  color := Nil;
-  format := Nil;
-  surface := Nil;
-  console := Nil;
-  Try
-    Try
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+  color: TPTCColor = nil;
+  key: TPTCKeyEvent = nil;
+  area: TPTCArea;
+  x, y: Integer;
+  size: Integer;
+  delta: Integer;
+begin
+  try
+    try
       { create key }
-      key := TPTCKey.Create;
-      
+      key := TPTCKeyEvent.Create;
+
       { create console }
       console := TPTCConsole.Create;
 
@@ -50,67 +44,67 @@ Begin
       surface := TPTCSurface.Create(console.width, console.height, format);
 
       { setup cursor data }
-      x := surface.width Div 2;
-      y := surface.height Div 2;
-      size := surface.width Div 10;
+      x := surface.width div 2;
+      y := surface.height div 2;
+      size := surface.width div 10;
       color := TPTCColor.Create(1, 1, 1);
 
       { main loop }
-      Repeat
+      repeat
         { check for key press }
-        If console.KeyPressed Then
-        Begin
+        if console.KeyPressed then
+        begin
           { read console key press }
           console.ReadKey(key);
-	
+
           { shift modifier }
-	  If key.shift Then
+          if key.shift then
             { move fast }
-	    delta := 10
-	  Else
+            delta := 10
+          else
             { move slow }
-	    delta := 1;
+            delta := 1;
 
           { handle cursor keys }
-          Case key.code Of
-            PTCKEY_LEFT : Dec(x, delta);
-            PTCKEY_RIGHT : Inc(x, delta);
-            PTCKEY_UP : Dec(y, delta);
-            PTCKEY_DOWN : Inc(y, delta);
+          case key.code of
+            PTCKEY_LEFT: Dec(x, delta);
+            PTCKEY_RIGHT: Inc(x, delta);
+            PTCKEY_UP: Dec(y, delta);
+            PTCKEY_DOWN: Inc(y, delta);
             { exit when escape is pressed }
-            PTCKEY_ESCAPE : Break;
-          End;
-        End;
+            PTCKEY_ESCAPE: Break;
+          end;
+        end;
 
         { clear surface }
         surface.clear;
 
         { setup cursor area }
         area := TPTCArea.Create(x - size, y - size, x + size, y + size);
-        Try
+        try
           { draw cursor as a quad }
           surface.clear(color, area);
-        Finally
+        finally
           area.Free;
-        End;
+        end;
 
         { copy to console }
         surface.copy(console);
 
         { update console }
         console.update;
-      Until False;
-    Finally
+      until False;
+    finally
       color.Free;
       console.close;
       console.Free;
       surface.Free;
       key.Free;
       format.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/keybrd2.pp → packages/ptc/examples/keyboard2.pp

@@ -1,36 +1,40 @@
-Program KeyboardExample2;
+{
+ Keyboard example for the PTCPas library
+ This source code is in the public domain
+}
+
+program KeyboardExample2;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Var
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  format : TPTCFormat;
-  color : TPTCColor;
-  timer : TPTCTimer;
-  key : TPTCKey;
-  area : TPTCArea;
-  x, y, delta : Real;
-  left, right, up, down : Boolean;
-  size : Integer;
-  Done : Boolean;
-
-Begin
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+  color: TPTCColor = nil;
+  timer: TPTCTimer = nil;
+  key: TPTCKeyEvent = nil;
+  area: TPTCArea;
+  x, y, delta: Real;
+  left, right, up, down: Boolean;
+  size: Integer;
+  Done: Boolean;
+begin
   left := False;
   right := False;
   up := False;
   down := False;
-  Try
-    Try
+  try
+    try
       { create key }
-      key := TPTCKey.Create;
-      
+      key := TPTCKeyEvent.Create;
+
       { create console }
       console := TPTCConsole.Create;
-      
+
       { enable key release events }
       console.KeyReleaseEnabled := True;
 
@@ -39,71 +43,71 @@ Begin
 
       { open the console }
       console.open('Keyboard example 2', format);
-      
+
       { create timer }
       timer := TPTCTimer.Create;
-      
+
       { create surface matching console dimensions }
       surface := TPTCSurface.Create(console.width, console.height, format);
 
       { setup cursor data }
-      x := surface.width Div 2;
-      y := surface.height Div 2;
-      size := surface.width Div 10;
+      x := surface.width div 2;
+      y := surface.height div 2;
+      size := surface.width div 10;
       color := TPTCColor.Create(1, 1, 1);
-      
+
       { start timer }
       timer.start;
 
       { main loop }
       Done := False;
-      Repeat
+      repeat
         { check for key press/release }
-        While console.KeyPressed Do
-        Begin
+        while console.KeyPressed do
+        begin
           console.ReadKey(key);
-          Case key.code Of
-	    PTCKEY_LEFT : left := key.press;
-	    PTCKEY_RIGHT : right := key.press;
-	    PTCKEY_UP : up := key.press;
-	    PTCKEY_DOWN : down := key.press;
-	    PTCKEY_ESCAPE : Begin
-	      Done := True;
-	      Break;
-	    End;
-	  End;
-        End;
+          case key.code of
+            PTCKEY_LEFT: left := key.press;
+            PTCKEY_RIGHT: right := key.press;
+            PTCKEY_UP: up := key.press;
+            PTCKEY_DOWN: down := key.press;
+            PTCKEY_ESCAPE: begin
+              Done := True;
+              Break;
+            end;
+          end;
+        end;
 
         { move square }
         delta := timer.delta*100;
-        If left Then
-          x -= delta;
-        If right Then
-          x += delta;
-        If up Then
-          y -= delta;
-        If down Then
-          y += delta;
+        if left then
+          x := x - delta;
+        if right then
+          x := x + delta;
+        if up then
+          y := y - delta;
+        if down then
+          y := y + delta;
 
         { clear surface }
         surface.clear;
 
         { setup cursor area }
         area := TPTCArea.Create(Trunc(x) - size, Trunc(y) - size, Trunc(x) + size, Trunc(y) + size);
-        Try
+        try
           { draw cursor as a quad }
           surface.clear(color, area);
-        Finally
+        finally
           area.Free;
-        End;
+        end;
 
         { copy to console }
         surface.copy(console);
 
         { update console }
         console.update;
-      Until Done;
-    Finally
+      until Done;
+    finally
       color.Free;
       console.close;
       console.Free;
@@ -111,10 +115,10 @@ Begin
       key.Free;
       timer.Free;
       format.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/land.pp

@@ -13,121 +13,116 @@ Ported to FPC by Nikolay Nikolov ([email protected])
  Cursor keys to move, <Pause> to brake and <Esc> to quit
 }
 
-Program Land;
+program Land;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Const
+const
   SCREENWIDTH = 320;
   SCREENHEIGHT = 200;
 
-  FOV : Integer = 256; { half of the xy field of view (This is based on the 0-2048 convention) }
+  FOV: Integer = 256; { half of the xy field of view (This is based on the 0-2048 convention) }
 
-Var
-  HMap : Array[0..256*256 - 1] Of Uint8; { Height field }
-  CMap : Array[0..256*256 - 1] Of Uint8; { Color map }
+var
+  HMap: array [0..256*256 - 1] of Uint8; { Height field }
+  CMap: array [0..256*256 - 1] of Uint8; { Color map }
 
   lasty, { Last pixel drawn on a given column }
-  lastc : Array[0..SCREENWIDTH - 1] Of Integer; { Color of last pixel on a column }
-  CosT, SinT : Array[0..2047] Of Integer; { Cosine and Sine tables }
+  lastc: array [0..SCREENWIDTH - 1] of Integer; { Color of last pixel on a column }
+  CosT, SinT: array [0..2047] of Integer; { Cosine and Sine tables }
 
 { Reduces a value to 0..255 (used in height field computation) }
-Function Clamp(x : Integer) : Integer;
-
-Begin
-  If x < 0 Then
-    Clamp := 0
-  Else
-    If x > 255 Then
-      Clamp := 255
-    Else
-      Clamp := x;
-End;
+function Clamp(x: Integer): Integer;
+begin
+  if x < 0 then
+    Result := 0
+  else
+    if x > 255 then
+      Result := 255
+    else
+      Result := x;
+end;
 
 { Heightfield and colormap computation }
-Procedure ComputeMap;
-
-Var
-  p, i, j, k, k2, p2, a, b, c, d : Integer;
-
-Begin
+procedure ComputeMap;
+var
+  p, i, j, k, k2, p2, a, b, c, d: Integer;
+begin
   { Start from a plasma clouds fractal }
   HMap[0] := 128;
   p := 256;
-  While p > 1 Do
-  Begin
-    p2 := p Shr 1;
+  while p > 1 do
+  begin
+    p2 := p shr 1;
     k := p * 8 + 20;
-    k2 := k Shr 1;
+    k2 := k shr 1;
     i := 0;
-    While i < 256 Do
-    Begin
+    while i < 256 do
+    begin
       j := 0;
-      While j < 256 Do
-      Begin
-	a := HMap[(i Shl 8) + j];
-	b := HMap[(((i + p) And 255) Shl 8) + j];
-	c := HMap[(i Shl 8) + ((j + p) And 255)];
-	d := HMap[(((i + p) And 255) Shl 8) + ((j + p) And 255)];
-
-	HMap[(i Shl 8) + ((j + p2) And 255)] :=
-	  Clamp(((a + c) Shr 1) + (Random(k) - k2));
-	HMap[(((i + p2) And 255) Shl 8) + ((j + p2) And 255)] :=
-	  Clamp(((a + b + c + d) Shr 2) + (Random(k) - k2));
-	HMap[(((i + p2) And 255) Shl 8) + j] :=
-	  Clamp(((a + b) Shr 1) + (Random(k) - k2));
-	Inc(j, p);
-      End;
+      while j < 256 do
+      begin
+        a := HMap[(i shl 8) + j];
+        b := HMap[(((i + p) and 255) shl 8) + j];
+        c := HMap[(i shl 8) + ((j + p) and 255)];
+        d := HMap[(((i + p) and 255) shl 8) + ((j + p) and 255)];
+
+        HMap[(i shl 8) + ((j + p2) and 255)] :=
+          Clamp(((a + c) shr 1) + (Random(k) - k2));
+        HMap[(((i + p2) and 255) shl 8) + ((j + p2) and 255)] :=
+          Clamp(((a + b + c + d) shr 2) + (Random(k) - k2));
+        HMap[(((i + p2) and 255) shl 8) + j] :=
+          Clamp(((a + b) shr 1) + (Random(k) - k2));
+        Inc(j, p);
+      end;
       Inc(i, p);
-    End;
+    end;
     p := p2;
-  End;
+  end;
 
   { Smoothing }
-  For k := 0 To 2 Do
-  Begin
+  for k := 0 to 2 do
+  begin
     i := 0;
-    While i < 256*256 Do
-    Begin
-      For j := 0 To 255 Do
-	HMap[i + j] := (HMap[((i + 256) And $FF00) + j] +
-			HMap[i + ((j + 1) And $FF)] +
-			HMap[((i - 256) And $FF00) + j] +
-			HMap[i + ((j - 1) And $FF)]) Shr 2;
+    while i < 256*256 do
+    begin
+      for j := 0 to 255 do
+        HMap[i + j] := (HMap[((i + 256) and $FF00) + j] +
+                        HMap[i + ((j + 1) and $FF)] +
+                        HMap[((i - 256) and $FF00) + j] +
+                        HMap[i + ((j - 1) and $FF)]) shr 2;
       Inc(i, 256);
-    End;
-  End;
+    end;
+  end;
 
   { Color computation (derivative of the height field) }
   i := 0;
-  While i < 256*256 Do
-  Begin
-    For j := 0 To 255 Do
-    Begin
-      k := 128 + (HMap[((i + 256) And $FF00) + ((j + 1) And 255)] - HMap[i + j])*4;
-      If k < 0 Then
-	k := 0;
-      If k > 255 Then
-	k := 255;
+  while i < 256*256 do
+  begin
+    for j := 0 to 255 do
+    begin
+      k := 128 + (HMap[((i + 256) and $FF00) + ((j + 1) and 255)] - HMap[i + j])*4;
+      if k < 0 then
+        k := 0;
+      if k > 255 then
+        k := 255;
       CMap[i + j] := k;
-    End;
+    end;
     Inc(i, 256);
-  End;
-End;
+  end;
+end;
 
 { Calculate the lookup tables }
-Procedure InitTables;
-
-Var
-  a : Integer;
-  result : Single;
-
-Begin
-  For a := 0 To 2047 Do
-  Begin
+procedure InitTables;
+var
+  a: Integer;
+  result: Single;
+begin
+  for a := 0 to 2047 do
+  begin
     { Precalculate cosine }
     result := cos(a * PI / 1024) * 256;
     CosT[a] := Trunc(result);
@@ -135,8 +130,8 @@ Begin
     { and sine }
     result := sin(a * PI / 1024) * 256;
     SinT[a] := Trunc(result);
-  End;
-End;
+  end;
+end;
 
 {
  Draw a "section" of the landscape; x0,y0 and x1,y1 and the xy coordinates
@@ -144,29 +139,27 @@ End;
  for the distance. x0,y0,x1,y1 are 16.16 fixed point numbers and the
  scaling factor is a 16.8 fixed point value.
 }
-Procedure Line(x0, y0, x1, y1, hy, s : Integer; surface_buffer : PUint32; fadeout : Integer);
-
-Var
-  sx, sy, i, a, b, u0, u1, v0, v1, h0, h1, h2, h3, h, c, y : Integer;
-  coord_x, coord_y, sc, cc, currentColor : Integer;
-  pixel : PUint32;
-
-Begin
+procedure Line(x0, y0, x1, y1, hy, s: Integer; surface_buffer: PUint32; fadeout: Integer);
+var
+  sx, sy, i, a, b, u0, u1, v0, v1, h0, h1, h2, h3, h, c, y: Integer;
+  coord_x, coord_y, sc, cc, currentColor: Integer;
+  pixel: PUint32;
+begin
   { Compute xy speed }
-  sx := (x1 - x0) Div SCREENWIDTH;
-  sy := (y1 - y0) Div SCREENWIDTH;
+  sx := (x1 - x0) div SCREENWIDTH;
+  sy := (y1 - y0) div SCREENWIDTH;
 
-  For i := 0 To SCREENWIDTH - 1 Do
-  Begin
+  for i := 0 to SCREENWIDTH - 1 do
+  begin
     { Compute the xy coordinates; a and b will be the position inside the }
     { single map cell (0..255). }
-    a := (x0 Shr 8) And $FF;
-    b := (y0 Shr 8) And $FF;
+    a := (x0 shr 8) and $FF;
+    b := (y0 shr 8) and $FF;
 
-    u0 := (x0 Shr 16) And $FF;
-    u1 := (u0 + 1) And $FF;
-    v0 := (y0 Shr 8) And $FF00;
-    v1 := (v0 + 256) And $FF00;
+    u0 := (x0 shr 16) and $FF;
+    u1 := (u0 + 1) and $FF;
+    v0 := (y0 shr 8) and $FF00;
+    v1 := (v0 + 256) and $FF00;
 
     { Fetch the height at the four corners of the square the point is in }
     h0 := HMap[u0 + v0];
@@ -175,9 +168,9 @@ Begin
     h3 := HMap[u1 + v1];
 
     { Compute the height using bilinear interpolation }
-    h0 := (h0 Shl 8) + a * (h1 - h0);
-    h2 := (h2 Shl 8) + a * (h3 - h2);
-    h := ((h0 Shl 8) + b * (h2 - h0)) Shr 16;
+    h0 := (h0 shl 8) + a * (h1 - h0);
+    h2 := (h2 shl 8) + a * (h3 - h2);
+    h := ((h0 shl 8) + b * (h2 - h0)) shr 16;
 
     { Fetch the color at the centre of the square the point is in }
     h0 := CMap[u0 + v0];
@@ -186,72 +179,70 @@ Begin
     h3 := CMap[u1 + v1];
 
     { Compute the color using bilinear interpolation (in 16.16) }
-    h0 := (h0 Shl 8) + a * (h1 - h0);
-    h2 := (h2 Shl 8) + a * (h3 - h2);
-    c := ((h0 Shl 8) + b * (h2 - h0));
+    h0 := (h0 shl 8) + a * (h1 - h0);
+    h2 := (h2 shl 8) + a * (h3 - h2);
+    c := ((h0 shl 8) + b * (h2 - h0));
 
     { Compute screen height using the scaling factor }
-    y := (((h - hy) * s) Shr 11) + (SCREENHEIGHT Shr 1);
+    y := (((h - hy) * s) shr 11) + (SCREENHEIGHT shr 1);
 
     { Draw the column }
     a := lasty[i];
-    If y < a Then
-    Begin
+    if y < a then
+    begin
       coord_x := i;
       coord_y := a;
-      If lastc[i] = -1 Then
-	lastc[i] := c;
+      if lastc[i] = -1 then
+        lastc[i] := c;
 
-      sc := (c - lastc[i]) Div (a - y);
+      sc := (c - lastc[i]) div (a - y);
       cc := lastc[i];
 
-      If a > (SCREENHEIGHT - 1) Then
-      Begin
-	Dec(coord_y, a - (SCREENHEIGHT - 1));
-	a := SCREENHEIGHT - 1;
-      End;
-      If y < 0 Then
-	y := 0;
-
-      While y < a Do
-      Begin
-	currentColor := cc Shr 18;
-	pixel := surface_buffer + (coord_y * SCREENWIDTH) + coord_x;
-	pixel^ := ((currentColor Shl 2) * (150 - fadeout) Div 150) Shl 8;
-	Inc(cc, sc);
-	Dec(coord_y);
-	Dec(a);
-      End;
+      if a > (SCREENHEIGHT - 1) then
+      begin
+        Dec(coord_y, a - (SCREENHEIGHT - 1));
+        a := SCREENHEIGHT - 1;
+      end;
+      if y < 0 then
+        y := 0;
+
+      while y < a do
+      begin
+        currentColor := cc shr 18;
+        pixel := surface_buffer + (coord_y * SCREENWIDTH) + coord_x;
+        pixel^ := ((currentColor shl 2) * (150 - fadeout) div 150) shl 8;
+        Inc(cc, sc);
+        Dec(coord_y);
+        Dec(a);
+      end;
       lasty[i] := y;
-    End;
+    end;
     lastc[i] := c;
 
     { Advance to next xy position }
     Inc(x0, sx); Inc(y0, sy);
-  End;
-End;
+  end;
+end;
 
 { Draw the view from the point x0,y0 (16.16) looking at angle a }
-Procedure View(x0, y0, angle, height : Integer; surface_buffer : PUint32);
-
-Var
-  d, u0, a, v0, u1, v1, h0, h1, h2, h3 : Integer;
-
-Begin
+procedure View(x0, y0, angle, height: Integer; surface_buffer: PUint32);
+var
+  d, u0, a, v0, u1, v1, h0, h1, h2, h3: Integer;
+begin
   { Initialize last-y and last-color arrays }
-  For d := 0 To SCREENWIDTH - 1 Do
-  Begin
+  for d := 0 to SCREENWIDTH - 1 do
+  begin
     lasty[d] := SCREENHEIGHT;
     lastc[d] := -1;
-  End;
+  end;
 
   { Compute the xy coordinates; a and b will be the position inside the }
   { single map cell (0..255). }
-  u0 := (x0 Shr 16) And $FF;
-  a := (x0 Shr 8) And $FF;
-  v0 := (y0 Shr 8) And $FF00;
-  u1 := (u0 + 1) And $FF;
-  v1 := (v0 + 256) And $FF00;
+  u0 := (x0 shr 16) and $FF;
+  a := (x0 shr 8) and $FF;
+  v0 := (y0 shr 8) and $FF00;
+  u1 := (u0 + 1) and $FF;
+  v1 := (v0 + 256) and $FF00;
 
   { Fetch the height at the four corners of the square the point is in }
   h0 := HMap[u0 + v0];
@@ -260,47 +251,41 @@ Begin
   h3 := HMap[u1 + v1];
 
   { Compute the height using bilinear interpolation }
-  h0 := (h0 Shl 8) + a * (h1 - h0);
-  h2 := (h2 Shl 8) + a * (h3 - h2);
+  h0 := (h0 shl 8) + a * (h1 - h0);
+  h2 := (h2 shl 8) + a * (h3 - h2);
 
   { Draw the landscape from near to far without overdraw }
   d := 0;
-  While d < 150 Do
-  Begin
-    Line(x0 + (d Shl 8)*CosT[(angle - FOV) And $7FF],
-	 y0 + (d Shl 8)*SinT[(angle - FOV) And $7FF],
-	 x0 + (d Shl 8)*CosT[(angle + FOV) And $7FF],
-	 y0 + (d Shl 8)*SinT[(angle + FOV) And $7FF],
-	 height, (100 Shl 8) Div (d + 1),
-	 surface_buffer,
-	 d);
-    Inc(d, 1 + (d Shr 6));
-  End;
-End;
-
-Var
-  format : TPTCFormat;
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  timer : TPTCTimer;
-  key : TPTCKeyEvent;
-  pixels : PUint32;
-  Done : Boolean;
-
-  x0, y0 : Integer;
-  height : Integer;
-  angle, deltaAngle, deltaSpeed, CurrentSpeed, scale, delta : Double;
-  index : Integer;
-
-Begin
+  while d < 150 do
+  begin
+    Line(x0 + (d shl 8)*CosT[(angle - FOV) and $7FF],
+         y0 + (d shl 8)*SinT[(angle - FOV) and $7FF],
+         x0 + (d shl 8)*CosT[(angle + FOV) and $7FF],
+         y0 + (d shl 8)*SinT[(angle + FOV) and $7FF],
+         height, (100 shl 8) div (d + 1),
+         surface_buffer,
+         d);
+    Inc(d, 1 + (d shr 6));
+  end;
+end;
+
+var
+  format: TPTCFormat = nil;
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  timer: TPTCTimer = nil;
+  key: TPTCKeyEvent = nil;
+  pixels: PUint32;
+  Done: Boolean;
+
+  x0, y0: Integer;
+  height: Integer;
+  angle, deltaAngle, deltaSpeed, CurrentSpeed, scale, delta: Double;
+  index: Integer;
+begin
   Done := False;
-  format := Nil;
-  console := Nil;
-  surface := Nil;
-  timer := Nil;
-  key := Nil;
-  Try
-    Try
+  try
+    try
       key := TPTCKeyEvent.Create;
       format := TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF);
       console := TPTCConsole.Create;
@@ -330,7 +315,7 @@ Begin
       timer.start;
 
       { main loop }
-      Repeat
+      repeat
         { get time delta between frames }
         delta := timer.delta;
 
@@ -339,13 +324,13 @@ Begin
 
         { lock surface pixels }
         pixels := surface.lock;
-        Try
+        try
           { draw current landscape view }
           View(x0, y0, Trunc(angle), height, pixels);
-	Finally
+        finally
           { unlock surface }
           surface.unlock;
-	End;
+        end;
 
         { copy surface to console }
         surface.copy(console);
@@ -354,49 +339,49 @@ Begin
         console.update;
 
         { check key press }
-        While console.KeyPressed Do
-        Begin
+        while console.KeyPressed do
+        begin
           { read key press }
-	  console.ReadKey(key);
+          console.ReadKey(key);
 
           { handle key press }
-	  Case key.code Of
+          case key.code of
                         { increase speed }
-	    PTCKEY_UP : CurrentSpeed += deltaSpeed * delta * scale;
+            PTCKEY_UP: CurrentSpeed := CurrentSpeed + deltaSpeed * delta * scale;
                         { decrease speed }
-	    PTCKEY_DOWN : CurrentSpeed -= deltaSpeed * delta * scale;
+            PTCKEY_DOWN: CurrentSpeed := CurrentSpeed - deltaSpeed * delta * scale;
                         { turn to the left }
-	    PTCKEY_LEFT : deltaAngle -= 1;
+            PTCKEY_LEFT: deltaAngle := deltaAngle - 1;
                         { turn to the right }
-	    PTCKEY_RIGHT : deltaAngle += 1;
-	    PTCKEY_SPACE : Begin
+            PTCKEY_RIGHT: deltaAngle := deltaAngle + 1;
+            PTCKEY_SPACE: begin
               { stop moving }
-	      CurrentSpeed := 0;
-	      deltaAngle := 0;
-	    End;
+              CurrentSpeed := 0;
+              deltaAngle := 0;
+            end;
                            { exit }
-	    PTCKEY_ESCAPE : Done := True;
-	  End;
-        End;
+            PTCKEY_ESCAPE: Done := True;
+          end;
+        end;
 
         { Update position/angle }
-        angle += deltaAngle * delta * scale;
+        angle := angle + deltaAngle * delta * scale;
 
-        index := Trunc(angle) And $7FF;
-        Inc(x0, Trunc(CurrentSpeed * CosT[index]) Div 256);
-        Inc(y0, Trunc(CurrentSpeed * SinT[index]) Div 256);
-      Until Done;
-    Finally
+        index := Trunc(angle) and $7FF;
+        Inc(x0, Trunc(CurrentSpeed * CosT[index]) div 256);
+        Inc(y0, Trunc(CurrentSpeed * SinT[index]) div 256);
+      until Done;
+    finally
       console.close;
       console.Free;
       surface.Free;
       timer.Free;
       format.Free;
       key.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/lights.pp

@@ -8,56 +8,51 @@ Ported to FPC by Nikolay Nikolov ([email protected])
  This source code is licensed under the GNU GPL
 }
 
-Program Lights;
+program Lights;
 
 {$MODE objfpc}
+{$INLINE on}
 
-Uses
+uses
   ptc;
 
-Var
+var
   { distance lookup table }
-  distance_table : Array[0..299, 0..511] Of DWord; { note: 16.16 fixed }
+  distance_table: array [0..299, 0..511] of DWord; { note: 16.16 fixed }
 
 { intensity calculation }
-Function CalcIntensity(dx, dy : Integer; i : DWord) : DWord;{ Inline;}
-
-Begin
+function CalcIntensity(dx, dy: Integer; i: DWord): DWord; Inline;
+begin
   { lookup intensity at [dx,dy] }
-  CalcIntensity := i * distance_table[dy, dx];
-End;
-
-Var
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  format : TPTCFormat;
-  palette : TPTCPalette;
-  dx, dy : Integer;
-  divisor : Single;
-  data : PUint32;
-  pixels, line : PUint8;
-  width : Integer;
-  i : Integer;
-  x, y, x1, y1, x2, y2, x3, y3, x4, y4 : Integer;
-  cx1, cy1, cx2, cy2, cx3, cy3, cx4, cy4 : Single;
-  dx1, dy1, dx2, dy2, dx3, dy3, dx4, dy4 : Single;
-  _dx1, _dx2, _dx3, _dx4 : Integer;
-  _dy1, _dy2, _dy3, _dy4 : Integer;
-  ix1, ix2, ix3, ix4 : Integer;
-  i1, i2, i3, i4 : DWord;
-  length : Integer;
-  move_t, move_dt, move_ddt : Single;
-  flash_t, flash_dt, flash_ddt : Single;
-  intensity : DWord;
-  max_intensity, max_intensity_inc : Single;
-
-Begin
-  console := Nil;
-  format := Nil;
-  surface := Nil;
-  palette := Nil;
-  Try
-    Try
+  Result := i * distance_table[dy, dx];
+end;
+
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+  palette: TPTCPalette = nil;
+  dx, dy: Integer;
+  divisor: Single;
+  data: PUint32;
+  pixels, line: PUint8;
+  width: Integer;
+  i: Integer;
+  x, y, x1, y1, x2, y2, x3, y3, x4, y4: Integer;
+  cx1, cy1, cx2, cy2, cx3, cy3, cx4, cy4: Single;
+  dx1, dy1, dx2, dy2, dx3, dy3, dx4, dy4: Single;
+  _dx1, _dx2, _dx3, _dx4: Integer;
+  _dy1, _dy2, _dy3, _dy4: Integer;
+  ix1, ix2, ix3, ix4: Integer;
+  i1, i2, i3, i4: DWord;
+  length: Integer;
+  move_t, move_dt, move_ddt: Single;
+  flash_t, flash_dt, flash_ddt: Single;
+  intensity: DWord;
+  max_intensity, max_intensity_inc: Single;
+begin
+  try
+    try
       { create console }
       console := TPTCConsole.Create;
 
@@ -70,26 +65,26 @@ Begin
       surface := TPTCSurface.Create(320, 200, format);
 
       { setup intensity table }
-      For dy := 0 To 199 Do
-        For dx := 0 To 511 Do
-        Begin
+      for dy := 0 to 199 do
+        for dx := 0 to 511 do
+        begin
           divisor := sqrt((dx * dx) + (dy * dy));
-          If divisor < 0.3 Then
+          if divisor < 0.3 then
             divisor := 0.3;
           distance_table[dy, dx] := Trunc(65535 / divisor);
-        End;
+        end;
 
       { create palette }
       palette := TPTCPalette.Create;
 
       { generate greyscale palette }
       data := palette.lock;
-      Try
-        For i := 0 To 255 Do
-          data[i] := (i Shl 16) Or (i Shl 8) Or i;
-      Finally
+      try
+        for i := 0 to 255 do
+          data[i] := (i shl 16) or (i shl 8) or i;
+      finally
         palette.unlock;
-      End;
+      end;
 
       { set console palette }
       console.palette(palette);
@@ -132,8 +127,8 @@ Begin
       max_intensity_inc := 0.2;
 
       { main loop }
-      While Not console.KeyPressed Do
-      Begin
+      while not console.KeyPressed do
+      begin
         { source positions }
         x1 := Trunc(cx1 + dx1);
         y1 := Trunc(cy1 + dy1);
@@ -146,13 +141,13 @@ Begin
 
         { lock surface }
         pixels := surface.lock;
-        Try
+        try
           { get surface dimensions }
           width := surface.width;
 
           { line loop }
-          For y := 0 To 199 Do
-          Begin
+          for y := 0 to 199 do
+          begin
             { calcalate pointer to start of line }
             line := pixels + y * width;
 
@@ -166,8 +161,8 @@ Begin
             x := 0;
 
             { line loop }
-            While x < width Do
-            Begin
+            while x < width do
+            begin
               { get x deltas }
               _dx1 := abs(x1 - x);
               _dx2 := abs(x2 - x);
@@ -179,37 +174,37 @@ Begin
               ix2 := 1;
               ix3 := 1;
               ix4 := 1;
-              If x1 > x Then
+              if x1 > x then
                 ix1 := -1;
-              If x2 > x Then
+              if x2 > x then
                 ix2 := -1;
-              If x3 > x Then
+              if x3 > x then
                 ix3 := -1;
-              If x4 > x Then
+              if x4 > x then
                 ix4 := -1;
 
               { set span length to min delta }
               length := width - x;
-              If (x1 > x) And (_dx1 < length) Then
+              if (x1 > x) and (_dx1 < length) then
                 length := _dx1;
-              If (x2 > x) And (_dx2 < length) Then
+              if (x2 > x) and (_dx2 < length) then
                 length := _dx2;
-              If (x3 > x) And (_dx3 < length) Then
+              if (x3 > x) and (_dx3 < length) then
                 length := _dx3;
-              If (x4 > x) And (_dx4 < length) Then
+              if (x4 > x) and (_dx4 < length) then
                 length := _dx4;
 
               { pixel loop }
-              While length > 0 Do
-              Begin
+              while length > 0 do
+              begin
                 Dec(length);
                 { calc intensities }
                 intensity := CalcIntensity(_dx1, _dy1, i1);
                 Inc(intensity, CalcIntensity(_dx2, _dy2, i2));
                 Inc(intensity, CalcIntensity(_dx3, _dy3, i3));
                 Inc(intensity, CalcIntensity(_dx4, _dy4, i4));
-                intensity := intensity Shr 16;
-                If intensity > 255 Then
+                intensity := intensity shr 16;
+                if intensity > 255 then
                   intensity := 255;
 
                 { update deltas }
@@ -221,13 +216,13 @@ Begin
                 { store the pixel }
                 line[x] := intensity;
                 Inc(x);
-              End;
-            End;
-          End;
-	Finally
+              end;
+            end;
+          end;
+        finally
           { unlock surface }
           surface.unlock;
-	End;
+        end;
 
         { move the lights around }
         dx1 := 50  * sin((move_t + 0.0) * 0.10);
@@ -252,9 +247,9 @@ Begin
         flash_dt := flash_dt + flash_ddt;
 
         { reset on big flash... }
-        If (move_t > 600) And (i1 > 10000) And (i2 > 10000) And
-           (i3 > 10000) And (i4 > 10000) Then
-        Begin
+        if (move_t > 600) and (i1 > 10000) and (i2 > 10000) and
+           (i3 > 10000) and (i4 > 10000) then
+        begin
           move_t := 0.3;
           move_dt := 0.1;
           move_ddt := 0.0006;
@@ -263,7 +258,7 @@ Begin
           flash_ddt := 0.0004;
           max_intensity := 0.0;
           max_intensity_inc := 0.2;
-        End;
+        end;
 
         { update intensity }
         max_intensity := max_intensity + max_intensity_inc;
@@ -274,17 +269,17 @@ Begin
 
         { update console }
         console.update;
-      End;
-    Finally
+      end;
+    finally
       console.close;
       surface.Free;
       console.Free;
       palette.Free;
       format.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/modes.pp

@@ -3,45 +3,43 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Modes example for OpenPTC 1.0 C++ Implementation
+ Modes example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program ModesExample;
+program ModesExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Procedure print(Const format : TPTCFormat);
-
-Begin
+procedure print(const format: TPTCFormat);
+begin
   { check format type }
-  If format.direct Then
+  if format.direct then
     { check alpha }
-    If format.a = 0 Then
+    if format.a = 0 then
       { direct color format without alpha }
       Write('Format(', format.bits:2, ',$', HexStr(format.r, 8), ',$', HexStr(format.g, 8), ',$', HexStr(format.b, 8), ')')
-    Else
+    else
       { direct color format with alpha }
       Write('Format(', format.bits:2, ',$', HexStr(format.r, 8), ',$', HexStr(format.g, 8), ',$', HexStr(format.b, 8), ',$', HexStr(format.a, 8), ')')
-  Else
+  else
     { indexed color format }
     Write('Format(', format.bits:2, ')');
-End;
-
-Procedure print(Const mode : TPTCMode);
+end;
 
-Begin
+procedure print(const mode: TPTCMode);
+begin
   { print mode width and height }
   Write(' ', mode.width:4, ' x ', mode.height);
-  If mode.height < 1000 Then
+  if mode.height < 1000 then
     Write(' ');
-  If mode.height < 100 Then
+  if mode.height < 100 then
     Write(' ');
-  If mode.height < 10 Then
+  if mode.height < 10 then
     Write(' ');
   Write(' x ');
 
@@ -50,17 +48,15 @@ Begin
 
   { newline }
   Writeln;
-End;
-
-Var
-  console : TPTCConsole;
-  modes : PPTCMode;
-  index : Integer;
-
-Begin
-  console := Nil;
-  Try
-    Try
+end;
+
+var
+  console: TPTCConsole = nil;
+  modes: PPTCMode;
+  index: Integer;
+begin
+  try
+    try
       { create console }
       console := TPTCConsole.Create;
 
@@ -68,11 +64,11 @@ Begin
       modes := console.modes;
 
       { check for empty list }
-      If Not modes[0].valid Then
+      if not modes[0].valid then
         { the console mode list was empty }
         Writeln('[console mode list is not available]')
-      Else
-      Begin
+      else
+      begin
         { print mode list header }
         Writeln('[console modes]');
 
@@ -80,21 +76,21 @@ Begin
         index := 0;
 
         { iterate through all modes }
-        While modes[index].valid Do
-        Begin
+        while modes[index].valid do
+        begin
           { print mode }
           print(modes[index]);
 
           { next mode }
           Inc(index);
-        End;
-      End;
-    Finally
+        end;
+      end;
+    finally
       console.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/mouse.pp

@@ -0,0 +1,128 @@
+{
+ Mouse example for the PTCPas library
+ This source code is in the public domain
+}
+
+program MouseExample;
+
+{$MODE objfpc}
+
+uses
+  ptc;
+
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+  event: TPTCEvent = nil;
+  pixels: PUint32;
+  color: Uint32;
+  width, height: Integer;
+  I: Integer;
+  X, Y: Integer;
+  button: Boolean;
+  Done: Boolean = False;
+begin
+  try
+    try
+      { create console }
+      console := TPTCConsole.Create;
+
+      { create format }
+      format := TPTCFormat.Create(32, $FF0000, $FF00, $FF);
+
+      { open the console }
+      console.open('Mouse example', format);
+
+      { we're going to draw our own cursor, so disable the default cursor }
+      console.option('hide cursor');
+
+      { create surface matching console dimensions }
+      surface := TPTCSurface.Create(console.width, console.height, format);
+
+      { initialization }
+      X := 0;
+      Y := 0;
+
+      repeat
+        { wait for events }
+        console.NextEvent(event, True, PTCAnyEvent);
+
+        { handle mouse events }
+        if event is TPTCMouseEvent then
+        begin
+          { if there's more than one mouse event, process them all... }
+          repeat
+            X := (event as TPTCMouseEvent).X;
+            Y := (event as TPTCMouseEvent).Y;
+            button := PTCMouseButton1 in (event as TPTCMouseEvent).ButtonState;
+          until not console.NextEvent(event, False, [PTCMouseEvent]);
+        end;
+
+        { handle keyboard events }
+        if (event is TPTCKeyEvent) and (event as TPTCKeyEvent).Press then
+        begin
+          case (event as TPTCKeyEvent).Code of
+            PTCKEY_G: console.Option('grab mouse');
+            PTCKEY_U: console.Option('ungrab mouse');
+            PTCKEY_ESCAPE: Done := True;
+          end;
+        end;
+
+        { clear surface }
+        surface.clear;
+
+        { lock surface }
+        pixels := surface.lock;
+
+        try
+          { get surface dimensions }
+          width := surface.width;
+          height := surface.height;
+
+          if button then
+            color := $00FF00 { green cursor, if button 1 is pressed }
+          else
+            color := $FFFFFF; { white cursor if button 1 is not pressed }
+
+          { draw a small cross for a cursor }
+          for I := 2 to 10 do
+          begin
+            if (X - I) >= 0 then
+              pixels[X - I + Y * width] := color;
+
+            if (X + I) < width then
+              pixels[X + I + Y * width] := color;
+
+            if (Y - I) >= 0 then
+              pixels[X + (Y - I) * width] := color;
+
+            if (Y + I) < height then
+              pixels[X + (Y + I) * width] := color;
+          end;
+
+        finally
+          { unlock surface }
+          surface.unlock;
+        end;
+
+        { copy to console }
+        surface.copy(console);
+
+        { update console }
+        console.update;
+
+      until Done;
+    finally
+      console.close;
+      console.Free;
+      surface.Free;
+      format.Free;
+      event.Free;
+    end;
+  except
+    on error: TPTCError do
+      { report error }
+      error.report;
+  end;
+end.

packages/ptc/examples/palette.pp

@@ -3,100 +3,104 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Palette example for OpenPTC 1.0 C++ Implementation
+ Palette example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program PaletteExample;
+program PaletteExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Var
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  format : TPTCFormat;
-  palette : TPTCPalette;
-  data : Array[0..255] Of int32;
-  pixels : Pchar8;
-  width, height : Integer;
-  i : Integer;
-  x, y, index : Integer;
-
-Begin
-  Try
-    { create console }
-    console := TPTCConsole.Create;
-
-    { create format }
-    format := TPTCFormat.Create(8);
-
-    { open console }
-    console.open('Palette example', format);
-
-    { create surface }
-    surface := TPTCSurface.Create(console.width, console.height, format);
-    format.Free;
-
-    { create palette }
-    palette := TPTCPalette.Create;
-
-    { generate palette }
-    For i := 0 To 255 Do
-      data[i] := i;
-
-    { load palette data }
-    palette.load(data);
-
-    { set console palette }
-    console.palette(palette);
-
-    { set surface palette }
-    surface.palette(palette);
-    palette.Free;
-
-    { loop until a key is pressed }
-    While Not console.KeyPressed Do
-    Begin
-      { lock surface }
-      pixels := surface.lock;
-
-      { get surface dimensions }
-      width := surface.width;
-      height := surface.height;
-
-      { draw random pixels }
-      For i := 1 To 100 Do
-      Begin
-        { get random position }
-	x := Random(width);
-	y := Random(height);
-
-        { get random color index }
-	index := Random(256);
-
-        { draw color [index] at position [x,y] }
-	pixels[x + y * width] := index;
-      End;
-
-      { unlock surface }
-      surface.unlock;
-
-      { copy to console }
-      surface.copy(console);
-
-      { update console }
-      console.update;
-    End;
-    console.close;
-    console.Free;
-    surface.Free;
-  Except
-    On error : TPTCError Do
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+  palette: TPTCPalette = nil;
+  data: array [0..255] of Uint32;
+  pixels: PUint8;
+  width, height: Integer;
+  i: Integer;
+  x, y, index: Integer;
+begin
+  try
+    try
+      { create console }
+      console := TPTCConsole.Create;
+
+      { create format }
+      format := TPTCFormat.Create(8);
+
+      { open console }
+      console.open('Palette example', format);
+
+      { create surface }
+      surface := TPTCSurface.Create(console.width, console.height, format);
+
+      { create palette }
+      palette := TPTCPalette.Create;
+
+      { generate palette }
+      for i := 0 to 255 do
+        data[i] := i;
+
+      { load palette data }
+      palette.load(data);
+
+      { set console palette }
+      console.palette(palette);
+
+      { set surface palette }
+      surface.palette(palette);
+
+      { loop until a key is pressed }
+      while not console.KeyPressed do
+      begin
+        { lock surface }
+        pixels := surface.lock;
+
+        try
+          { get surface dimensions }
+          width := surface.width;
+          height := surface.height;
+
+          { draw random pixels }
+          for i := 1 to 100 do
+          begin
+            { get random position }
+            x := Random(width);
+            y := Random(height);
+
+            { get random color index }
+            index := Random(256);
+
+            { draw color [index] at position [x,y] }
+            pixels[x + y * width] := index;
+          end;
+        finally
+          { unlock surface }
+          surface.unlock;
+        end;
+
+        { copy to console }
+        surface.copy(console);
+
+        { update console }
+        console.update;
+      end;
+    finally
+      console.close;
+      console.Free;
+      surface.Free;
+      palette.Free;
+      format.Free;
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/pixel.pp

@@ -8,45 +8,39 @@ Ported to FPC by Nikolay Nikolov ([email protected])
  This source code is licensed under the GNU GPL
 }
 
-Program PixelExample;
+program PixelExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Procedure putpixel(surface : TPTCSurface; x, y : Integer; r, g, b : char8);
-
-Var
-  pixels : Pint32;
-  color : int32;
-
-Begin
+procedure putpixel(surface: TPTCSurface; x, y: Integer; r, g, b: Uint8);
+var
+  pixels: PUint32;
+  color: Uint32;
+begin
   { lock surface }
   pixels := surface.lock;
-  Try
+  try
     { pack the color integer from r,g,b components }
-    color := (r Shl 16) Or (g Shl 8) Or b;
+    color := (r shl 16) or (g shl 8) or b;
 
     { plot the pixel on the surface }
     pixels[x + y * surface.width] := color;
-  Finally
+  finally
     { unlock surface }
     surface.unlock;
-  End;
-End;
-
-Var
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  format : TPTCFormat;
-
-Begin
-  format := Nil;
-  surface := Nil;
-  console := Nil;
-  Try
-    Try
+  end;
+end;
+
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+begin
+  try
+    try
       { create console }
       console := TPTCConsole.Create;
 
@@ -60,7 +54,7 @@ Begin
       surface := TPTCSurface.Create(console.width, console.height, format);
 
       { plot a white pixel in the middle of the surface }
-      putpixel(surface, surface.width Div 2, surface.height Div 2, 255, 255, 255);
+      putpixel(surface, surface.width div 2, surface.height div 2, 255, 255, 255);
 
       { copy to console }
       surface.copy(console);
@@ -70,15 +64,15 @@ Begin
 
       { read key }
       console.ReadKey;
-    Finally
+    finally
       console.close;
       console.Free;
       surface.Free;
       format.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/random.pp

@@ -3,33 +3,29 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Random example for OpenPTC 1.0 C++ Implementation
+ Random example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program RandomExample;
+program RandomExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Var
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  format : TPTCFormat;
-  pixels : Pint32;
-  width, height : Integer;
-  i : Integer;
-  x, y, r, g, b : Integer;
-
-Begin
-  format := Nil;
-  surface := Nil;
-  console := Nil;
-  Try
-    Try
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+  pixels: PUint32;
+  width, height: Integer;
+  i: Integer;
+  x, y, r, g, b: Integer;
+begin
+  try
+    try
       { create console }
       console := TPTCConsole.Create;
 
@@ -43,50 +39,50 @@ Begin
       surface := TPTCSurface.Create(console.width, console.height, format);
 
       { loop until a key is pressed }
-      While Not console.KeyPressed Do
-      Begin
+      while not console.KeyPressed do
+      begin
         { lock surface }
         pixels := surface.lock;
-        Try
+        try
           { get surface dimensions }
           width := surface.width;
           height := surface.height;
 
           { draw random pixels }
-          For i := 1 To 100 Do
-          Begin
+          for i := 1 to 100 do
+          begin
             { get random position }
-	    x := Random(width);
-	    y := Random(height);
+            x := Random(width);
+            y := Random(height);
 
             { get random color }
-	    r := Random(256);
-	    g := Random(256);
-	    b := Random(256);
+            r := Random(256);
+            g := Random(256);
+            b := Random(256);
 
             { draw color [r,g,b] at position [x,y] }
-	    pixels[x + y * width] := (r Shl 16) + (g Shl 8) + b;
-          End;
-        Finally
+            pixels[x + y * width] := (r shl 16) + (g shl 8) + b;
+          end;
+        finally
           { unlock surface }
           surface.unlock;
-	End;
+        end;
 
         { copy to console }
         surface.copy(console);
 
         { update console }
         console.update;
-      End;
-    Finally
+      end;
+    finally
       console.close;
       console.Free;
       surface.Free;
       format.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/save.pp

@@ -3,92 +3,93 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Save example for OpenPTC 1.0 C++ Implementation
+ Save example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program SaveExample;
+program SaveExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc, Math;
 
-Procedure save(surface : TPTCSurface; filename : String);
-
-Const
+procedure save(surface: TPTCSurface; filename: string);
+var
+  F: File;
+  width, height: Integer;
+  size: Integer;
+  y: Integer;
+  pixels: PUint8 = nil;
+  format: TPTCFormat = nil;
+  palette: TPTCPalette = nil;
   { generate the header for a true color targa image }
-  header : Array[0..17] Of char8 =
+  header: array [0..17] of Uint8 =
     (0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
-
-Var
-  F : File;
-  width, height : Integer;
-  size : Integer;
-  y : Integer;
-  pixels : Pchar8;
-  format : TPTCFormat;
-  palette : TPTCPalette;
-
-Begin
+begin
   { open image file for writing }
-  ASSign(F, filename);
+  AssignFile(F, filename);
   Rewrite(F, 1);
 
-  { get surface dimensions }
-  width := surface.width;
-  height := surface.height;
-
-  { set targa image width }
-  header[12] := width And $FF;
-  header[13] := width Shr 8;
-
-  { set targa image height }
-  header[14] := height And $FF;
-  header[15] := height Shr 8;
+  try
+    { get surface dimensions }
+    width := surface.width;
+    height := surface.height;
 
-  { set bits per pixel }
-  header[16] := 24;
+    { set targa image width }
+    header[12] := width and $FF;
+    header[13] := width shr 8;
 
-  { write tga header }
-  BlockWrite(F, header, 18);
+    { set targa image height }
+    header[14] := height and $FF;
+    header[15] := height shr 8;
 
-  { calculate size of image pixels }
-  size := width * height * 3;
+    { set bits per pixel }
+    header[16] := 24;
 
-  { allocate image pixels }
-  pixels := GetMem(size);
+    { write tga header }
+    BlockWrite(F, header, 18);
 
-  format := TPTCFormat.Create(24, $00FF0000, $0000FF00, $000000FF);
-  palette := TPTCPalette.Create;
+    { calculate size of image pixels }
+    size := width * height * 3;
 
-  { save surface to image pixels }
-  surface.save(pixels, width, height, width * 3, format, palette);
+    { allocate image pixels }
+    pixels := GetMem(size);
 
-  palette.Free;
-  format.Free;
+    {$IFDEF FPC_LITTLE_ENDIAN}
+    format := TPTCFormat.Create(24, $00FF0000, $0000FF00, $000000FF);
+    {$ELSE FPC_LITTLE_ENDIAN}
+    format := TPTCFormat.Create(24, $000000FF, $0000FF00, $00FF0000);
+    {$ENDIF FPC_LITTLE_ENDIAN}
+    palette := TPTCPalette.Create;
 
-  { write image pixels one line at a time }
-  For y := height - 1 DownTo 0 Do
-    BlockWrite(F, pixels[width * y * 3], width * 3);
+    { save surface to image pixels }
+    surface.save(pixels, width, height, width * 3, format, palette);
 
-  { free image pixels }
-  FreeMem(pixels);
+    { write image pixels one line at a time }
+    for y := height - 1 DownTo 0 do
+      BlockWrite(F, pixels[width * y * 3], width * 3);
 
-  Close(F);
-End;
+  finally
+    { free image pixels }
+    FreeMem(pixels);
 
-Function calculate(real, imaginary : Single; maximum : Integer) : Integer;
+    palette.Free;
+    format.Free;
 
-Var
-  c_r, c_i : Single;
-  z_r, z_i : Single;
-  z_r_squared, z_i_squared : Single;
-  z_squared_magnitude : Single;
-  count : Integer;
+    CloseFile(F);
+  end;
+end;
 
-Begin
+function calculate(real, imaginary: Single; maximum: Integer): Integer;
+var
+  c_r, c_i: Single;
+  z_r, z_i: Single;
+  z_r_squared, z_i_squared: Single;
+  z_squared_magnitude: Single;
+  count: Integer;
+begin
   { complex number 'c' }
   c_r := real;
   c_i := imaginary;
@@ -102,8 +103,8 @@ Begin
   z_i_squared := 0;
 
   { mandelbrot function iteration loop }
-  For count := 0 To maximum - 1 Do
-  Begin
+  for count := 0 to maximum - 1 do
+  begin
     { square 'z' and add 'c' }
     z_i := 2 * z_r * z_i + c_i;
     z_r := z_r_squared - z_i_squared + c_r;
@@ -116,46 +117,43 @@ Begin
     z_squared_magnitude := z_r_squared + z_i_squared;
 
     { stop iterating if the magnitude of 'z' is greater than two }
-    If z_squared_magnitude > 4 Then
-    Begin
+    if z_squared_magnitude > 4 then
+    begin
       calculate := Count;
-      Exit;
-    End;
-  End;
+      exit;
+    end;
+  end;
 
   { maximum }
   calculate := 0;
-End;
+end;
 
-Procedure mandelbrot(console : TPTCConsole; surface : TPTCSurface;
-		     x1, y1, x2, y2 : Single);
-
-Const
+procedure mandelbrot(console: TPTCConsole; surface: TPTCSurface;
+                     x1, y1, x2, y2: Single);
+const
   { constant values }
   entries = 1024;
   maximum = 1024;
-
-Var
+var
   { fractal color table }
-  table : Array[0..entries - 1] Of int32;
-  i : Integer;
-  f_index : Single;
-  time : Single;
-  intensity : Single;
-  pixels, pixel : Pint32;
-  width, height : Integer;
-  dx, dy : Single;
-  real, imaginary : Single;
-  x, y : Integer;
-  count : Integer;
-  index : Integer;
-  color : int32;
-  area : TPTCArea;
-
-Begin
+  table: array [0..entries - 1] of Uint32;
+  i: Integer;
+  f_index: Single;
+  time: Single;
+  intensity: Single;
+  pixels, pixel: PUint32;
+  width, height: Integer;
+  dx, dy: Single;
+  real, imaginary: Single;
+  x, y: Integer;
+  count: Integer;
+  index: Integer;
+  color: Uint32;
+  area: TPTCArea;
+begin
   { generate fractal color table }
-  For i := 0 To entries - 1 Do
-  Begin
+  for i := 0 to entries - 1 do
+  begin
     { calculate normalized index }
     f_index := i / entries;
 
@@ -170,11 +168,11 @@ Begin
 
     { store intensity as a shade of blue }
     table[i] := Trunc(255 * intensity);
-  End;
+  end;
 
   { lock surface pixels }
   pixels := surface.lock;
-  Try
+  try
     { get surface dimensions }
     width := surface.width;
     height := surface.height;
@@ -190,19 +188,19 @@ Begin
     imaginary := y1;
 
     { iterate down surface y }
-    For y := 0 To height - 1 Do
-    Begin
+    for y := 0 to height - 1 do
+    begin
       { real axis }
       real := x1;
 
-      { iterate across surface x }    
-      For x := 0 To width - 1 Do
-      Begin
+      { iterate across surface x }
+      for x := 0 to width - 1 do
+      begin
         { calculate the mandelbrot interation count }
         count := calculate(real, imaginary, maximum);
 
         { calculate color table index }
-        index := count Mod entries;
+        index := count mod entries;
 
         { lookup color from iteration }
         color := table[index];
@@ -215,41 +213,37 @@ Begin
 
         { update real }
         real := real + dx;
-      End;
+      end;
 
       { update imaginary }
       imaginary := imaginary + dy;
 
       { setup line area }
       area := TPTCArea.Create(0, y, width, y + 1);
-      Try
+      try
         { copy surface area to console }
         surface.copy(console, area, area);
-      Finally
+      finally
         area.Free;
-      End;
+      end;
 
       { update console area }
       console.update;
-    End;
-  Finally
+    end;
+  finally
     { unlock surface }
     surface.unlock;
-  End;
-End;
-
-Var
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  format : TPTCFormat;
-  x1, y1, x2, y2 : Single;
-
-Begin
-  format := Nil;
-  surface := Nil;
-  console := Nil;
-  Try
-    Try
+  end;
+end;
+
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+  x1, y1, x2, y2: Single;
+begin
+  try
+    try
       { create console }
       console := TPTCConsole.Create;
 
@@ -276,15 +270,15 @@ Begin
 
       { read key }
       console.ReadKey;
-    Finally
+    finally
       console.close;
       console.Free;
       surface.Free;
       format.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/stretch.pp

@@ -3,86 +3,85 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Stretch example for OpenPTC 1.0 C++ Implementation
+ Stretch example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program StretchExample;
+program StretchExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Procedure load(surface : TPTCSurface; filename : String);
-
-Var
-  F : File;
-  width, height : Integer;
-  pixels : PByte;
-  y : Integer;
-  tmp : TPTCFormat;
-  tmp2 : TPTCPalette;
-
-Begin
+procedure load(surface: TPTCSurface; filename: String);
+var
+  F: File;
+  width, height: Integer;
+  pixels: PByte = nil;
+  y: Integer;
+  tmp: TPTCFormat;
+  tmp2: TPTCPalette;
+begin
   { open image file }
-  ASSign(F, filename);
+  AssignFile(F, filename);
   Reset(F, 1);
 
-  { skip header }
-  Seek(F, 18);
+  try
+    { skip header }
+    Seek(F, 18);
 
-  { get surface dimensions }
-  width := surface.width;
-  height := surface.height;
+    { get surface dimensions }
+    width := surface.width;
+    height := surface.height;
+
+    { allocate image pixels }
+    pixels := GetMem(width * height * 3);
 
-  { allocate image pixels }
-  pixels := GetMem(width * height * 3);
-  Try
     { read image pixels one line at a time }
-    For y := height - 1 DownTo 0 Do
+    for y := height - 1 downto 0 do
       BlockRead(F, pixels[width * y * 3], width * 3);
 
     { load pixels to surface }
+    {$IFDEF FPC_LITTLE_ENDIAN}
     tmp := TPTCFormat.Create(24, $00FF0000, $0000FF00, $000000FF);
-    Try
+    {$ELSE FPC_LITTLE_ENDIAN}
+    tmp := TPTCFormat.Create(24, $000000FF, $0000FF00, $00FF0000);
+    {$ENDIF FPC_LITTLE_ENDIAN}
+    try
       tmp2 := TPTCPalette.Create;
-      Try
+      try
         surface.load(pixels, width, height, width * 3, tmp, tmp2);
-      Finally
+      finally
         tmp2.Free;
-      End;
-    Finally
+      end;
+    finally
       tmp.Free;
-    End;
-  Finally
+    end;
+  finally
     { free image pixels }
     FreeMem(pixels);
-  End;
-End;
-
-Var
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  image : TPTCSurface;
-  format : TPTCFormat;
-  timer : TPTCTimer;
-  area : TPTCArea;
-  color : TPTCColor;
-  time : Double;
-  zoom : Single;
-  x, y, x1, y1, x2, y2, dx, dy : Integer;
-
-Begin
-  format := Nil;
-  color := Nil;
-  timer := Nil;
-  image := Nil;
-  surface := Nil;
-  console := Nil;
-  Try
-    Try
+
+    { close file }
+    CloseFile(F);
+  end;
+end;
+
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  image: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+  timer: TPTCTimer = nil;
+  area: TPTCArea = nil;
+  color: TPTCColor = nil;
+  time: Double;
+  zoom: Single;
+  x, y, x1, y1, x2, y2, dx, dy: Integer;
+begin
+  try
+    try
       { create console }
       console := TPTCConsole.Create;
 
@@ -102,10 +101,10 @@ Begin
       load(image, 'stretch.tga');
 
       { setup stretching parameters }
-      x := surface.width Div 2;
-      y := surface.height Div 2;
-      dx := surface.width Div 2;
-      dy := surface.height Div 3;
+      x := surface.width div 2;
+      y := surface.height div 2;
+      dx := surface.width div 2;
+      dy := surface.height div 3;
 
       { create timer }
       timer := TPTCTimer.Create;
@@ -115,8 +114,8 @@ Begin
       color := TPTCColor.Create(1, 1, 1);
 
       { loop until a key is pressed }
-      While Not console.KeyPressed Do
-      Begin
+      while not console.KeyPressed do
+      begin
         { get current time from timer }
         time := timer.time;
 
@@ -134,7 +133,7 @@ Begin
 
         { setup image copy area }
         area := TPTCArea.Create(x1, y1, x2, y2);
-	Try
+        try
           { copy and stretch image to surface }
           image.copy(surface, image.area, area);
 
@@ -143,11 +142,11 @@ Begin
 
           { update console }
           console.update;
-	Finally
+        finally
           area.Free;
-	End;
-      End;
-    Finally
+        end;
+      end;
+    finally
       console.close;
       console.Free;
       surface.Free;
@@ -155,10 +154,10 @@ Begin
       image.Free;
       color.Free;
       timer.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/texwarp.pp

@@ -8,193 +8,183 @@ Ported to FPC by Nikolay Nikolov ([email protected])
   This source code is licensed under the GNU GPL
 }
 
-Program TexWarp;
+program TexWarp;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Const
+const
 { colour balance values.  change these if you don't like the colouring }
 { of the texture. }
-  red_balance : Uint32 = 2;
-  green_balance : Uint32 = 3;
-  blue_balance : Uint32 = 1;
-
-Procedure blur(s : TPTCSurface);
-
-Var
-  d : PUint8;
-  pitch : Integer;
-  spack, r : Integer;
-
-Begin
+  red_balance: Uint32 = 2;
+  green_balance: Uint32 = 3;
+  blue_balance: Uint32 = 1;
+
+procedure blur(s: TPTCSurface);
+var
+  d: PUint8;
+  pitch: Integer;
+  spack, r: Integer;
+begin
   { lock surface }
   d := s.lock;
-  
-  Try
+
+  try
     pitch := s.pitch;
     spack := (s.height - 1) * pitch;
 
     { first pixel }
-    For r := 0 To 3 Do
-      d[r] := (d[pitch + r] + d[r + 4] + d[spack + r] + d[pitch - 4 + r]) Div 4;
+    for r := 0 to 3 do
+      d[r] := (d[pitch + r] + d[r + 4] + d[spack + r] + d[pitch - 4 + r]) div 4;
 
     { rest of first line }
-    For r := 4 To pitch - 1 Do
-      d[r] := (d[r + pitch] + d[r + 4] + d[r - 4] + d[spack + r]) Div 4;
+    for r := 4 to pitch - 1 do
+      d[r] := (d[r + pitch] + d[r + 4] + d[r - 4] + d[spack + r]) div 4;
 
     { rest of surface except last line }
-    For r := pitch To ((s.height - 1) * pitch) - 1 Do
-      d[r] := (d[r - pitch] + d[r + pitch] + d[r + 4] + d[r - 4]) Div 4;
+    for r := pitch to ((s.height - 1) * pitch) - 1 do
+      d[r] := (d[r - pitch] + d[r + pitch] + d[r + 4] + d[r - 4]) div 4;
 
     { last line except last pixel }
-    For r := (s.height - 1) * pitch To (s.height * s.pitch) - 5 Do
-      d[r] := (d[r - pitch] + d[r + 4] + d[r - 4] + d[r - spack]) Div 4;
+    for r := (s.height - 1) * pitch to (s.height * s.pitch) - 5 do
+      d[r] := (d[r - pitch] + d[r + 4] + d[r - 4] + d[r - spack]) div 4;
 
     { last pixel }
-    For r := (s.height * s.pitch) - 4 To s.height * s.pitch Do
-      d[r] := (d[r - pitch] + d[r - 4] + d[r - spack] + d[r + 4 - pitch]) Div 4;
+    for r := (s.height * s.pitch) - 4 to s.height * s.pitch - 1 do
+      d[r] := (d[r - pitch] + d[r - 4] + d[r - spack] + d[r + 4 - pitch]) div 4;
 
-  Finally
+  finally
     s.unlock;
-  End;
-End;
-
-Procedure generate(surface : TPTCSurface);
-
-Var
-  dest : PUint32;
-  i : Integer;
-  x, y : Integer;
-  d : PUint32;
-  cv : Uint32;
-  r, g, b : Uint8;
-
-Begin
+  end;
+end;
+
+procedure generate(surface: TPTCSurface);
+var
+  dest: PUint32;
+  i: Integer;
+  x, y: Integer;
+  d: PUint32;
+  cv: Uint32;
+  r, g, b: Uint8;
+begin
   { draw random dots all over the surface }
   dest := surface.lock;
-  Try
-    For i := 0 To surface.width * surface.height - 1 Do
-    Begin
+  try
+    for i := 0 to surface.width * surface.height - 1 do
+    begin
       x := Random(surface.width);
       y := Random(surface.height);
       d := dest + (y * surface.width) + x;
-      cv := (Random(100) Shl 16) Or (Random(100) Shl 8) Or Random(100);
+      cv := (Random(100) shl 16) or (Random(100) shl 8) or Random(100);
       d^ := cv;
-    End;
-  Finally
+    end;
+  finally
     surface.unlock;
-  End;
-  
+  end;
+
   { blur the surface }
-  For i := 1 To 5 Do
+  for i := 1 to 5 do
     blur(surface);
-  
+
   { multiply the color values }
   dest := surface.lock;
-  Try
-    For i := 0 To surface.width * surface.height - 1 Do
-    Begin
+  try
+    for i := 0 to surface.width * surface.height - 1 do
+    begin
       cv := dest^;
-      r := (cv Shr 16) And 255;
-      g := (cv Shr 8) And 255;
-      b := cv And 255;
-      r *= red_balance;
-      g *= green_balance;
-      b *= blue_balance;
-      If r > 255 Then
+      r := (cv shr 16) and 255;
+      g := (cv shr 8) and 255;
+      b := cv and 255;
+      r := r * red_balance;
+      g := g * green_balance;
+      b := b * blue_balance;
+      if r > 255 then
         r := 255;
-      If g > 255 Then
+      if g > 255 then
         g := 255;
-      If b > 255 Then
+      if b > 255 then
         b := 255;
-      dest^ := (r Shl 16) Or (g Shl 8) Or b;
+      dest^ := (r shl 16) or (g shl 8) or b;
       Inc(dest);
-    End;
-  Finally
+    end;
+  finally
     surface.unlock;
-  End;
-End;
-
-Procedure grid_map(grid : PUint32; xbase, ybase, xmove, ymove, amp : Single);
-
-Var
-  x, y : Integer;
-  a, b, id : Single;
-
-Begin
+  end;
+end;
+
+procedure grid_map(grid: PUint32; xbase, ybase, xmove, ymove, amp: Single);
+var
+  x, y: Integer;
+  a, b, id: Single;
+begin
   a := 0;
-  For y := 0 To 25 Do
-  Begin
+  for y := 0 to 25 do
+  begin
     b := 0;
-    For x := 0 To 40 Do
-    Begin
+    for x := 0 to 40 do
+    begin
       { it should be noted that there is no scientific basis for }
       { the following three lines :) }
       grid[0] := Uint32(Trunc((xbase * 14 + x*4 + xmove*sin(b)+sin(cos(a)*sin(amp))*15) * 65536));
       grid[1] := Uint32(Trunc((ybase * 31 + y*3 + ymove*cos(b)*sin(sin(a)*cos(amp))*30) * 65536));
       id := (cos(xbase) + sin(ybase) + cos(a*xmove*0.17) + sin(b*ymove*0.11)) * amp * 23;
-      If id < -127 Then
+      if id < -127 then
         grid[2] := 0
-      Else
-        If id > 127 Then
-	  grid[2] := 255 Shl 16
-	Else
-	  grid[2] := (128 Shl 16) + Trunc(id * 65536.0);
-      grid += 3;
-      b += pi / 30;
-    End;
-    a += pi / 34;
-  End;
-End;
-
-Procedure make_light_table(lighttable : PUint8);
-
-Var
-  i, j : Integer;
-  tv : Integer;
-
-Begin
-  For i := 0 To 255 Do
-    For j := 0 To 255 Do
-    Begin
+      else
+        if id > 127 then
+          grid[2] := 255 shl 16
+        else
+          grid[2] := (128 shl 16) + Trunc(id * 65536.0);
+      Inc(grid, 3);
+      b := b + pi / 30;
+    end;
+    a := a + pi / 34;
+  end;
+end;
+
+procedure make_light_table(lighttable: PUint8);
+var
+  i, j: Integer;
+  tv: Integer;
+begin
+  for i := 0 to 255 do
+    for j := 0 to 255 do
+    begin
       { light table goes from 0 to i*2. }
-      tv := (i * j) Div 128;
-      If tv > 255 Then
+      tv := (i * j) div 128;
+      if tv > 255 then
         tv := 255;
       lighttable[(j * 256) + i] := tv;
-    End;
-End;
+    end;
+end;
 
 { if you want to see how to do this properly, look at the tunnel3d demo. }
 { (not included in this distribution :) }
-Procedure texture_warp(dest, grid, texture : PUint32; lighttable : PUint8);
-
-Var
-  utl, utr, ubl, ubr : Integer;
-  vtl, vtr, vbl, vbr : Integer;
-  itl, itr, ibl, ibr : Integer;
-  dudx, dvdx, didx, dudy, dvdy, didy, ddudy, ddvdy, ddidy : Integer;
-  dudx2, dvdx2, didx2 : Integer;
-  bx, by, px, py : Integer;
-  uc, vc, ic, ucx, vcx, icx : Integer;
-  
-  edi : Uint32;
-  texel : Uint32;
-  
-  cbp, dp : PUint32;
-  dpix : Uint32;
-  
-  ltp : PUint8;
-
-Begin
+procedure texture_warp(dest, grid, texture: PUint32; lighttable: PUint8);
+var
+  utl, utr, ubl, ubr: Integer;
+  vtl, vtr, vbl, vbr: Integer;
+  itl, itr, ibl, ibr: Integer;
+  dudx, dvdx, didx, dudy, dvdy, didy, ddudy, ddvdy, ddidy: Integer;
+  dudx2, dvdx2, didx2: Integer;
+  bx, by, px, py: Integer;
+  uc, vc, ic, ucx, vcx, icx: Integer;
+
+  edi: Uint32;
+  texel: Uint32;
+
+  cbp, dp: PUint32;
+  dpix: Uint32;
+
+  ltp: PUint8;
+begin
   cbp := grid;
-  For by := 0 To 24 Do
-  Begin
-    For bx := 0 To 39 Do
-    Begin
+  for by := 0 to 24 do
+  begin
+    for bx := 0 to 39 do
+    begin
       utl := Integer(cbp^);
       vtl := Integer((cbp + 1)^);
       itl := Integer((cbp + 2)^);
@@ -207,87 +197,81 @@ Begin
       ubr := Integer((cbp + (42 * 3))^);
       vbr := Integer((cbp + (42 * 3) + 1)^);
       ibr := Integer((cbp + (42 * 3) + 2)^);
-      dudx := (utr - utl) Div 8;
-      dvdx := (vtr - vtl) Div 8;
-      didx := (itr - itl) Div 8;
-      dudx2 := (ubr - ubl) Div 8;
-      dvdx2 := (vbr - vbl) Div 8;
-      didx2 := (ibr - ibl) Div 8;
-      dudy := (ubl - utl) Div 8;
-      dvdy := (vbl - vtl) Div 8;
-      didy := (ibl - itl) Div 8;
-      ddudy := (dudx2 - dudx) Div 8;
-      ddvdy := (dvdx2 - dvdx) Div 8;
-      ddidy := (didx2 - didx) Div 8;
+      dudx := (utr - utl) div 8;
+      dvdx := (vtr - vtl) div 8;
+      didx := (itr - itl) div 8;
+      dudx2 := (ubr - ubl) div 8;
+      dvdx2 := (vbr - vbl) div 8;
+      didx2 := (ibr - ibl) div 8;
+      dudy := (ubl - utl) div 8;
+      dvdy := (vbl - vtl) div 8;
+      didy := (ibl - itl) div 8;
+      ddudy := (dudx2 - dudx) div 8;
+      ddvdy := (dvdx2 - dvdx) div 8;
+      ddidy := (didx2 - didx) div 8;
       uc := utl;
       vc := vtl;
       ic := itl;
-      For py := 0 To 7 Do
-      Begin
+      for py := 0 to 7 do
+      begin
         ucx := uc;
-	vcx := vc;
-	icx := ic;
-	dp := dest + (((by * 8 + py)*320) + (bx * 8));
-	For px := 0 To 7 Do
-	Begin
+        vcx := vc;
+        icx := ic;
+        dp := dest + (((by * 8 + py)*320) + (bx * 8));
+        for px := 0 to 7 do
+        begin
 
           { get light table pointer for current intensity }
-	  ltp := lighttable + ((icx And $FF0000) Shr 8);
+          ltp := lighttable + ((icx and $FF0000) shr 8);
 
           { get texel }
-	  edi := ((ucx And $FF0000) Shr 16) + ((vcx And $FF0000) Shr 8);
-	  texel := texture[edi];
-	  
+          edi := ((ucx and $FF0000) shr 16) + ((vcx and $FF0000) shr 8);
+          texel := texture[edi];
+
           { calculate actual colour }
-	  dpix := ltp[(texel Shr 16) And 255];
-	  dpix := dpix Shl 8;
-	  dpix := dpix Or ltp[(texel Shr 8) And 255];
-	  dpix := dpix Shl 8;
-	  dpix := dpix Or ltp[texel And 255];
-	  
-	  dp^ := dpix;
-	  Inc(dp);
-	  
-	  ucx += dudx;
-	  vcx += dvdx;
-	  icx += didx;
-	End;
-	uc += dudy;
-	vc += dvdy;
-	ic += didy;
-	dudx += ddudy;
-	dvdx += ddvdy;
-	didx += ddidy;
-      End;
-      cbp += 3;
-    End;
-    cbp += 3;
-  End;
-End;
-
-Var
-  format : TPTCFormat;
-  texture : TPTCSurface;
-  surface : TPTCSurface;
-  console : TPTCConsole;
-  lighttable : PUint8;
+          dpix := ltp[(texel shr 16) and 255];
+          dpix := dpix shl 8;
+          dpix := dpix or ltp[(texel shr 8) and 255];
+          dpix := dpix shl 8;
+          dpix := dpix or ltp[texel and 255];
+
+          dp^ := dpix;
+          Inc(dp);
+
+          Inc(ucx, dudx);
+          Inc(vcx, dvdx);
+          Inc(icx, didx);
+        end;
+        Inc(uc, dudy);
+        Inc(vc, dvdy);
+        Inc(ic, didy);
+        Inc(dudx, ddudy);
+        Inc(dvdx, ddvdy);
+        Inc(didx, ddidy);
+      end;
+      Inc(cbp, 3);
+    end;
+    Inc(cbp, 3);
+  end;
+end;
+
+var
+  format: TPTCFormat = nil;
+  texture: TPTCSurface = nil;
+  surface: TPTCSurface = nil;
+  console: TPTCConsole = nil;
+  lighttable: PUint8 = nil;
   { texture grid }
-  grid : Array[0..41*26*3-1] Of Uint32;
-  xbase, ybase, xmove, ymove, amp, dct, dxb, dyb, dxm, dym, sa : Single;
-  
-  p1, p2 : PUint32;
-
-Begin
-  format := Nil;
-  texture := Nil;
-  surface := Nil;
-  console := Nil;
-  lighttable := Nil;
-  Try
-    Try
+  grid: array [0..41*26*3-1] of Uint32;
+  xbase, ybase, xmove, ymove, amp, dct, dxb, dyb, dxm, dym, sa: Single;
+
+  p1, p2: PUint32;
+begin
+  try
+    try
       { create format }
       format := TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF);
-    
+
       { create texture surface }
       texture := TPTCSurface.Create(256, 256, format);
 
@@ -318,79 +302,78 @@ Begin
       dyb := -0.019;
       dxm := 0.015;
       dym := -0.0083;
-    
+
       { main loop }
-      While Not console.KeyPressed Do
-      Begin
-    
+      while not console.KeyPressed do
+      begin
+
         { create texture mapping grid }
         grid_map(grid, xbase, ybase, xmove, ymove*3, amp);
 
         p1 := surface.lock;
-	Try
-	  p2 := texture.lock;
-	  Try
+        try
+          p2 := texture.lock;
+          try
             { map texture to drawing surface }
             texture_warp(p1, grid, p2, lighttable);
-	  Finally
+          finally
             texture.unlock;
-	  End;
-	Finally
+          end;
+        finally
           surface.unlock;
-	End;
+        end;
 
         { copy surface to console }
         surface.copy(console);
 
         { update console }
         console.update;
-      
+
         { move control values (limit them so it doesn't go too far) }
-        xbase += dxb;
-        If xbase > pi Then
+        xbase := xbase + dxb;
+        if xbase > pi then
           dxb := -dxb;
-        If xbase < (-pi) Then
+        if xbase < (-pi) then
           dxb := -dxb;
-      
-        ybase += dyb;
-        If ybase > pi Then
+
+        ybase := ybase + dyb;
+        if ybase > pi then
           dyb := -dyb;
-        If ybase < (-pi) Then
+        if ybase < (-pi) then
           dyb := -dyb;
-      
-        xmove += dxm;
-        If xmove > pi Then
+
+        xmove := xmove + dxm;
+        if xmove > pi then
           dxm := -dxm;
-        If xmove < (-pi) Then
+        if xmove < (-pi) then
           dxm := -dxm;
-      
-        ymove += dym;
-        If ymove > pi Then
+
+        ymove := ymove + dym;
+        if ymove > pi then
           dym := -dym;
-        If ymove < (-pi) Then
+        if ymove < (-pi) then
           dym := -dym;
-      
-        amp += dct;
+
+        amp := amp + dct;
         sa := sin(amp);
-        If (sa > -0.0001) And (sa < 0.0001) Then
-        Begin
-          If amp > 8.457547 Then
-	    dct := -dct;
-	  If amp < -5.365735 Then
-	    dct := -dct;
-        End;
-      End;
-    Finally
+        if (sa > -0.0001) and (sa < 0.0001) then
+        begin
+          if amp > 8.457547 then
+            dct := -dct;
+          if amp < -5.365735 then
+            dct := -dct;
+        end;
+      end;
+    finally
       console.close;
       console.Free;
       surface.Free;
       texture.Free;
       format.Free;
-      If assigned(lighttable) Then
-        FreeMem(lighttable);
-    End;
-  Except
-    On e : TPTCError Do
+      FreeMem(lighttable);
+    end;
+  except
+    on e: TPTCError do
       e.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/timer.pp

@@ -3,36 +3,31 @@ Ported to FPC by Nikolay Nikolov ([email protected])
 }
 
 {
- Timer example for OpenPTC 1.0 C++ Implementation
+ Timer example for OpenPTC 1.0 C++ implementation
  Copyright (c) Glenn Fiedler ([email protected])
  This source code is in the public domain
 }
 
-Program TimerExample;
+program TimerExample;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc;
 
-Var
-  console : TPTCConsole;
-  format : TPTCFormat;
-  surface : TPTCSurface;
-  timer : TPTCTimer;
-  time, t : Double;
-  pixels : PDWord;
-  width, height : Integer;
-  repeats, center, magnitude, intensity, sx : Single;
-  x, y : Integer;
-
-Begin
-  timer := Nil;
-  format := Nil;
-  surface := Nil;
-  console := Nil;
-  Try
-    Try
+var
+  console: TPTCConsole = nil;
+  format: TPTCFormat = nil;
+  surface: TPTCSurface = nil;
+  timer: TPTCTimer = nil;
+  time, t: Double;
+  pixels: PDWord;
+  width, height: Integer;
+  repeats, center, magnitude, intensity, sx: Single;
+  x, y: Integer;
+begin
+  try
+    try
       { create console }
       console := TPTCConsole.Create;
 
@@ -52,8 +47,8 @@ Begin
       timer.start;
 
       { loop until a key is pressed }
-      While Not console.KeyPressed Do
-      Begin
+      while not console.KeyPressed do
+      begin
         { get current time from timer }
         time := timer.time;
 
@@ -62,7 +57,7 @@ Begin
 
         { lock surface }
         pixels := surface.lock;
-        Try
+        try
           { get surface dimensions }
           width := surface.width;
           height := surface.height;
@@ -73,44 +68,44 @@ Begin
           magnitude := height / 3;
 
           { render a sine curve }
-          For x := 0 To width - 1 Do
-          Begin
+          for x := 0 to width - 1 do
+          begin
             { rescale 'x' in the range [0,2*pi] }
-	    sx := x / width * 2 * pi;
+            sx := x / width * 2 * pi;
 
             { calculate time at current position }
-	    t := time + sx * repeats;
+            t := time + sx * repeats;
 
             { lookup sine intensity at time 't' }
-	    intensity := sin(t);
+            intensity := sin(t);
 
             { convert intensity to a y position on the surface }
-	    y := Trunc(center + intensity * magnitude);
+            y := Trunc(center + intensity * magnitude);
 
             { plot pixel on sine curve }
-	    pixels[x + y * width] := $000000FF;
-          End;
-        Finally
+            pixels[x + y * width] := $000000FF;
+          end;
+        finally
           { unlock surface }
           surface.unlock;
-	End;
+        end;
 
         { copy to console }
         surface.copy(console);
 
         { update console }
         console.update;
-      End;
-    Finally
+      end;
+    finally
       timer.Free;
       surface.Free;
       console.close;
       console.Free;
       format.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/tunnel.pp

@@ -9,68 +9,59 @@ Ported to FPC by Nikolay Nikolov ([email protected])
  This source code is licensed under the GNU GPL
 }
 
-Program Tunnel;
+program Tunnel;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc, Math;
 
-Type
+type
   { tunnel class }
-  TTunnel = Class(TObject)
-    Public
-    Constructor Create;
-    Destructor Destroy; Override;
-    Procedure setup;
-    Procedure draw(buffer : PUint32; t : Single);
-    Private
+  TTunnel = class
+    public
+    constructor Create;
+    destructor Destroy; override;
+    procedure setup;
+    procedure draw(buffer: PUint32; t: Single);
+    private
     { tunnel data }
-    tunnel : PUint32;
-    texture : PUint8;
-  End;
+    tunnel: PUint32;
+    texture: PUint8;
+  end;
 
-Constructor TTunnel.Create;
-
-Begin
-  tunnel := Nil;
-  texture := Nil;
-  
+constructor TTunnel.Create;
+begin
   { allocate tables }
   tunnel := GetMem(320*200*SizeOf(Uint32));
   texture := GetMem(256*256*2*SizeOf(Uint8));
 
   { setup }
   setup;
-End;
-
-Destructor TTunnel.Destroy;
+end;
 
-Begin
+destructor TTunnel.Destroy;
+begin
   { free tables }
-  If assigned(tunnel) Then
-    FreeMem(tunnel);
-  If assigned(texture) Then
-    FreeMem(texture);
-  
-  Inherited Destroy;
-End;
-
-Procedure TTunnel.setup;
-
-Var
-  index : Integer;
-  x, y : Integer;
-  angle, angle1, angle2, radius, u, v : Double;
-
-Begin
+  FreeMem(tunnel);
+  FreeMem(texture);
+
+  inherited Destroy;
+end;
+
+procedure TTunnel.setup;
+var
+  index: Integer;
+  x, y: Integer;
+  angle, angle1, angle2, radius, u, v: Double;
+begin
   { tunnel index }
   index := 0;
-  
+
   { generate tunnel table }
-  For y := 100 DownTo -99 Do
-    For x := -160 To 159 Do
-    Begin
+  for y := 100 DownTo -99 do
+    for x := -160 to 159 do
+    begin
       { calculate angle from center }
       angle := arctan2(y, x) * 256 / pi / 2;
 
@@ -78,70 +69,63 @@ Begin
       radius := sqrt(x * x + y * y);
 
       { clamp radius to minimum }
-      If radius < 1 Then
-	radius := 1;
+      if radius < 1 then
+        radius := 1;
 
       { texture coordinates }
       u := angle;
       v := 6000 / radius;
 
       { calculate texture index for (u,v) }
-      tunnel[index] := (Trunc(v) And $FF) * 256 + (Trunc(u) And $FF);
+      tunnel[index] := (Trunc(v) and $FF) * 256 + (Trunc(u) and $FF);
       Inc(index);
-    End;
+    end;
 
   { generate blue plasma texture }
   index := 0;
   angle2 := pi * 2/256 * 230;
-  For y := 0 To 256 * 2 - 1 Do
-  Begin
+  for y := 0 to 256 * 2 - 1 do
+  begin
     angle1 := pi * 2/256 * 100;
-    For x := 0 To 256-1 Do
-    Begin
+    for x := 0 to 256-1 do
+    begin
       texture[index] := Trunc(sin(angle1)*80 + sin(angle2)*40 + 128);
       angle1 := angle1 + pi*2/256*3;
       Inc(index);
-    End;
+    end;
     angle2 := angle2 + pi * 2/256 *2;
-  End;
-End;
-
-Procedure TTunnel.draw(buffer : PUint32; t : Single);
-
-Var
-  x, y : Integer;
-  scroll : Uint32;
-  i : Integer;
-
-Begin
+  end;
+end;
+
+procedure TTunnel.draw(buffer: PUint32; t: Single);
+var
+  x, y: Integer;
+  scroll: Uint32;
+  i: Integer;
+begin
   { tunnel control functions }
   x := Trunc(sin(t) * 99.9);
   y := Trunc(t * 200);
 
   { calculate tunnel scroll offset }
-  scroll := ((y And $FF) Shl 8) + (x And $FF);
+  scroll := ((y and $FF) shl 8) + (x and $FF);
 
   { loop through each pixel }
-  For i := 0 To 64000-1 Do
+  for i := 0 to 64000-1 do
     { lookup tunnel texture }
     buffer[i] := texture[tunnel[i] + scroll];
-End;
-
-Var
-  format : TPTCFormat;
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  TheTunnel : TTunnel;
-  time, delta : Single;
-  buffer : PUint32;
-
-Begin
-  format := Nil;
-  surface := Nil;
-  console := Nil;
-  TheTunnel := Nil;
-  Try
-    Try
+end;
+
+var
+  format: TPTCFormat = nil;
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  TheTunnel: TTunnel = nil;
+  time, delta: Single;
+  buffer: PUint32;
+begin
+  try
+    try
       { create format }
       format := TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF);
 
@@ -153,7 +137,7 @@ Begin
 
       { create surface }
       surface := TPTCSurface.Create(320, 200, format);
-    
+
       { create tunnel }
       TheTunnel := TTunnel.Create;
 
@@ -162,17 +146,17 @@ Begin
       delta := 0.03;
 
       { loop until a key is pressed }
-      While Not console.KeyPressed Do
-      Begin
+      while not console.KeyPressed do
+      begin
         { lock surface }
         buffer := surface.lock;
-	Try
+        try
           { draw tunnel }
           TheTunnel.draw(buffer, time);
-	Finally
+        finally
           { unlock surface }
           surface.unlock;
-	End;
+        end;
 
         { copy to console }
         surface.copy(console);
@@ -181,18 +165,18 @@ Begin
         console.update;
 
         { update time }
-        time += delta;
-      End;
-    Finally
+        time := time + delta;
+      end;
+    finally
       TheTunnel.Free;
       surface.Free;
       console.close;
       console.Free;
       format.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       { report error }
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/examples/tunnel3d.pp

@@ -9,20 +9,20 @@ Ported to FPC by Nikolay Nikolov ([email protected])
  Copyright (c) 1998 Christian Nentwich ([email protected])
  This source code is licensed under the GNU LGPL
 
- And do not just blatantly cut&paste this into your demo :)
+ and do not just blatantly cut&paste this into your demo :)
 }
 
-Program Tunnel3D;
+program Tunnel3D;
 
 {$MODE objfpc}
 
-Uses
+uses
   ptc, Math;
 
-Type
+type
   PVector = ^TVector;
-  TVector = Array[0..2] Of Single;      { X,Y,Z }
-  TMatrix = Array[0..3, 0..3] Of Single;{ FIRST  = COLUMN
+  TVector = array [0..2] of Single;      { X,Y,Z }
+  TMatrix = array [0..3, 0..3] of Single;{ FIRST  = COLUMN
                                           SECOND = ROW
 
                                           [0, 0]  [1, 0]  [2, 0]
@@ -31,116 +31,108 @@ Type
   (I know the matrices are the wrong way round, so what, the code is quite
   old :) }
 
-  TRayTunnel = Class(TObject)
-  Private
-    tunneltex : PUint8;                      { Texture }
-    pal : PUint8;                            { Original palette }
-    lookup : PUint32;                         { Lookup table for lighting }
+  TRayTunnel = class
+  private
+    tunneltex: PUint8;                      { Texture }
+    tunneltex_orig: PUint8;                 { Original start of texture memory block }
+    pal: PUint8;                            { Original palette }
+    lookup: PUint32;                         { Lookup table for lighting }
 
-    sintab, costab : PSingle;                { Take a guess }
+    sintab, costab: PSingle;                { Take a guess }
 
-    u_array, v_array, l_array : PInteger;    { Raytraced coordinates and light }
-    norms : PVector;
+    u_array, v_array, l_array: PInteger;    { Raytraced coordinates and light }
+    norms: PVector;
 
-    radius, radius_sqr : Single;
-    rot : TMatrix;
+    radius, radius_sqr: Single;
+    rot: TMatrix;
 
-    pos, light : TVector;                    { Position in the tunnel, pos of }
-    xa, ya, za : Integer;                    { lightsource, angles }
+    pos, light: TVector;                    { Position in the tunnel, pos of }
+    xa, ya, za: Integer;                    { lightsource, angles }
 
-    lightstatus : Boolean;                   { Following the viewer ? }
+    lightstatus: Boolean;                   { Following the viewer ? }
 
-  Public
-    Constructor Create(rad : Single);        { Constructor takes the radius }
-    Destructor Destroy; Override;
+  public
+    constructor Create(rad: Single);        { constructor takes the radius }
+    destructor Destroy; override;
 
-    Procedure load_texture;
+    procedure load_texture;
 
-    Procedure tilt(x, y, z : Integer);              { Rotate relative }
-    Procedure tilt(x, y, z : Integer; abs : Uint8); { Absolute }
+    procedure tilt(x, y, z: Integer);              { Rotate relative }
+    procedure tilt(x, y, z: Integer; abs: Uint8); { Absolute }
 
-    Procedure move(dx, dy, dz : Single);            { Relative move }
-    Procedure move(x, y, z : Single; abs : Uint8);  { Absolute }
+    procedure move(dx, dy, dz: Single);            { Relative move }
+    procedure move(x, y, z: Single; abs: Uint8);  { Absolute }
 
-    Procedure movelight(dx, dy, dz : Single);
-    Procedure movelight(x, y, z : Single; abs : Uint8);
+    procedure movelight(dx, dy, dz: Single);
+    procedure movelight(x, y, z: Single; abs: Uint8);
 
-    Procedure locklight(lock : Boolean);    { Make the light follow the viewer }
+    procedure locklight(lock: Boolean);    { Make the light follow the viewer }
 
-    Procedure interpolate;                  { Raytracing }
+    procedure interpolate;                  { Raytracing }
 
-    Procedure draw(dest : PUint32);          { Draw the finished tunnel }
-  End;
+    procedure draw(dest: PUint32);          { Draw the finished tunnel }
+  end;
 
 { VECTOR ROUTINES }
-Procedure vector_normalize(Var v : TVector);
-
-Var
-  length : Single;
-
-Begin
+procedure vector_normalize(var v: TVector);
+var
+  length: Single;
+begin
   length := v[0] * v[0] + v[1] * v[1] + v[2] * v[2];
   length := sqrt(length);
-  If length <> 0 Then
-  Begin
+  if length <> 0 then
+  begin
     v[0] := v[0] / length;
     v[1] := v[1] / length;
     v[2] := v[2] / length;
-  End
-  Else
-  Begin
+  end
+  else
+  begin
     v[0] := 0;
     v[1] := 0;
     v[2] := 0;
-  End;
-End;
-
-Procedure vector_times_matrix(Const v : TVector; Const m : TMatrix;
-                              Var res : TVector);
-
-Var
-  i, j : Integer;
-
-Begin
-  For j := 0 To 2 Do
-  Begin
+  end;
+end;
+
+procedure vector_times_matrix(const v: TVector; const m: TMatrix;
+                              var res: TVector);
+var
+  i, j: Integer;
+begin
+  for j := 0 to 2 do
+  begin
     res[j] := 0;
-    For i := 0 To 2 Do
+    for i := 0 to 2 do
       res[j] := res[j] + (m[j, i] * v[i]);
-  End;
-End;
-
-Procedure matrix_idle(Var m : TMatrix);
+  end;
+end;
 
-Begin
+procedure matrix_idle(var m: TMatrix);
+begin
   FillChar(m, SizeOf(TMatrix), 0);
   m[0, 0] := 1;
   m[1, 1] := 1;
   m[2, 2] := 1;
   m[3, 3] := 1;
-End;
-
-Procedure matrix_times_matrix(Const m1, m2 : TMatrix; Var res : TMatrix);
-
-Var
-  i, j, k : Integer;
-
-Begin
-  For j := 0 To 3 Do
-    For i := 0 To 3 Do
-    Begin
+end;
+
+procedure matrix_times_matrix(const m1, m2: TMatrix; var res: TMatrix);
+var
+  i, j, k: Integer;
+begin
+  for j := 0 to 3 do
+    for i := 0 to 3 do
+    begin
       res[i, j] := 0;
-      For k := 0 To 3 Do
+      for k := 0 to 3 do
         res[i, j] := res[i, j] + (m1[k, j] * m2[i, k]);
-    End;
-End;
-
-Procedure matrix_rotate_x(Var m : TMatrix; angle : Integer; sintab, costab : PSingle);
+    end;
+end;
 
-Var
-  tmp, tmp2 : TMatrix;
-
-Begin
+procedure matrix_rotate_x(var m: TMatrix; angle: Integer; sintab, costab: PSingle);
+var
+  tmp, tmp2: TMatrix;
+begin
   matrix_idle(tmp);
   tmp[1, 1] := costab[angle];
   tmp[2, 1] := sintab[angle];
@@ -148,14 +140,12 @@ Begin
   tmp[2, 2] := costab[angle];
   matrix_times_matrix(tmp, m, tmp2);
   Move(tmp2, m, SizeOf(TMatrix));
-End;
-
-Procedure matrix_rotate_y(Var m : TMatrix; angle : Integer; sintab, costab : PSingle);
+end;
 
-Var
-  tmp, tmp2 : TMatrix;
-
-Begin
+procedure matrix_rotate_y(var m: TMatrix; angle: Integer; sintab, costab: PSingle);
+var
+  tmp, tmp2: TMatrix;
+begin
   matrix_idle(tmp);
   tmp[0, 0] := costab[angle];
   tmp[2, 0] := -sintab[angle];
@@ -163,14 +153,12 @@ Begin
   tmp[2, 2] := costab[angle];
   matrix_times_matrix(tmp, m, tmp2);
   Move(tmp2, m, SizeOf(TMatrix));
-End;
-
-Procedure matrix_rotate_z(Var m : TMatrix; angle : Integer; sintab, costab : PSingle);
-
-Var
-  tmp, tmp2 : TMatrix;
+end;
 
-Begin
+procedure matrix_rotate_z(var m: TMatrix; angle: Integer; sintab, costab: PSingle);
+var
+  tmp, tmp2: TMatrix;
+begin
   matrix_idle(tmp);
   tmp[0, 0] := costab[angle];
   tmp[1, 0] := sintab[angle];
@@ -178,25 +166,14 @@ Begin
   tmp[1, 1] := costab[angle];
   matrix_times_matrix(tmp, m, tmp2);
   Move(tmp2, m, SizeOf(TMatrix));
-End;
-
-Constructor TRayTunnel.Create(rad : Single);
-
-Var
-  x, y : Single;
-  i, j : Integer;
-  tmp : TVector;
-
-Begin
-  tunneltex := Nil;
-  sintab := Nil;
-  costab := Nil;
-  u_array := Nil;
-  v_array := Nil;
-  norms := Nil;
-  lookup := Nil;
-  pal := Nil;
-
+end;
+
+constructor TRayTunnel.Create(rad: Single);
+var
+  x, y: Single;
+  i, j: Integer;
+  tmp: TVector;
+begin
   radius := rad;
   radius_sqr := rad * rad;
 
@@ -210,28 +187,28 @@ Begin
   lookup := GetMem(65 * 256 * SizeOf(Uint32));
   pal := GetMem(768 * SizeOf(Uint8));
 
-  For i := 0 To 1023 Do
-  Begin
+  for i := 0 to 1023 do
+  begin
     sintab[i] := sin(i * pi / 512);
     costab[i] := cos(i * pi / 512);
-  End;
+  end;
 
   { Generate normal vectors }
   y := -100;
-  For j := 0 To 25 Do
-  Begin
+  for j := 0 to 25 do
+  begin
     x := -160;
-    For i := 0 To 40 Do
-    Begin
+    for i := 0 to 40 do
+    begin
       tmp[0] := x;
       tmp[1] := y;
       tmp[2] := 128;
       vector_normalize(tmp);
       norms[j * 64 + i] := tmp;
       x := x + 8;
-    End;
+    end;
     y := y + 8;
-  End;
+  end;
 
   { Reset tunnel and light position and all angles }
   pos[0] := 0; pos[1] := 0; pos[2] := 0;
@@ -243,127 +220,119 @@ Begin
 
   { Normalize light vector to length 1.0 }
   vector_normalize(light);
-End;
-
-Destructor TRayTunnel.Destroy;
-
-Begin
-  If Assigned(tunneltex) Then
-    FreeMem(tunneltex);
-  If Assigned(pal) Then
-    FreeMem(pal);
-  If Assigned(lookup) Then
-    FreeMem(lookup);
-  If Assigned(norms) Then
-    FreeMem(norms);
-  If Assigned(l_array) Then
-    FreeMem(l_array);
-  If Assigned(v_array) Then
-    FreeMem(v_array);
-  If Assigned(u_array) Then
-    FreeMem(u_array);
-  If Assigned(costab) Then
-    FreeMem(costab);
-  If Assigned(sintab) Then
-    FreeMem(sintab);
-End;
-
-Procedure TRayTunnel.load_texture;
-
-Var
-  texfile : File;
-  tmp : PUint8;
-  i, j : Uint32;
-  r, g, b : Uint32;
-  newoffs : Integer;
-
-Begin
-  { Allocate tunnel texture 65536+33 bytes too big }
-
-  If tunneltex <> Nil Then
-  Begin
-    FreeMem(tunneltex);
-    tunneltex := Nil;
-  End;
-  tunneltex := GetMem(2*65536 + 33);
-  tmp := GetMem(65536);
-
-  { Align the texture on a 64k boundary }
-  While (PtrUInt(tunneltex) And $FFFF) <> 0 Do
-    Inc(tunneltex);
-
-  ASSign(texfile, 'tunnel3d.raw');
-  Reset(texfile, 1);
-  BlockRead(texfile, pal^, 768);
-  BlockRead(texfile, tmp^, 65536);
-  Close(texfile);
-
-  { Generate lookup table for lighting (65 because of possible inaccuracies) }
-
-  For j := 0 To 64 Do
-    For i := 0 To 255 Do
-    Begin
-      r := pal[i * 3] Shl 2;
-      g := pal[i * 3 + 1] Shl 2;
-      b := pal[i * 3 + 2] Shl 2;
-      r := (r * j) Shr 6;
-      g := (g * j) Shr 6;
-      b := (b * j) Shr 6;
-      If r > 255 Then
-        r := 255;
-      If g > 255 Then
-        g := 255;
-      If b > 255 Then
-        b := 255;
-      lookup[j * 256 + i] := (r Shl 16) Or (g Shl 8) Or b;
-    End;
-
-  { Arrange texture for cache optimised mapping }
-
-  For j := 0 To 255 Do
-    For i := 0 To 255 Do
-    Begin
-      newoffs := ((i Shl 8) And $F800) + (i And $0007) + ((j Shl 3) And $7F8);
-      (tunneltex + newoffs)^ := (tmp + j * 256 + i)^;
-    End;
-
-  FreeMem(tmp);
-End;
-
-Procedure TRayTunnel.interpolate;
-
-Var
-  ray, intsc, norm, lvec : TVector;
-  x, y, a, b, c, discr, t, res : Single;
-  i, j : Integer;
-
-Begin
-  If lightstatus Then { Lightsource locked to viewpoint }
+end;
+
+destructor TRayTunnel.Destroy;
+begin
+  FreeMem(tunneltex_orig);
+  FreeMem(pal);
+  FreeMem(lookup);
+  FreeMem(norms);
+  FreeMem(l_array);
+  FreeMem(v_array);
+  FreeMem(u_array);
+  FreeMem(costab);
+  FreeMem(sintab);
+end;
+
+procedure TRayTunnel.load_texture;
+var
+  texfile: File;
+  tmp: PUint8 = nil;
+  i, j: Uint32;
+  r, g, b: Uint32;
+  newoffs: Integer;
+begin
+  try
+    { Allocate tunnel texture 65536+33 bytes too big }
+
+    if tunneltex_orig <> nil then
+    begin
+      FreeMem(tunneltex_orig);
+      tunneltex_orig := nil;
+    end;
+    tunneltex_orig := GetMem(2*65536 + 33);
+    tmp := GetMem(65536);
+
+    { Align the texture on a 64k boundary }
+    tunneltex := tunneltex_orig;
+    while (PtrUInt(tunneltex) and $FFFF) <> 0 do
+      Inc(tunneltex);
+
+    AssignFile(texfile, 'tunnel3d.raw');
+    Reset(texfile, 1);
+    try
+      BlockRead(texfile, pal^, 768);
+      BlockRead(texfile, tmp^, 65536);
+    finally
+      CloseFile(texfile);
+    end;
+
+    { Generate lookup table for lighting (65 because of possible inaccuracies) }
+
+    for j := 0 to 64 do
+      for i := 0 to 255 do
+      begin
+        r := pal[i * 3] shl 2;
+        g := pal[i * 3 + 1] shl 2;
+        b := pal[i * 3 + 2] shl 2;
+        r := (r * j) shr 6;
+        g := (g * j) shr 6;
+        b := (b * j) shr 6;
+        if r > 255 then
+          r := 255;
+        if g > 255 then
+          g := 255;
+        if b > 255 then
+          b := 255;
+        lookup[j * 256 + i] := (r shl 16) or (g shl 8) or b;
+      end;
+
+    { Arrange texture for cache optimised mapping }
+
+    for j := 0 to 255 do
+      for i := 0 to 255 do
+      begin
+        newoffs := ((i shl 8) and $F800) + (i and $0007) + ((j shl 3) and $7F8);
+        (tunneltex + newoffs)^ := (tmp + j * 256 + i)^;
+      end;
+  finally
+    FreeMem(tmp);
+  end;
+end;
+
+procedure TRayTunnel.interpolate;
+var
+  ray, intsc, norm, lvec: TVector;
+  x, y, a, b, c, discr, t, res: Single;
+  i, j: Integer;
+begin
+  if lightstatus then { Lightsource locked to viewpoint }
     light := pos;
 
   matrix_idle(rot);
-  matrix_rotate_x(rot, xa And $3FF, sintab, costab);
-  matrix_rotate_y(rot, ya And $3FF, sintab, costab);
-  matrix_rotate_z(rot, za And $3FF, sintab, costab);
+  matrix_rotate_x(rot, xa and $3FF, sintab, costab);
+  matrix_rotate_y(rot, ya and $3FF, sintab, costab);
+  matrix_rotate_z(rot, za and $3FF, sintab, costab);
 
   { Constant factor }
   c := 2 * (pos[0] * pos[0] + pos[1] * pos[1] - radius_sqr);
 
   { Start raytracing }
   y := -100;
-  For j := 0 To 25 Do
-  Begin
+  for j := 0 to 25 do
+  begin
     x := -160;
-    For i := 0 To 40 Do
-    Begin
-      vector_times_matrix(norms[(j Shl 6) + i], rot, ray);
+    for i := 0 to 40 do
+    begin
+      vector_times_matrix(norms[(j shl 6) + i], rot, ray);
 
       a := 2 * (ray[0] * ray[0] + ray[1] * ray[1]);
       b := 2 * (pos[0] * ray[0] + pos[1] * ray[1]);
 
       discr := b * b - a * c;
-      If discr > 0 Then
-      Begin
+      if discr > 0 then
+      begin
         discr := sqrt(discr);
         t := (- b + discr) / a;
 
@@ -373,9 +342,9 @@ Begin
         intsc[2] := pos[2] + t * ray[2];
 
         { Calculate texture index at intersection point (cylindrical mapping) }
-        { Try and adjust the 0.2 to stretch/shrink the texture }
-        u_array[(j Shl 6) + i] := Trunc(intsc[2] * 0.2) Shl 16;
-        v_array[(j Shl 6) + i] := Trunc(abs(arctan2(intsc[1], intsc[0]) * 256 / pi)) Shl 16;
+        { try and adjust the 0.2 to stretch/shrink the texture }
+        u_array[(j shl 6) + i] := Trunc(intsc[2] * 0.2) shl 16;
+        v_array[(j shl 6) + i] := Trunc(abs(arctan2(intsc[1], intsc[0]) * 256 / pi)) shl 16;
 
         { Calculate the dotproduct between the normal vector and the vector }
         { from the intersection point to the lightsource }
@@ -391,172 +360,158 @@ Begin
         res := lvec[0] * norm[0] + lvec[1] * norm[1] + lvec[2] * norm[2];
 
         { Scale the light a bit }
-        res *= res;
-        If res < 0 Then
+        res := Sqr(res);
+        if res < 0 then
           res := 0;
-        If res > 1 Then
+        if res > 1 then
           res := 1;
-        res *= 63;
+        res := res * 63;
 
         { Put it into the light array }
-        l_array[(j Shl 6) + i] := Trunc(res) Shl 16;
-      End
-      Else
-      Begin
-        u_array[(j Shl 6) + i] := 0;
-        v_array[(j Shl 6) + i] := 0;
-        l_array[(j Shl 6) + i] := 0;
-      End;
+        l_array[(j shl 6) + i] := Trunc(res) shl 16;
+      end
+      else
+      begin
+        u_array[(j shl 6) + i] := 0;
+        v_array[(j shl 6) + i] := 0;
+        l_array[(j shl 6) + i] := 0;
+      end;
       x := x + 8;
-    End;
+    end;
     y := y + 8;
-  End;
-End;
-
-Procedure TRayTunnel.draw(dest : PUint32);
-
-Var
-  x, y, lu, lv, ru, rv, liu, liv, riu, riv : Integer;
-  iu, iv, i, j, ll, rl, lil, ril, l, il : Integer;
-  iadr, adr, til_u, til_v, til_iu, til_iv : DWord;
-  bla : Uint8;
-
-Begin
-  For j := 0 To 24 Do
-    For i := 0 To 39 Do
-    Begin
-      iadr := (j Shl 6) + i;
+  end;
+end;
+
+procedure TRayTunnel.draw(dest: PUint32);
+var
+  x, y, lu, lv, ru, rv, liu, liv, riu, riv: Integer;
+  iu, iv, i, j, ll, rl, lil, ril, l, il: Integer;
+  iadr, adr, til_u, til_v, til_iu, til_iv: DWord;
+  bla: Uint8;
+begin
+  for j := 0 to 24 do
+    for i := 0 to 39 do
+    begin
+      iadr := (j shl 6) + i;
 
       { Set up gradients }
       lu := u_array[iadr]; ru := u_array[iadr + 1];
-      liu := (u_array[iadr + 64] - lu) Shr 3;
-      riu := (u_array[iadr + 65] - ru) Shr 3;
+      liu := (u_array[iadr + 64] - lu) shr 3;
+      riu := (u_array[iadr + 65] - ru) shr 3;
 
       lv := v_array[iadr]; rv := v_array[iadr + 1];
-      liv := (v_array[iadr + 64] - lv) Shr 3;
-      riv := (v_array[iadr + 65] - rv) Shr 3;
+      liv := (v_array[iadr + 64] - lv) shr 3;
+      riv := (v_array[iadr + 65] - rv) shr 3;
 
       ll := l_array[iadr]; rl := l_array[iadr + 1];
-      lil := (l_array[iadr + 64] - ll) Shr 3;
-      ril := (l_array[iadr + 65] - rl) Shr 3;
+      lil := (l_array[iadr + 64] - ll) shr 3;
+      ril := (l_array[iadr + 65] - rl) shr 3;
 
-      For y := 0 To 7 Do
-      Begin
-        iu := (ru - lu) Shr 3;
-        iv := (rv - lv) Shr 3;
+      for y := 0 to 7 do
+      begin
+        iu := (ru - lu) shr 3;
+        iv := (rv - lv) shr 3;
         l := ll;
-        il := (rl - ll) Shr 3;
+        il := (rl - ll) shr 3;
 
         { Mess up everything for the sake of cache optimised mapping :) }
-        til_u := DWord(((lu Shl 8) And $F8000000) Or ((lu Shr 1) And $00007FFF) Or (lu And $00070000));
-        til_v := DWord(((lv Shl 3) And $07F80000) Or ((lv Shr 1) And $00007FFF));
-        til_iu := DWord((((iu Shl 8) And $F8000000) Or ((iu Shr 1) And $00007FFF) Or
-                          (iu And $00070000)) Or $07F88000);
-        til_iv := DWord((((iv Shl 3) And $07F80000) Or ((iv Shr 1) And $00007FFF)) Or $F8078000);
+        til_u := DWord(((lu shl 8) and $F8000000) or ((lu shr 1) and $00007FFF) or (lu and $00070000));
+        til_v := DWord(((lv shl 3) and $07F80000) or ((lv shr 1) and $00007FFF));
+        til_iu := DWord((((iu shl 8) and $F8000000) or ((iu shr 1) and $00007FFF) or
+                          (iu and $00070000)) or $07F88000);
+        til_iv := DWord((((iv shl 3) and $07F80000) or ((iv shr 1) and $00007FFF)) or $F8078000);
 
         adr := til_u + til_v;
 
-        For x := 0 To 7 Do
-        Begin
+        for x := 0 to 7 do
+        begin
           { Interpolate texture u,v and light }
-	  Inc(til_u, til_iu);
-	  Inc(til_v, til_iv);
+          Inc(til_u, til_iu);
+          Inc(til_v, til_iv);
           Inc(l, il);
 
-          adr := adr Shr 16;
+          adr := adr shr 16;
 
-          til_u := til_u And DWord($F8077FFF);
-          til_v := til_v And $07F87FFF;
+          til_u := til_u and DWord($F8077FFF);
+          til_v := til_v and $07F87FFF;
 
           bla := (tunneltex + adr)^;
 
           adr := til_u + til_v;
 
           { Look up the light and write to buffer }
-          (dest + ((j Shl 3) + y) * 320 + (I Shl 3) + x)^ := lookup[((l And $3F0000) Shr 8) + bla];
-        End;
+          (dest + ((j shl 3) + y) * 320 + (I shl 3) + x)^ := lookup[((l and $3F0000) shr 8) + bla];
+        end;
 
         Inc(lu, liu); Inc(ru, riu);
         Inc(lv, liv); Inc(rv, riv);
         Inc(ll, lil); Inc(rl, ril);
-      End;
-    End;
-End;
+      end;
+    end;
+end;
 
 { tilt rotates the viewer in the tunnel in a relative / absolute way }
-Procedure TRayTunnel.tilt(x, y, z : Integer);
-
-Begin
-  xa := (xa + x) And $3FF;
-  ya := (ya + y) And $3FF;
-  za := (za + z) And $3FF;
-End;
-
-Procedure TRayTunnel.tilt(x, y, z : Integer; abs : Uint8);
-
-Begin
-  xa := x And $3FF;
-  ya := y And $3FF;
-  za := z And $3FF;
-End;
+procedure TRayTunnel.tilt(x, y, z: Integer);
+begin
+  xa := (xa + x) and $3FF;
+  ya := (ya + y) and $3FF;
+  za := (za + z) and $3FF;
+end;
+
+procedure TRayTunnel.tilt(x, y, z: Integer; abs: Uint8);
+begin
+  xa := x and $3FF;
+  ya := y and $3FF;
+  za := z and $3FF;
+end;
 
 { Relative / absolute move }
-Procedure TRayTunnel.move(dx, dy, dz : Single);
-
-Begin
+procedure TRayTunnel.move(dx, dy, dz: Single);
+begin
   pos[0] := pos[0] + dx;
   pos[1] := pos[1] + dy;
   pos[2] := pos[2] + dz;
-End;
-
-Procedure TRayTunnel.move(x, y, z : Single; abs : Uint8);
+end;
 
-Begin
+procedure TRayTunnel.move(x, y, z: Single; abs: Uint8);
+begin
   pos[0] := x;
   pos[1] := y;
   pos[2] := z;
-End;
+end;
 
 { Relative / absolute move for the lightsource }
-Procedure TRayTunnel.movelight(dx, dy, dz : Single);
-
-Begin
+procedure TRayTunnel.movelight(dx, dy, dz: Single);
+begin
   light[0] := light[0] + dx;
   light[1] := light[1] + dy;
   light[2] := light[2] + dz;
-End;
-
-Procedure TRayTunnel.movelight(x, y, z : Single; abs : Uint8);
+end;
 
-Begin
+procedure TRayTunnel.movelight(x, y, z: Single; abs: Uint8);
+begin
   light[0] := x;
   light[1] := y;
   light[2] := z;
-End;
+end;
 
 { Lock lightsource to the viewer }
-Procedure TRayTunnel.locklight(lock : Boolean);
-
-Begin
+procedure TRayTunnel.locklight(lock: Boolean);
+begin
   lightstatus := lock;
-End;
-
-Var
-  console : TPTCConsole;
-  surface : TPTCSurface;
-  format : TPTCFormat;
-  tunnel : TRayTunnel;
-  posz, phase_x, phase_y : Single;
-  angle_x, angle_y : Integer;
-  buffer : PUint32;
-
-Begin
-  format := Nil;
-  surface := Nil;
-  console := Nil;
-  tunnel := Nil;
-  Try
-    Try
+end;
+
+var
+  console: TPTCConsole = nil;
+  surface: TPTCSurface = nil;
+  format: TPTCFormat = nil;
+  tunnel: TRayTunnel = nil;
+  posz, phase_x, phase_y: Single;
+  angle_x, angle_y: Integer;
+  buffer: PUint32;
+begin
+  try
+    try
       format := TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF);
 
       console := TPTCConsole.create;
@@ -575,19 +530,19 @@ Begin
       posz := 80; phase_x := 0; phase_y := 0;
       angle_x := 6; angle_y := 2;
 
-      While Not console.KeyPressed Do
-      Begin
+      while not console.KeyPressed do
+      begin
         buffer := surface.lock;
-	Try
+        try
           tunnel.interpolate;
 
           { Draw to offscreen buffer }
           tunnel.draw(buffer);
-	Finally
+        finally
           surface.unlock;
-	End;
+        end;
 
-        { And copy to screen }
+        { and copy to screen }
         surface.copy(console);
 
         console.update;
@@ -597,16 +552,16 @@ Begin
 
         phase_x := phase_x + 0.2;
         phase_y := phase_y + 0.1;
-      End;
-    Finally
+      end;
+    finally
       console.close;
       console.Free;
       surface.Free;
       tunnel.Free;
       format.Free;
-    End;
-  Except
-    On error : TPTCError Do
+    end;
+  except
+    on error: TPTCError do
       error.report;
-  End;
-End.
+  end;
+end.

packages/ptc/src/aread.inc

@@ -1,39 +0,0 @@
-{
-    Free Pascal port of the OpenPTC C++ library.
-    Copyright (C) 2001-2006  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
-}
-
-Type
-  TPTCArea=Class(TObject)
-  Private
-    FLeft, FTop, FRight, FBottom : Integer;
-    Function GetWidth : Integer;
-    Function GetHeight : Integer;
-  Public
-    Constructor Create;
-    Constructor Create(ALeft, ATop, ARight, ABottom : Integer);
-    Constructor Create(Const AArea : TPTCArea);
-    Procedure Assign(Const AArea : TPTCArea);
-    Function Equals(Const AArea : TPTCArea) : Boolean;
-    Property Left : Integer Read FLeft;
-    Property Top : Integer Read FTop;
-    Property Right : Integer Read FRight;
-    Property Bottom : Integer Read FBottom;
-    Property Width : Integer Read GetWidth;
-    Property Height : Integer Read GetHeight;
-  End;

packages/ptc/src/baseconsoled.inc

@@ -1,61 +0,0 @@
-{
-    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
-}
-
-Type
-  TPTCBaseConsole=Class(TPTCBaseSurface)
-  Private
-    FReleaseEnabled : Boolean;
-    Function GetPages : Integer; Virtual; Abstract;
-    Function GetName : String; Virtual; Abstract;
-    Function GetTitle : String; Virtual; Abstract;
-    Function GetInformation : String; Virtual; Abstract;
-  Public
-    Constructor Create; Virtual;
-    Procedure Configure(Const AFileName : String); Virtual; Abstract;
-    Function Modes : PPTCMode; Virtual; Abstract;
-    Procedure Open(Const ATitle : String; APages : Integer = 0); Overload; Virtual; Abstract;
-    Procedure Open(Const ATitle : String; Const AFormat : TPTCFormat;
-                   APages : Integer = 0); Overload; Virtual; Abstract;
-    Procedure Open(Const ATitle : String; AWidth, AHeight : Integer;
-                   Const AFormat : TPTCFormat; APages : Integer = 0); Overload; Virtual; Abstract;
-    Procedure Open(Const ATitle : String; Const AMode : TPTCMode;
-                   APages : Integer = 0); Overload; Virtual; Abstract;
-    Procedure Close; Virtual; Abstract;
-    Procedure Flush; Virtual; Abstract;
-    Procedure Finish; Virtual; Abstract;
-    Procedure Update; Virtual; Abstract;
-    Procedure Update(Const AArea : TPTCArea); Virtual; Abstract;
-
-    { event handling }
-    Function NextEvent(Var AEvent : TPTCEvent; AWait : Boolean; Const AEventMask : TPTCEventMask) : Boolean; Virtual; Abstract;
-    Function PeekEvent(AWait : Boolean; Const AEventMask : TPTCEventMask) : TPTCEvent; Virtual; Abstract;
-
-    { key handling }
-    Function KeyPressed : Boolean;
-    Function PeekKey(Var AKey : TPTCKeyEvent) : Boolean;
-    Procedure ReadKey(Var AKey : TPTCKeyEvent);
-    Procedure ReadKey;
-    Property KeyReleaseEnabled : Boolean Read FReleaseEnabled Write FReleaseEnabled;
-
-    Property Pages : Integer Read GetPages;
-    Property Name : String Read GetName;
-    Property Title : String Read GetTitle;
-    Property Information : String Read GetInformation;
-  End;

packages/ptc/src/baseconsolei.inc

@@ -1,88 +0,0 @@
-{
-    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
-}
-
-Constructor TPTCBaseConsole.Create;
-
-Begin
-  FReleaseEnabled := False;
-End;
-
-Function TPTCBaseConsole.KeyPressed : Boolean;
-
-Var
-  k, kpeek : TPTCEvent;
-
-Begin
-  k := Nil;
-  Try
-    Repeat
-      kpeek := PeekEvent(False, [PTCKeyEvent]);
-      If kpeek = Nil Then
-        Exit(False);
-      If FReleaseEnabled Or (kpeek As TPTCKeyEvent).Press Then
-        Exit(True);
-      NextEvent(k, False, [PTCKeyEvent]);
-    Until False;
-  Finally
-    k.Free;
-  End;
-End;
-
-Procedure TPTCBaseConsole.ReadKey(Var AKey : TPTCKeyEvent);
-
-Var
-  ev : TPTCEvent;
-
-Begin
-  ev := AKey;
-  Try
-    Repeat
-      NextEvent(ev, True, [PTCKeyEvent]);
-    Until FReleaseEnabled Or (ev As TPTCKeyEvent).Press;
-  Finally
-    AKey := ev As TPTCKeyEvent;
-  End;
-End;
-
-Function TPTCBaseConsole.PeekKey(Var AKey : TPTCKeyEvent) : Boolean;
-
-Begin
-  If KeyPressed Then
-  Begin
-    ReadKey(AKey);
-    Result := True;
-  End
-  Else
-    Result := False;
-End;
-
-Procedure TPTCBaseConsole.ReadKey;
-
-Var
-  k : TPTCKeyEvent;
-
-Begin
-  k := TPTCKeyEvent.Create;
-  Try
-    ReadKey(k);
-  Finally
-    k.Free;
-  End;
-End;

packages/ptc/src/basesurfaced.inc

@@ -1,67 +0,0 @@
-{
-    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
-}
-
-Type
-  TPTCBaseSurface=Class(TObject)
-  Private
-    Function GetWidth : Integer; Virtual; Abstract;
-    Function GetHeight : Integer; Virtual; Abstract;
-    Function GetPitch : Integer; Virtual; Abstract;
-    Function GetArea : TPTCArea; Virtual; Abstract;
-    Function GetFormat : TPTCFormat; Virtual; Abstract;
-  Public
-    Procedure Copy(Var ASurface : TPTCBaseSurface); Virtual; Abstract;
-    Procedure Copy(Var ASurface : TPTCBaseSurface;
-                   Const ASource, ADestination : TPTCArea); Virtual; Abstract;
-    Function Lock : Pointer; Virtual; Abstract;
-    Procedure Unlock; Virtual; Abstract;
-    Procedure Load(Const APixels : Pointer;
-                   AWidth, AHeight, APitch : Integer;
-                   Const AFormat : TPTCFormat;
-                   Const APalette : TPTCPalette); Virtual; Abstract;
-    Procedure Load(Const APixels : Pointer;
-                   AWidth, AHeight, APitch : Integer;
-                   Const AFormat : TPTCFormat;
-                   Const APalette : TPTCPalette;
-                   Const ASource, ADestination : TPTCArea); Virtual; Abstract;
-    Procedure Save(APixels : Pointer;
-                   AWidth, AHeight, APitch : Integer;
-                   Const AFormat : TPTCFormat;
-                   Const APalette : TPTCPalette); Virtual; Abstract;
-    Procedure Save(APixels : Pointer;
-                   AWidth, AHeight, APitch : Integer;
-                   Const AFormat : TPTCFormat;
-                   Const APalette : TPTCPalette;
-                   Const ASource, ADestination : TPTCArea); Virtual; Abstract;
-    Procedure Clear; Virtual; Abstract;
-    Procedure Clear(Const AColor : TPTCColor); Virtual; Abstract;
-    Procedure Clear(Const AColor : TPTCColor;
-                    Const AArea : TPTCArea); Virtual; Abstract;
-    Procedure Palette(Const APalette : TPTCPalette); Virtual; Abstract;
-    Procedure Clip(Const AArea : TPTCArea); Virtual; Abstract;
-    Function Option(Const AOption : String) : Boolean; Virtual; Abstract;
-    Function Clip : TPTCArea; Virtual; Abstract;
-    Function Palette : TPTCPalette; Virtual; Abstract;
-    Property Width : Integer Read GetWidth;
-    Property Height : Integer Read GetHeight;
-    Property Pitch : Integer Read GetPitch;
-    Property Area : TPTCArea Read GetArea;
-    Property Format : TPTCFormat Read GetFormat;
-  End;

packages/ptc/src/basesurfacei.inc

@@ -1,19 +0,0 @@
-{
-    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
-}

packages/ptc/src/cleard.inc

@@ -1,33 +0,0 @@
-{
-    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
-}
-
-Type
-  TPTCClear=Class(TObject)
-  Private
-    FHandle : THermesHandle;
-    FFormat : TPTCFormat;
-  Public
-    Constructor Create;
-    Destructor Destroy; Override;
-    Procedure Request(Const AFormat : TPTCFormat);
-    Procedure Clear(APixels : Pointer;
-                    AX, AY, AWidth, AHeight, APitch : Integer;
-                    Const AColor : TPTCColor);
-  End;

packages/ptc/src/colord.inc

@@ -1,42 +0,0 @@
-{
-    Free Pascal port of the OpenPTC C++ library.
-    Copyright (C) 2001-2006  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
-}
-
-Type
-  TPTCColor=Class(TObject)
-  Private
-    FIndex : Integer;
-    FRed, FGreen, FBlue, FAlpha : Single;
-    FDirect : Boolean;
-    FIndexed : Boolean;
-  Public
-    Constructor Create;
-    Constructor Create(AIndex : Integer);
-    Constructor Create(ARed, AGreen, ABlue : Single; AAlpha : Single = 1);
-    Constructor Create(Const AColor : TPTCColor);
-    Procedure Assign(Const AColor : TPTCColor);
-    Function Equals(Const AColor : TPTCColor) : Boolean;
-    Property Index : Integer Read FIndex;
-    Property R : Single Read FRed;
-    Property G : Single Read FGreen;
-    Property B : Single Read FBlue;
-    Property A : Single Read FAlpha;
-    Property Direct : Boolean Read FDirect;
-    Property Indexed : Boolean Read FIndexed;
-  End;

packages/ptc/src/consoled.inc

@@ -1,91 +0,0 @@
-{
-    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
-}
-
-Type
-  TPTCConsole=Class(TPTCBaseConsole)
-  Private
-    Function ConsoleCreate(index : Integer) : TPTCBaseConsole;
-    Function ConsoleCreate(Const AName : String) : TPTCBaseConsole;
-    Procedure check;
-    console : TPTCBaseConsole;
-    m_modes : Array[0..1023] Of TPTCMode;
-    hacky_option_console_flag : Boolean;
-  Public
-    Constructor Create; Override;
-    Destructor Destroy; Override;
-    Procedure configure(Const _file : String); Override;
-    Function option(Const _option : String) : Boolean; Override;
-    Function modes : PPTCMode; Override;
-    Procedure open(Const _title : String; _pages : Integer = 0); Overload; Override;
-    Procedure open(Const _title : String; Const _format : TPTCFormat;
-                   _pages : Integer = 0); Overload; Override;
-    Procedure open(Const _title : String; _width, _height : Integer;
-                   Const _format : TPTCFormat; _pages : Integer = 0); Overload; Override;
-    Procedure open(Const _title : String; Const _mode : TPTCMode;
-                   _pages : Integer = 0); Overload; Override;
-
-    Procedure close; Override;
-    Procedure flush; Override;
-    Procedure finish; Override;
-    Procedure update; Override;
-    Procedure update(Const _area : TPTCArea); Override;
-    Procedure copy(Var surface : TPTCBaseSurface); Override;
-    Procedure copy(Var surface : TPTCBaseSurface;
-                   Const source, destination : TPTCArea); Override;
-    Function lock : Pointer; Override;
-    Procedure unlock; Override;
-    Procedure load(Const pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette); Override;
-    Procedure load(Const pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette;
-                   Const source, destination : TPTCArea); Override;
-    Procedure save(pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette); Override;
-    Procedure save(pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette;
-                   Const source, destination : TPTCArea); Override;
-    Procedure clear; Override;
-    Procedure clear(Const color : TPTCColor); Override;
-    Procedure clear(Const color : TPTCColor;
-                    Const _area : TPTCArea); Override;
-    Procedure palette(Const _palette : TPTCPalette); Override;
-    Function Palette : TPTCPalette; Override;
-    Procedure Clip(Const _area : TPTCArea); Override;
-    Function GetWidth : Integer; Override;
-    Function GetHeight : Integer; Override;
-    Function GetPitch : Integer; Override;
-    Function GetPages : Integer; Override;
-    Function GetArea : TPTCArea; Override;
-    Function Clip : TPTCArea; Override;
-    Function GetFormat : TPTCFormat; Override;
-    Function GetName : String; Override;
-    Function GetTitle : String; Override;
-    Function GetInformation : String; Override;
-    Function NextEvent(Var event : TPTCEvent; wait : Boolean; Const EventMask : TPTCEventMask) : Boolean; Override;
-    Function PeekEvent(wait : Boolean; Const EventMask : TPTCEventMask) : TPTCEvent; Override;
-  End;

packages/ptc/src/consolei.inc

@@ -1,754 +0,0 @@
-{
-    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
-}
-
-Const
- {$IFDEF GO32V2}
-  ConsoleTypesNumber = 4;
- {$ENDIF GO32V2}
- {$IFDEF Win32}
-  ConsoleTypesNumber = 2;
- {$ENDIF Win32}
- {$IFDEF WinCE}
-  ConsoleTypesNumber = 2;
- {$ENDIF WinCE}
- {$IFDEF UNIX}
-  ConsoleTypesNumber = 1;
- {$ENDIF UNIX}
-  ConsoleTypes : Array[0..ConsoleTypesNumber - 1] Of
-    Record
-      ConsoleClass : Class Of TPTCBaseConsole;
-      Names : Array[1..2] Of String;
-    End =
-  (
-  {$IFDEF GO32V2}
-   (ConsoleClass : TVESAConsole;      Names : ('VESA', '')),
-   (ConsoleClass : TVGAConsole;       Names : ('VGA', 'Fakemode')),
-   (ConsoleClass : TCGAConsole;       Names : ('CGA', '')),
-   (ConsoleClass : TTEXTFX2Console;   Names : ('TEXTFX2', 'Text'))
-  {$ENDIF GO32V2}
-
-  {$IFDEF Win32}
-   (ConsoleClass : TDirectXConsole;   Names : ('DirectX', '')),
-   (ConsoleClass : TGDIConsole;       Names : ('GDI', ''))
-  {$ENDIF Win32}
-
-  {$IFDEF WinCE}
-   (ConsoleClass : TWinCEGAPIConsole; Names : ('GAPI', '')),
-   (ConsoleClass : TWinCEGDIConsole;  Names : ('GDI', ''))
-  {$ENDIF WinCE}
-
-  {$IFDEF UNIX}
-   (ConsoleClass : TX11Console;       Names : ('X11', ''))
-  {$ENDIF UNIX}
-  );
-
-Constructor TPTCConsole.Create;
-
-Var
-  I : Integer;
-  {$IFDEF UNIX}
-  s : AnsiString;
-  {$ENDIF UNIX}
-
-Begin
-  Inherited Create;
-  console := Nil;
-  hacky_option_console_flag := False;
-  FillChar(m_modes, SizeOf(m_modes), 0);
-  For I := Low(m_modes) To High(m_modes) Do
-    m_modes[I] := TPTCMode.Create;
-
-  {$IFDEF UNIX}
-    configure('/usr/share/ptcpas/ptcpas.conf');
-    s := fpgetenv('HOME');
-    If s = '' Then
-      s := '/';
-    If s[Length(s)] <> '/' Then
-      s := s + '/';
-    s := s + '.ptcpas.conf';
-    configure(s);
-  {$ENDIF UNIX}
-
-  {$IFDEF Win32}
-    configure('ptcpas.cfg');
-  {$ENDIF Win32}
-
-  {$IFDEF GO32V2}
-    configure('ptcpas.cfg');
-  {$ENDIF GO32V2}
-
-  {$IFDEF WinCE}
-  {todo: configure WinCE}
-  {$ENDIF WinCE}
-End;
-
-Destructor TPTCConsole.Destroy;
-
-Var
-  I : Integer;
-
-Begin
-  close;
-  console.Free;
-  For I := Low(m_modes) To High(m_modes) Do
-    m_modes[I].Free;
-  Inherited Destroy;
-End;
-
-Procedure TPTCConsole.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 TPTCConsole.option(Const _option : String) : Boolean;
-
-Begin
-  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;
-
-  If Assigned(console) Then
-    option := console.option(_option)
-  Else
-  Begin
-    console := ConsoleCreate(_option);
-    If Assigned(console) Then
-    Begin
-      hacky_option_console_flag := True;
-      option := True;
-    End
-    Else
-      option := False;
-  End;
-End;
-
-Function TPTCConsole.modes : PPTCMode;
-
-Var
-  _console : TPTCBaseConsole;
-  index, mode : Integer;
-  local : Integer;
-  _modes : PPTCMode;
-  tmp : TPTCMode;
-
-Begin
-  If Assigned(console) Then
-    modes := console.modes
-  Else
-  Begin
-    _console := Nil;
-    index := -1;
-    mode := 0;
-    Try
-      Repeat
-        Inc(index);
-        Try
-          _console := ConsoleCreate(index);
-        Except
-          On TPTCError Do Begin
-            FreeAndNil(_console);
-            Continue;
-          End;
-        End;
-        If _console = Nil Then
-          Break;
-        _modes := _console.modes;
-        local := 0;
-        While _modes[local].valid Do
-        Begin
-          m_modes[mode].Assign(_modes[local]);
-          Inc(local);
-          Inc(mode);
-        End;
-        FreeAndNil(_console);
-      Until False;
-    Finally
-      _console.Free;
-    End;
-    { todo: strip duplicate modes from list? }
-    tmp := TPTCMode.Create;
-    Try
-      m_modes[mode].Assign(tmp);
-    Finally
-      tmp.Free;
-    End;
-    modes := m_modes;
-  End;
-End;
-
-Procedure TPTCConsole.open(Const _title : String; _pages : Integer);{ Overload;}
-
-Var
-  composite, tmp : TPTCError;
-  index : Integer;
-  success : Boolean;
-
-Begin
-  If Assigned(console) Then
-  Begin
-    Try
-      console.open(_title, _pages);
-      Exit;
-    Except
-      On error : TPTCError Do Begin
-        FreeAndNil(console);
-        If hacky_option_console_flag Then
-        Begin
-          hacky_option_console_flag := False;
-          Raise TPTCError.Create('could not open console', error);
-        End;
-      End;
-    End;
-  End;
-  index := -1;
-  composite := TPTCError.Create;
-  success := False;
-  Try
-    Repeat
-      Inc(index);
-      Try
-        console := ConsoleCreate(index);
-        If console = Nil Then
-          Break;
-        console.open(_title, _pages);
-        success := True;
-        Exit;
-      Except
-        On error : TPTCError Do Begin
-          tmp := TPTCError.Create(error.message, composite);
-          Try
-            composite.Assign(tmp);
-          Finally
-            tmp.Free;
-          End;
-          FreeAndNil(console);
-          Continue;
-        End;
-      End;
-    Until False;
-    console := Nil;
-    Raise TPTCError.Create(composite);
-  Finally
-    composite.Free;
-    If Not success Then
-      FreeAndNil(console);
-  End;
-End;
-
-Procedure TPTCConsole.open(Const _title : String; Const _format : TPTCFormat;
-                           _pages : Integer);{ Overload;}
-
-Var
-  composite, tmp : TPTCError;
-  index : Integer;
-  success : Boolean;
-
-Begin
-  If Assigned(console) Then
-  Begin
-    Try
-      console.open(_title, _format, _pages);
-      Exit;
-    Except
-      On error : TPTCError Do Begin
-        FreeAndNil(console);
-        If hacky_option_console_flag Then
-        Begin
-          hacky_option_console_flag := False;
-          Raise TPTCError.Create('could not open console', error);
-        End;
-      End;
-    End;
-  End;
-  index := -1;
-  composite := TPTCError.Create;
-  success := False;
-  Try
-    Repeat
-      Inc(index);
-      Try
-        console := ConsoleCreate(index);
-        If console = Nil Then
-          Break;
-        console.open(_title, _format, _pages);
-        success := True;
-        Exit;
-      Except
-        On error : TPTCError Do Begin
-          tmp := TPTCError.Create(error.message, composite);
-          Try
-            composite.Assign(tmp);
-          Finally
-            tmp.Free;
-          End;
-          FreeAndNil(console);
-          Continue;
-        End;
-      End;
-    Until False;
-    console := Nil;
-    Raise TPTCError.Create(composite);
-  Finally
-    composite.Free;
-    If Not success Then
-      FreeAndNil(console);
-  End;
-End;
-
-Procedure TPTCConsole.open(Const _title : String; _width, _height : Integer;
-                           Const _format : TPTCFormat; _pages : Integer);{ Overload;}
-
-Var
-  composite, tmp : TPTCError;
-  index : Integer;
-  success : Boolean;
-
-Begin
-  If Assigned(console) Then
-  Begin
-    Try
-      console.open(_title, _width, _height, _format, _pages);
-      Exit;
-    Except
-      On error : TPTCError Do Begin
-        FreeAndNil(console);
-        If hacky_option_console_flag Then
-        Begin
-          hacky_option_console_flag := False;
-          Raise TPTCError.Create('could not open console', error);
-        End;
-      End;
-    End;
-  End;
-  index := -1;
-  composite := TPTCError.Create;
-  success := False;
-  Try
-    Repeat
-      Inc(index);
-      Try
-        console := ConsoleCreate(index);
-        If console = Nil Then
-          Break;
-        console.open(_title, _width, _height, _format, _pages);
-        success := True;
-        Exit;
-      Except
-        On error : TPTCError Do Begin
-          tmp := TPTCError.Create(error.message, composite);
-          Try
-            composite.Assign(tmp);
-          Finally
-            tmp.Free;
-          End;
-          FreeAndNil(console);
-          Continue;
-        End;
-      End;
-    Until False;
-    console := Nil;
-    Raise TPTCError.Create(composite);
-  Finally
-    composite.Free;
-    If Not success Then
-      FreeAndNil(console);
-  End;
-End;
-
-Procedure TPTCConsole.open(Const _title : String; Const _mode : TPTCMode;
-                           _pages : Integer);{ Overload;}
-
-Var
-  composite, tmp : TPTCError;
-  index : Integer;
-  success : Boolean;
-
-Begin
-  If Assigned(console) Then
-  Begin
-    Try
-      console.open(_title, _mode, _pages);
-      Exit;
-    Except
-      On error : TPTCError Do Begin
-        FreeAndNil(console);
-        If hacky_option_console_flag Then
-        Begin
-          hacky_option_console_flag := False;
-          Raise TPTCError.Create('could not open console', error);
-        End;
-      End;
-    End;
-  End;
-  index := -1;
-  composite := TPTCError.Create;
-  success := False;
-  Try
-    Repeat
-      Inc(index);
-      Try
-        console := ConsoleCreate(index);
-        If console = Nil Then
-          Break;
-        console.open(_title, _mode, _pages);
-        success := True;
-        Exit;
-      Except
-        On error : TPTCError Do Begin
-          tmp := TPTCError.Create(error.message, composite);
-          Try
-            composite.Assign(tmp);
-          Finally
-            tmp.Free;
-          End;
-          FreeAndNil(console);
-          Continue;
-        End;
-      End;
-    Until False;
-    console := Nil;
-    Raise TPTCError.Create(composite);
-  Finally
-    composite.Free;
-    If Not success Then
-      FreeAndNil(console);
-  End;
-End;
-
-Procedure TPTCConsole.close;
-
-Begin
-  If Assigned(console) Then
-    console.close;
-  hacky_option_console_flag := False;
-End;
-
-Procedure TPTCConsole.flush;
-
-Begin
-  check;
-  console.flush;
-End;
-
-Procedure TPTCConsole.finish;
-
-Begin
-  check;
-  console.finish;
-End;
-
-Procedure TPTCConsole.update;
-
-Begin
-  check;
-  console.update;
-End;
-
-Procedure TPTCConsole.update(Const _area : TPTCArea);
-
-Begin
-  check;
-  console.update(_area);
-End;
-
-Procedure TPTCConsole.copy(Var surface : TPTCBaseSurface);
-
-Begin
-  check;
-  console.copy(surface);
-End;
-
-Procedure TPTCConsole.copy(Var surface : TPTCBaseSurface;
-                           Const source, destination : TPTCArea);
-
-Begin
-  check;
-  console.copy(surface, source, destination);
-End;
-
-Function TPTCConsole.lock : Pointer;
-
-Begin
-  check;
-  lock := console.lock;
-End;
-
-Procedure TPTCConsole.unlock;
-
-Begin
-  check;
-  console.unlock;
-End;
-
-Procedure TPTCConsole.load(Const pixels : Pointer;
-                           _width, _height, _pitch : Integer;
-                           Const _format : TPTCFormat;
-                           Const _palette : TPTCPalette);
-
-Begin
-  check;
-  console.load(pixels, _width, _height, _pitch, _format, _palette);
-End;
-
-Procedure TPTCConsole.load(Const pixels : Pointer;
-                           _width, _height, _pitch : Integer;
-                           Const _format : TPTCFormat;
-                           Const _palette : TPTCPalette;
-                           Const source, destination : TPTCArea);
-
-Begin
-  check;
-  console.load(pixels, _width, _height, _pitch, _format, _palette,
-               source, destination);
-End;
-
-Procedure TPTCConsole.save(pixels : Pointer;
-                           _width, _height, _pitch : Integer;
-                           Const _format : TPTCFormat;
-                           Const _palette : TPTCPalette);
-
-Begin
-  check;
-  console.save(pixels, _width, _height, _pitch, _format, _palette);
-End;
-
-Procedure TPTCConsole.save(pixels : Pointer;
-                           _width, _height, _pitch : Integer;
-                           Const _format : TPTCFormat;
-                           Const _palette : TPTCPalette;
-                           Const source, destination : TPTCArea);
-
-Begin
-  check;
-  console.save(pixels, _width, _height, _pitch, _format, _palette,
-               source, destination);
-End;
-
-Procedure TPTCConsole.clear;
-
-Begin
-  check;
-  console.clear;
-End;
-
-Procedure TPTCConsole.clear(Const color : TPTCColor);
-
-Begin
-  check;
-  console.clear(color);
-End;
-
-Procedure TPTCConsole.clear(Const color : TPTCColor;
-                           Const _area : TPTCArea);
-
-Begin
-  check;
-  console.clear(color, _area);
-End;
-
-Procedure TPTCConsole.palette(Const _palette : TPTCPalette);
-
-Begin
-  check;
-  console.palette(_palette);
-End;
-
-Function TPTCConsole.Palette : TPTCPalette;
-
-Begin
-  check;
-  Result := console.Palette;
-End;
-
-Procedure TPTCConsole.Clip(Const _area : TPTCArea);
-
-Begin
-  check;
-  console.clip(_area);
-End;
-
-Function TPTCConsole.GetWidth : Integer;
-
-Begin
-  check;
-  Result := console.GetWidth;
-End;
-
-Function TPTCConsole.GetHeight : Integer;
-
-Begin
-  check;
-  Result := console.GetHeight;
-End;
-
-Function TPTCConsole.GetPitch : Integer;
-
-Begin
-  check;
-  Result := console.GetPitch;
-End;
-
-Function TPTCConsole.GetPages : Integer;
-
-Begin
-  check;
-  Result := console.GetPages;
-End;
-
-Function TPTCConsole.GetArea : TPTCArea;
-
-Begin
-  check;
-  Result := console.GetArea;
-End;
-
-Function TPTCConsole.Clip : TPTCArea;
-
-Begin
-  check;
-  Result := console.Clip;
-End;
-
-Function TPTCConsole.GetFormat : TPTCFormat;
-
-Begin
-  check;
-  Result := console.GetFormat;
-End;
-
-Function TPTCConsole.GetName : String;
-
-Begin
-  Result := '';
-  If Assigned(console) Then
-    Result := console.GetName
-  Else
-{$IFDEF GO32V2}
-    Result := 'DOS';
-{$ENDIF GO32V2}
-{$IFDEF WIN32}
-    Result := 'Win32';
-{$ENDIF WIN32}
-{$IFDEF LINUX}
-    Result := 'Linux';
-{$ENDIF LINUX}
-End;
-
-Function TPTCConsole.GetTitle : String;
-
-Begin
-  check;
-  Result := console.GetTitle;
-End;
-
-Function TPTCConsole.GetInformation : String;
-
-Begin
-  check;
-  Result := console.GetInformation;
-End;
-
-Function TPTCConsole.NextEvent(Var event : TPTCEvent; wait : Boolean; Const EventMask : TPTCEventMask) : Boolean;
-
-Begin
-  check;
-  Result := console.NextEvent(event, wait, EventMask);
-End;
-
-Function TPTCConsole.PeekEvent(wait : Boolean; Const EventMask : TPTCEventMask) : TPTCEvent;
-
-Begin
-  check;
-  Result := console.PeekEvent(wait, EventMask);
-End;
-
-Function TPTCConsole.ConsoleCreate(index : Integer) : TPTCBaseConsole;
-
-Begin
-  Result := Nil;
-  If (index >= Low(ConsoleTypes)) And (index <= High(ConsoleTypes)) Then
-    Result := ConsoleTypes[index].ConsoleClass.Create;
-
-  If Result <> Nil Then
-    Result.KeyReleaseEnabled := KeyReleaseEnabled;
-End;
-
-Function TPTCConsole.ConsoleCreate(Const AName : String) : TPTCBaseConsole;
-
-Var
-  I, J : Integer;
-
-Begin
-  Result := Nil;
-
-  If AName = '' Then
-    Exit;
-
-  For I := Low(ConsoleTypes) To High(ConsoleTypes) Do
-    For J := Low(ConsoleTypes[I].Names) To High(ConsoleTypes[I].Names) Do
-      If AName = ConsoleTypes[I].Names[J] Then
-      Begin
-        Result := ConsoleTypes[I].ConsoleClass.Create;
-
-        If Result <> Nil Then
-        Begin
-          Result.KeyReleaseEnabled := KeyReleaseEnabled;
-          Exit;
-        End;
-      End;
-End;
-
-Procedure TPTCConsole.check;
-
-Begin
-  { $IFDEF DEBUG}
-  If console = Nil Then
-    Raise TPTCError.Create('console is not open (core)');
-  { $ENDIF DEBUG}
-End;

packages/ptc/src/copyd.inc

@@ -1,37 +0,0 @@
-{
-    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
-}
-
-Type
-  TPTCCopy=Class(TObject)
-  Private
-    Procedure Update;
-    FHandle : THermesHandle;
-    FFlags : LongInt;
-  Public
-    Constructor Create;
-    Destructor Destroy; Override;
-    Procedure Request(Const ASource, ADestination : TPTCFormat);
-    Procedure Palette(Const ASource, ADestination : TPTCPalette);
-    Procedure Copy(Const ASourcePixels : Pointer; ASourceX, ASourceY,
-                   ASourceWidth, ASourceHeight, ASourcePitch : Integer;
-                   ADestinationPixels : Pointer; ADestinationX, ADestinationY,
-                   ADestinationWidth, ADestinationHeight, ADestinationPitch : Integer);
-    Function Option(Const AOption : String) : Boolean;
-  End;

packages/ptc/src/copyi.inc

@@ -1,127 +0,0 @@
-{
-    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
-}
-
-Constructor TPTCCopy.Create;
-
-Begin
-  If Not Hermes_Init Then
-    Raise TPTCError.Create('could not initialize hermes');
-  FFlags := HERMES_CONVERT_NORMAL;
-  FHandle := Hermes_ConverterInstance(FFlags);
-  If FHandle = 0 Then
-    Raise TPTCError.Create('could not create hermes converter instance');
-End;
-
-Destructor TPTCCopy.Destroy;
-
-Begin
-  Hermes_ConverterReturn(FHandle);
-  Hermes_Done;
-  Inherited Destroy;
-End;
-
-Procedure TPTCCopy.Request(Const ASource, ADestination : TPTCFormat);
-
-Var
-  hermes_source_format, hermes_destination_format : PHermesFormat;
-
-Begin
-  hermes_source_format := @ASource.FFormat;
-  hermes_destination_format := @ADestination.FFormat;
-  If Not Hermes_ConverterRequest(FHandle, hermes_source_format,
-     hermes_destination_format) Then
-    Raise TPTCError.Create('unsupported hermes pixel format conversion');
-End;
-
-Procedure TPTCCopy.Palette(Const ASource, ADestination : TPTCPalette);
-
-Begin
-  If Not Hermes_ConverterPalette(FHandle, ASource.m_handle,
-         ADestination.m_handle) Then
-    Raise TPTCError.Create('could not set hermes conversion palettes');
-End;
-
-Procedure TPTCCopy.copy(Const ASourcePixels : Pointer; ASourceX, ASourceY,
-                   ASourceWidth, ASourceHeight, ASourcePitch : Integer;
-                   ADestinationPixels : Pointer; ADestinationX, ADestinationY,
-                   ADestinationWidth, ADestinationHeight, ADestinationPitch : Integer);
-
-Begin
-{$IFDEF DEBUG}
-{
-  This checking is performed only when DEBUG is defined,
-  and can be used to track down errors early caused by passing
-  nil pointers to surface and console functions.
-
-  Even though technicially it is the users responsibility
-  to ensure that all pointers are non-nil, it is useful
-  to provide a check here in debug build to prevent such
-  bugs from ever occuring.
-
-  The checking function also tests that the source and destination
-  pointers are not the same, a bug that can be caused by copying
-  a surface to itself. The nature of the copy routine is that
-  this operation is undefined if the source and destination memory
-  areas overlap.
-}
-  If ASourcePixels = Nil Then
-    Raise TPTCError.Create('nil source pointer in copy');
-  If ADestinationPixels = Nil Then
-    Raise TPTCError.Create('nil destination pointer in copy');
-  If ASourcePixels = ADestinationPixels Then
-    Raise TPTCError.Create('identical source and destination pointers in copy');
-{$ELSE DEBUG}
-    { in release build no checking is performed for the sake of efficiency. }
-{$ENDIF DEBUG}
-  If Not Hermes_ConverterCopy(FHandle, ASourcePixels, ASourceX, ASourceY,
-          ASourceWidth, ASourceHeight, ASourcePitch, ADestinationPixels,
-          ADestinationX, ADestinationY, ADestinationWidth, ADestinationHeight,
-          ADestinationPitch) Then
-    Raise TPTCError.Create('hermes conversion failure');
-End;
-
-Function TPTCCopy.Option(Const AOption : String) : Boolean;
-
-Begin
-  If (AOption = 'attempt dithering') And ((FFlags And HERMES_CONVERT_DITHER) = 0) Then
-  Begin
-    FFlags := FFlags Or HERMES_CONVERT_DITHER;
-    Update;
-    Result := True;
-    Exit;
-  End;
-  If (AOption = 'disable dithering') And ((FFlags And HERMES_CONVERT_DITHER) <> 0) Then
-  Begin
-    FFlags := FFlags And (Not HERMES_CONVERT_DITHER);
-    Update;
-    Result := True;
-    Exit;
-  End;
-  Result := False;
-End;
-
-Procedure TPTCCopy.Update;
-
-Begin
-  Hermes_ConverterReturn(FHandle);
-  FHandle := Hermes_ConverterInstance(FFlags);
-  If FHandle = 0 Then
-    Raise TPTCError.Create('could not update hermes converter instance');
-End;

packages/ptc/src/core/aread.inc

@@ -0,0 +1,51 @@
+{
+    Free Pascal port of the OpenPTC C++ library.
+    Copyright (C) 2001-2006  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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCArea = class
+  private
+    FLeft, FTop, FRight, FBottom: Integer;
+    function GetWidth: Integer;
+    function GetHeight: Integer;
+  public
+    constructor Create;
+    constructor Create(ALeft, ATop, ARight, ABottom: Integer);
+    constructor Create(const AArea: TPTCArea);
+    procedure Assign(const AArea: TPTCArea);
+    function Equals(const AArea: TPTCArea): Boolean;
+    property Left: Integer read FLeft;
+    property Top: Integer read FTop;
+    property Right: Integer read FRight;
+    property Bottom: Integer read FBottom;
+    property Width: Integer read GetWidth;
+    property Height: Integer read GetHeight;
+  end;

packages/ptc/src/areai.inc → packages/ptc/src/core/areai.inc

@@ -6,7 +6,19 @@
     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.
+    version 2.1 of the License, or (at your option) any later version
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,75 +30,68 @@
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 }
 
-Constructor TPTCArea.Create(ALeft, ATop, ARight, ABottom : Integer);
-
-Begin
-  If ALeft < ARight Then
-  Begin
+constructor TPTCArea.Create(ALeft, ATop, ARight, ABottom: Integer);
+begin
+  if ALeft < ARight then
+  begin
     FLeft := ALeft;
     FRight := ARight;
-  End
-  Else
-  Begin
+  end
+  else
+  begin
     FLeft := ARight;
     FRight := ALeft;
-  End;
-  If ATop < ABottom Then
-  Begin
+  end;
+  if ATop < ABottom then
+  begin
     FTop := ATop;
     FBottom := ABottom;
-  End
-  Else
-  Begin
+  end
+  else
+  begin
     FTop := ABottom;
     FBottom := ATop;
-  End;
-End;
-
-Constructor TPTCArea.Create;
+  end;
+end;
 
-Begin
+constructor TPTCArea.Create;
+begin
   FLeft   := 0;
   FRight  := 0;
   FTop    := 0;
   FBottom := 0;
-End;
+end;
 
-Constructor TPTCArea.Create(Const AArea : TPTCArea);
-
-Begin
+constructor TPTCArea.Create(const AArea: TPTCArea);
+begin
   FLeft   := AArea.FLeft;
   FTop    := AArea.FTop;
   FRight  := AArea.FRight;
   FBottom := AArea.FBottom;
-End;
-
-Procedure TPTCArea.Assign(Const AArea : TPTCArea);
+end;
 
-Begin
+procedure TPTCArea.Assign(const AArea: TPTCArea);
+begin
   FLeft   := AArea.FLeft;
   FTop    := AArea.FTop;
   FRight  := AArea.FRight;
   FBottom := AArea.FBottom;
-End;
+end;
 
-Function TPTCArea.Equals(Const AArea : TPTCArea) : Boolean;
-
-Begin
-  Result := (FLeft   = AArea.FLeft) And
-            (FTop    = AArea.FTop) And
-            (FRight  = AArea.FRight) And
+function TPTCArea.Equals(const AArea: TPTCArea): Boolean;
+begin
+  Result := (FLeft   = AArea.FLeft) and
+            (FTop    = AArea.FTop) and
+            (FRight  = AArea.FRight) and
             (FBottom = AArea.FBottom);
-End;
-
-Function TPTCArea.GetWidth : Integer;
+end;
 
-Begin
+function TPTCArea.GetWidth: Integer;
+begin
   Result := FRight - FLeft;
-End;
-
-Function TPTCArea.GetHeight : Integer;
+end;
 
-Begin
+function TPTCArea.GetHeight: Integer;
+begin
   Result := FBottom - FTop;
-End;
+end;

packages/ptc/src/core/baseconsoled.inc

@@ -0,0 +1,73 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCBaseConsole = class(TPTCBaseSurface)
+  private
+    FReleaseEnabled: Boolean;
+    function GetPages: Integer; virtual; abstract;
+    function GetName: string; virtual; abstract;
+    function GetTitle: string; virtual; abstract;
+    function GetInformation: string; virtual; abstract;
+  public
+    constructor Create; virtual;
+    procedure Configure(const AFileName: String); virtual; abstract;
+    function Modes: PPTCMode; virtual; abstract;
+    procedure Open(const ATitle: string; APages: Integer = 0); overload; virtual; abstract;
+    procedure Open(const ATitle: string; const AFormat: TPTCFormat;
+                   APages: Integer = 0); overload; virtual; abstract;
+    procedure Open(const ATitle: string; AWidth, AHeight: Integer;
+                   const AFormat: TPTCFormat; APages: Integer = 0); overload; virtual; abstract;
+    procedure Open(const ATitle: string; const AMode: TPTCMode;
+                   APages: Integer = 0); overload; virtual; abstract;
+    procedure Close; virtual; abstract;
+    procedure Flush; virtual; abstract;
+    procedure Finish; virtual; abstract;
+    procedure Update; virtual; abstract;
+    procedure Update(const AArea: TPTCArea); virtual; abstract;
+
+    { event handling }
+    function NextEvent(var AEvent: TPTCEvent; AWait: Boolean; const AEventMask: TPTCEventMask): Boolean; virtual; abstract;
+    function PeekEvent(AWait: Boolean; const AEventMask: TPTCEventMask): TPTCEvent; virtual; abstract;
+
+    { key handling }
+    function KeyPressed: Boolean;
+    function PeekKey(var AKey: TPTCKeyEvent): Boolean;
+    procedure ReadKey(var AKey: TPTCKeyEvent);
+    procedure ReadKey;
+    property KeyReleaseEnabled: Boolean read FReleaseEnabled write FReleaseEnabled;
+
+    property Pages: Integer read GetPages;
+    property Name: string read GetName;
+    property Title: string read GetTitle;
+    property Information: string read GetInformation;
+  end;

packages/ptc/src/core/baseconsolei.inc

@@ -0,0 +1,92 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+constructor TPTCBaseConsole.Create;
+begin
+  FReleaseEnabled := False;
+end;
+
+function TPTCBaseConsole.KeyPressed: Boolean;
+var
+  k, kpeek: TPTCEvent;
+begin
+  k := nil;
+  try
+    repeat
+      kpeek := PeekEvent(False, [PTCKeyEvent]);
+      if kpeek = nil then
+        exit(False);
+      if FReleaseEnabled or (kpeek As TPTCKeyEvent).Press then
+        exit(True);
+      NextEvent(k, False, [PTCKeyEvent]);
+    until False;
+  finally
+    k.Free;
+  end;
+end;
+
+procedure TPTCBaseConsole.ReadKey(var AKey: TPTCKeyEvent);
+var
+  ev: TPTCEvent;
+begin
+  ev := AKey;
+  try
+    repeat
+      NextEvent(ev, True, [PTCKeyEvent]);
+    until FReleaseEnabled or (ev As TPTCKeyEvent).Press;
+  finally
+    AKey := ev As TPTCKeyEvent;
+  end;
+end;
+
+function TPTCBaseConsole.PeekKey(var AKey: TPTCKeyEvent): Boolean;
+begin
+  if KeyPressed then
+  begin
+    ReadKey(AKey);
+    Result := True;
+  end
+  else
+    Result := False;
+end;
+
+procedure TPTCBaseConsole.ReadKey;
+var
+  k: TPTCKeyEvent;
+begin
+  k := TPTCKeyEvent.Create;
+  try
+    ReadKey(k);
+  finally
+    k.Free;
+  end;
+end;

packages/ptc/src/core/basesurfaced.inc

@@ -0,0 +1,79 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCBaseSurface = class
+  private
+    function GetWidth: Integer; virtual; abstract;
+    function GetHeight: Integer; virtual; abstract;
+    function GetPitch: Integer; virtual; abstract;
+    function GetArea: TPTCArea; virtual; abstract;
+    function GetFormat: TPTCFormat; virtual; abstract;
+  public
+    procedure Copy(ASurface: TPTCBaseSurface); virtual; abstract;
+    procedure Copy(ASurface: TPTCBaseSurface;
+                   const ASource, ADestination: TPTCArea); virtual; abstract;
+    function Lock: Pointer; virtual; abstract;
+    procedure Unlock; virtual; abstract;
+    procedure Load(const APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette); virtual; abstract;
+    procedure Load(const APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette;
+                   const ASource, ADestination: TPTCArea); virtual; abstract;
+    procedure Save(APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette); virtual; abstract;
+    procedure Save(APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette;
+                   const ASource, ADestination: TPTCArea); virtual; abstract;
+    procedure Clear; virtual; abstract;
+    procedure Clear(const AColor: TPTCColor); virtual; abstract;
+    procedure Clear(const AColor: TPTCColor;
+                    const AArea: TPTCArea); virtual; abstract;
+    procedure Palette(const APalette: TPTCPalette); virtual; abstract;
+    procedure Clip(const AArea: TPTCArea); virtual; abstract;
+    function Option(const AOption: String): Boolean; virtual; abstract;
+    function Clip: TPTCArea; virtual; abstract;
+    function Palette: TPTCPalette; virtual; abstract;
+    property Width: Integer read GetWidth;
+    property Height: Integer read GetHeight;
+    property Pitch: Integer read GetPitch;
+    property Area: TPTCArea read GetArea;
+    property Format: TPTCFormat read GetFormat;
+  end;

packages/ptc/src/eventd.inc → packages/ptc/src/core/basesurfacei.inc

@@ -6,7 +6,19 @@
     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.
+    version 2.1 of the License, or (at your option) any later version
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -17,22 +29,3 @@
     License along with this library; if not, write to the Free Software
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 }
-
-Type
-  TPTCEventType = (PTCKeyEvent, PTCMouseEvent{, PTCExposeEvent});
-  TPTCEventMask = Set Of TPTCEventType;
-  TPTCEvent = Class(TObject)
-  Protected
-    Function GetType : TPTCEventType; Virtual; Abstract;
-  Public
-    Property EventType : TPTCEventType Read GetType;
-  End;
-
-Const
-  PTCAnyEvent : TPTCEventMask = [PTCKeyEvent, PTCMouseEvent{, PTCExposeEvent}];
-
-{Type
-  TPTCExposeEvent = Class(TPTCEvent)
-  Protected
-    Function GetType : TPTCEventType; Override;
-  End;}

packages/ptc/src/core/cleard.inc

@@ -0,0 +1,45 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCClear = class
+  private
+    FHandle: THermesClearerHandle;
+    FFormat: TPTCFormat;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure Request(const AFormat: TPTCFormat);
+    procedure Clear(APixels: Pointer;
+                    AX, AY, AWidth, AHeight, APitch: Integer;
+                    const AColor: TPTCColor);
+  end;

packages/ptc/src/cleari.inc → packages/ptc/src/core/cleari.inc

@@ -6,7 +6,19 @@
     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.
+    version 2.1 of the License, or (at your option) any later version
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,26 +30,24 @@
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 }
 
-Constructor TPTCClear.Create;
-
-Begin
-  FFormat := Nil;
+constructor TPTCClear.Create;
+begin
+  FFormat := nil;
   { initialize hermes }
-  If Not Hermes_Init Then
-    Raise TPTCError.Create('could not initialize hermes');
+  if not Hermes_Init then
+    raise TPTCError.Create('could not initialize hermes');
 
   { default current format }
   FFormat := TPTCFormat.Create;
   { create hermes clearer instance }
   FHandle := Hermes_ClearerInstance;
   { check hermes clearer instance }
-  If FHandle = 0 Then
-    Raise TPTCError.Create('could not create hermes clearer instance');
-End;
-
-Destructor TPTCClear.Destroy;
+  if FHandle = nil then
+    raise TPTCError.Create('could not create hermes clearer instance');
+end;
 
-Begin
+destructor TPTCClear.Destroy;
+begin
   { return the clearer instance }
   Hermes_ClearerReturn(FHandle);
   FFormat.Free;
@@ -45,40 +55,36 @@ Begin
   { free hermes }
   Hermes_Done;
 
-  Inherited Destroy;
-End;
-
-Procedure TPTCClear.Request(Const AFormat : TPTCFormat);
+  inherited Destroy;
+end;
 
-Var
-  hermes_format : PHermesFormat;
-
-Begin
+procedure TPTCClear.Request(const AFormat: TPTCFormat);
+var
+  hermes_format: PHermesFormat;
+begin
   hermes_format := @AFormat.FFormat;
   { request surface clear for this format }
-  If Not Hermes_ClearerRequest(FHandle, hermes_format) Then
-    Raise TPTCError.Create('unsupported clear format');
+  if not Hermes_ClearerRequest(FHandle, hermes_format) then
+    raise TPTCError.Create('unsupported clear format');
 
   { update current format }
   FFormat.Assign(AFormat);
-End;
-
-Procedure TPTCClear.Clear(APixels : Pointer; AX, AY, AWidth, AHeight, APitch : Integer; Const AColor : TPTCColor);
-
-Var
-  r, g, b, a : LongInt;
-  index : LongInt;
+end;
 
-Begin
-  If APixels = Nil Then
-    Raise TPTCError.Create('nil pixels pointer in clear');
+procedure TPTCClear.Clear(APixels: Pointer; AX, AY, AWidth, AHeight, APitch: Integer; const AColor: TPTCColor);
+var
+  r, g, b, a: LongInt;
+  index: LongInt;
+begin
+  if APixels = nil then
+    raise TPTCError.Create('nil pixels pointer in clear');
 
   { check format type }
-  If FFormat.direct Then
-  Begin
+  if FFormat.direct then
+  begin
     { check color type }
-    If Not AColor.direct Then
-      Raise TPTCError.Create('direct pixel formats can only be cleared with direct color');
+    if not AColor.direct then
+      raise TPTCError.Create('direct pixel formats can only be cleared with direct color');
 
     { setup clear color }
     r := Trunc(AColor.R * 255);
@@ -87,55 +93,55 @@ Begin
     a := Trunc(AColor.A * 255);
 
     { clamp red }
-    If r > 255 Then
+    if r > 255 then
       r := 255
-    Else
-      If r < 0 Then
+    else
+      if r < 0 then
         r := 0;
 
     { clamp green }
-    If g > 255 Then
+    if g > 255 then
       g := 255
-    Else
-      If g < 0 Then
+    else
+      if g < 0 then
         g := 0;
 
     { clamp blue }
-    If b > 255 Then
+    if b > 255 then
       b := 255
-    Else
-      If b < 0 Then
+    else
+      if b < 0 then
         b := 0;
 
     { clamp alpha }
-    If a > 255 Then
+    if a > 255 then
       a := 255
-    Else
-      If a < 0 Then
+    else
+      if a < 0 then
         a := 0;
 
     { perform the clearing }
     Hermes_ClearerClear(FHandle, APixels, AX, AY, AWidth, AHeight, APitch,
                         r, g, b, a);
-  End
-  Else
-  Begin
+  end
+  else
+  begin
     { check color type }
-    If Not AColor.indexed Then
-      Raise TPTCError.Create('indexed pixel formats can only be cleared with indexed color');
+    if not AColor.indexed then
+      raise TPTCError.Create('indexed pixel formats can only be cleared with indexed color');
 
     { setup clear index }
     index := AColor.index;
 
     { clamp color index }
-    If index > 255 Then
+    if index > 255 then
       index := 255
-    Else
-      If index < 0 Then
+    else
+      if index < 0 then
         index := 0;
 
     { perform the clearing }
     Hermes_ClearerClear(FHandle, APixels, AX, AY, AWidth, AHeight, APitch,
                         0, 0, 0, index);
-  End;
-End;
+  end;
+end;

packages/ptc/src/clipperd.inc → packages/ptc/src/core/clipperd.inc

@@ -6,7 +6,19 @@
     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.
+    version 2.1 of the License, or (at your option) any later version
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,13 +30,13 @@
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 }
 
-Type
-  TPTCClipper=Class(TObject)
-  Public
+type
+  TPTCClipper = class
+  public
     { clip a single area against clip area }
-    Class Function Clip(Const AArea, AClip : TPTCArea) : TPTCArea;
+    class function Clip(const AArea, AClip: TPTCArea): TPTCArea;
     { clip source and destination areas against source and destination clip areas }
-    Class Procedure Clip(Const ASource, AClipSource, AClippedSource,
+    class procedure Clip(const ASource, AClipSource, AClippedSource,
                          ADestination, AClipDestination,
-                         AClippedDestination : TPTCArea);
-  End;
+                         AClippedDestination: TPTCArea);
+  end;

packages/ptc/src/clipperi.inc → packages/ptc/src/core/clipperi.inc

@@ -6,7 +6,19 @@
     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.
+    version 2.1 of the License, or (at your option) any later version
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -20,13 +32,11 @@
 
 {$INLINE ON}
 
-Class Function TPTCClipper.Clip(Const AArea, AClip : TPTCArea) : TPTCArea;
-
-Var
-  left, top, right, bottom : Integer;
-  clip_left, clip_top, clip_right, clip_bottom : Integer;
-
-Begin
+class function TPTCClipper.Clip(const AArea, AClip: TPTCArea): TPTCArea;
+var
+  left, top, right, bottom: Integer;
+  clip_left, clip_top, clip_right, clip_bottom: Integer;
+begin
   { get in coordinates }
   left   := AArea.Left;
   top    := AArea.Top;
@@ -40,66 +50,63 @@ Begin
   clip_bottom := AClip.Bottom;
 
   { clip left }
-  If left < clip_left Then
+  if left < clip_left then
     left := clip_left;
-  If left > clip_right Then
+  if left > clip_right then
     left := clip_right;
 
   { clip top }
-  If top < clip_top Then
+  if top < clip_top then
     top := clip_top;
-  If top > clip_bottom Then
+  if top > clip_bottom then
     top := clip_bottom;
 
   { clip right }
-  If right < clip_left Then
+  if right < clip_left then
     right := clip_left;
-  If right > clip_right Then
+  if right > clip_right then
     right := clip_right;
 
   { clip bottom }
-  If bottom < clip_top Then
+  if bottom < clip_top then
     bottom := clip_top;
-  If bottom > clip_bottom Then
+  if bottom > clip_bottom then
     bottom := clip_bottom;
 
   Result := TPTCArea.Create(Left, Top, Right, Bottom);
-End;
+end;
 
 { clip floating point area against a floating point clip area }
-Procedure TPTCClipper_clip(Var left, top, right, bottom : Real;
-                           clip_left, clip_top, clip_right, clip_bottom : Real); Inline;
-
-Begin
+procedure TPTCClipper_clip(var left, top, right, bottom: Real;
+                           clip_left, clip_top, clip_right, clip_bottom: Real); Inline;
+begin
   { clip left }
-  If left < clip_left Then
+  if left < clip_left then
     left := clip_left;
-  If left > clip_right Then
+  if left > clip_right then
     left := clip_right;
   { clip top }
-  If top < clip_top Then
+  if top < clip_top then
     top := clip_top;
-  If top > clip_bottom Then
+  if top > clip_bottom then
     top := clip_bottom;
   { clip right }
-  If right < clip_left Then
+  if right < clip_left then
     right := clip_left;
-  If right > clip_right Then
+  if right > clip_right then
     right := clip_right;
   { clip bottom }
-  If bottom < clip_top Then
+  if bottom < clip_top then
     bottom := clip_top;
-  If bottom > clip_bottom Then
+  if bottom > clip_bottom then
     bottom := clip_bottom;
-End;
+end;
 
 { clip floating point area against clip area }
-Procedure TPTCClipper_clip(Var left, top, right, bottom : Real; Const _clip : TPTCArea); Inline;
-
-Var
-  clip_left, clip_top, clip_right, clip_bottom : Real;
-
-Begin
+procedure TPTCClipper_clip(var left, top, right, bottom: Real; const _clip: TPTCArea); Inline;
+var
+  clip_left, clip_top, clip_right, clip_bottom: Real;
+begin
   { get floating point clip area }
   clip_left := _clip.left;
   clip_top := _clip.top;
@@ -107,47 +114,43 @@ Begin
   clip_bottom := _clip.bottom;
   { clip floating point area against floating point clip area }
   TPTCClipper_clip(left, top, right, bottom, clip_left, clip_top, clip_right, clip_bottom);
-End;
+end;
 
 { snap a floating point area to integer coordinates }
-Procedure TPTCClipper_round(Var left, top, right, bottom : Real); Inline;
-
-Begin
+procedure TPTCClipper_round(var left, top, right, bottom: Real); Inline;
+begin
   left := Round(left);
   top := Round(top);
   right := Round(right);
   bottom := Round(bottom);
-End;
+end;
 
-Class Procedure TPTCClipper.Clip(Const ASource, AClipSource, AClippedSource,
+class procedure TPTCClipper.Clip(const ASource, AClipSource, AClippedSource,
                                  ADestination, AClipDestination,
-                                 AClippedDestination : TPTCArea);
-
-Var
-  tmp1, tmp2 : TPTCArea;
-
-  source_left, source_top, source_right, source_bottom : Real;
+                                 AClippedDestination: TPTCArea);
+var
+  tmp1, tmp2: TPTCArea;
+  source_left, source_top, source_right, source_bottom: Real;
   clipped_source_left, clipped_source_top, clipped_source_right,
-  clipped_source_bottom : Real;
+  clipped_source_bottom: Real;
   source_delta_left, source_delta_top, source_delta_right,
-  source_delta_bottom : Real;
-  source_to_destination_x, source_to_destination_y : Real;
+  source_delta_bottom: Real;
+  source_to_destination_x, source_to_destination_y: Real;
   destination_left, destination_top, destination_right,
-  destination_bottom : Real;
+  destination_bottom: Real;
   adjusted_destination_left, adjusted_destination_top,
-  adjusted_destination_right, adjusted_destination_bottom : Real;
+  adjusted_destination_right, adjusted_destination_bottom: Real;
   clipped_destination_left, clipped_destination_top,
-  clipped_destination_right, clipped_destination_bottom : Real;
+  clipped_destination_right, clipped_destination_bottom: Real;
   destination_delta_left, destination_delta_top, destination_delta_right,
-  destination_delta_bottom : Real;
-  destination_to_source_x, destination_to_source_y : Real;
+  destination_delta_bottom: Real;
+  destination_to_source_x, destination_to_source_y: Real;
   adjusted_source_left, adjusted_source_top, adjusted_source_right,
-  adjusted_source_bottom : Real;
-
-Begin
-  tmp1 := Nil;
-  tmp2 := Nil;
-  Try
+  adjusted_source_bottom: Real;
+begin
+  tmp1 := nil;
+  tmp2 := nil;
+  try
     { expand source area to floating point }
     source_left   := ASource.Left;
     source_top    := ASource.Top;
@@ -165,15 +168,15 @@ Begin
                      clipped_source_bottom, AClipSource);
 
     { check for early source area clipping exit }
-    If (clipped_source_left = clipped_source_right) Or
-       (clipped_source_top = clipped_source_bottom) Then
-    Begin
+    if (clipped_source_left = clipped_source_right) or
+       (clipped_source_top = clipped_source_bottom) then
+    begin
       { clipped area is zero }
       tmp1 := TPTCArea.Create(0, 0, 0, 0);
       AClippedSource.Assign(tmp1);
       AClippedDestination.Assign(tmp1);
-      Exit;
-    End;
+      exit;
+    end;
 
     { calculate deltas in source clip }
     source_delta_left := clipped_source_left - source_left;
@@ -208,15 +211,15 @@ Begin
                      clipped_destination_right, clipped_destination_bottom, AClipDestination);
 
     { check for early destination area clipping exit }
-    If (clipped_destination_left = clipped_destination_right) Or
-       (clipped_destination_top = clipped_destination_bottom) Then
-    Begin
+    if (clipped_destination_left = clipped_destination_right) or
+       (clipped_destination_top = clipped_destination_bottom) then
+    begin
       { clipped area is zero }
       tmp1 := TPTCArea.Create(0, 0, 0, 0);
       AClippedSource.Assign(tmp1);
       AClippedDestination.Assign(tmp1);
-      Exit;
-    End;
+      exit;
+    end;
 
     { calculate deltas in destination clip }
     destination_delta_left := clipped_destination_left - adjusted_destination_left;
@@ -257,8 +260,8 @@ Begin
                             Trunc(clipped_destination_bottom));
     AClippedSource.Assign(tmp1);
     AClippedDestination.Assign(tmp2);
-  Finally
+  finally
     tmp1.Free;
     tmp2.Free;
-  End;
-End;
+  end;
+end;

packages/ptc/src/core/colord.inc

@@ -0,0 +1,54 @@
+{
+    Free Pascal port of the OpenPTC C++ library.
+    Copyright (C) 2001-2006  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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCColor = class
+  private
+    FIndex: Integer;
+    FRed, FGreen, FBlue, FAlpha: Single;
+    FDirect: Boolean;
+    FIndexed: Boolean;
+  public
+    constructor Create;
+    constructor Create(AIndex: Integer);
+    constructor Create(ARed, AGreen, ABlue: Single; AAlpha: Single = 1);
+    constructor Create(const AColor: TPTCColor);
+    procedure Assign(const AColor: TPTCColor);
+    function Equals(const AColor: TPTCColor): Boolean;
+    property Index: Integer read FIndex;
+    property R: Single read FRed;
+    property G: Single read FGreen;
+    property B: Single read FBlue;
+    property A: Single read FAlpha;
+    property Direct: Boolean read FDirect;
+    property Indexed: Boolean read FIndexed;
+  end;

packages/ptc/src/colori.inc → packages/ptc/src/core/colori.inc

@@ -6,7 +6,19 @@
     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.
+    version 2.1 of the License, or (at your option) any later version
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,9 +30,8 @@
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 }
 
-Constructor TPTCColor.Create;
-
-Begin
+constructor TPTCColor.Create;
+begin
   FIndexed := False;
   FDirect  := False;
   FIndex   := 0;
@@ -28,11 +39,10 @@ Begin
   FGreen   := 0;
   FBlue    := 0;
   FAlpha   := 1;
-End;
+end;
 
-Constructor TPTCColor.Create(AIndex : Integer);
-
-Begin
+constructor TPTCColor.Create(AIndex: Integer);
+begin
   FIndexed := True;
   FDirect  := False;
   FIndex   := AIndex;
@@ -40,11 +50,10 @@ Begin
   FGreen   := 0;
   FBlue    := 0;
   FAlpha   := 1;
-End;
-
-Constructor TPTCColor.Create(ARed, AGreen, ABlue : Single; AAlpha : Single = 1);
+end;
 
-Begin
+constructor TPTCColor.Create(ARed, AGreen, ABlue: Single; AAlpha: Single = 1);
+begin
   FIndexed := False;
   FDirect  := True;
   FIndex   := 0;
@@ -52,11 +61,10 @@ Begin
   FGreen   := AGreen;
   FBlue    := ABlue;
   FAlpha   := AAlpha;
-End;
+end;
 
-Constructor TPTCColor.Create(Const AColor : TPTCColor);
-
-Begin
+constructor TPTCColor.Create(const AColor: TPTCColor);
+begin
   FIndex   := AColor.FIndex;
   FRed     := AColor.FRed;
   FGreen   := AColor.FGreen;
@@ -64,11 +72,10 @@ Begin
   FAlpha   := AColor.FAlpha;
   FDirect  := AColor.FDirect;
   FIndexed := AColor.FIndexed;
-End;
-
-Procedure TPTCColor.Assign(Const AColor : TPTCColor);
+end;
 
-Begin
+procedure TPTCColor.Assign(const AColor: TPTCColor);
+begin
   FIndex   := AColor.FIndex;
   FRed     := AColor.FRed;
   FGreen   := AColor.FGreen;
@@ -76,16 +83,15 @@ Begin
   FAlpha   := AColor.FAlpha;
   FDirect  := AColor.FDirect;
   FIndexed := AColor.FIndexed;
-End;
-
-Function TPTCColor.Equals(Const AColor : TPTCColor) : Boolean;
+end;
 
-Begin
-  Result := (FIndexed = AColor.FIndexed) And
-            (FDirect  = AColor.FDirect) And
-            (FIndex   = AColor.FIndex) And
-            (FRed     = AColor.FRed) And
-            (FGreen   = AColor.FGreen) And
-            (FBlue    = AColor.FBlue) And
+function TPTCColor.Equals(const AColor: TPTCColor): Boolean;
+begin
+  Result := (FIndexed = AColor.FIndexed) and
+            (FDirect  = AColor.FDirect) and
+            (FIndex   = AColor.FIndex) and
+            (FRed     = AColor.FRed) and
+            (FGreen   = AColor.FGreen) and
+            (FBlue    = AColor.FBlue) and
             (FAlpha   = AColor.FAlpha);
-End;
+end;

packages/ptc/src/core/consoled.inc

@@ -0,0 +1,109 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCConsole = class(TPTCBaseConsole)
+  private
+    FConsole: TPTCBaseConsole;
+    FModes: array [0..1023] of TPTCMode;
+    FOptionsQueue: array of string;
+    FHackyOptionConsoleFlag: Boolean;
+
+    function ConsoleCreate(AIndex: Integer): TPTCBaseConsole;
+    function ConsoleCreate(const AName: string): TPTCBaseConsole;
+    procedure Check;
+
+    procedure AddOptionToOptionsQueue(const AOption: string);
+    procedure ExecuteOptionsFromOptionsQueue;
+    procedure ClearOptionsQueue;
+  public
+    constructor Create; override;
+    destructor Destroy; override;
+    procedure Configure(const AFile: string); override;
+    function Option(const AOption: string): Boolean; override;
+    function Modes: PPTCMode; override;
+    procedure Open(const ATitle: string; APages: Integer = 0); overload; override;
+    procedure Open(const ATitle: string; const AFormat: TPTCFormat;
+                   APages: Integer = 0); overload; override;
+    procedure Open(const ATitle: string; AWidth, AHeight: Integer;
+                   const AFormat: TPTCFormat; APages: Integer = 0); overload; override;
+    procedure Open(const ATitle: string; const AMode: TPTCMode;
+                   APages: Integer = 0); overload; override;
+
+    procedure Close; override;
+    procedure Flush; override;
+    procedure Finish; override;
+    procedure Update; override;
+    procedure Update(const AArea: TPTCArea); override;
+    procedure Copy(ASurface: TPTCBaseSurface); override;
+    procedure Copy(ASurface: TPTCBaseSurface;
+                   const ASource, ADestination: TPTCArea); override;
+    function Lock: Pointer; override;
+    procedure Unlock; override;
+    procedure Load(const APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette); override;
+    procedure Load(const APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette;
+                   const ASource, ADestination: TPTCArea); override;
+    procedure Save(APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette); override;
+    procedure Save(APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette;
+                   const ASource, ADestination: TPTCArea); override;
+    procedure Clear; override;
+    procedure Clear(const AColor: TPTCColor); override;
+    procedure Clear(const AColor: TPTCColor;
+                    const AArea: TPTCArea); override;
+    procedure Palette(const APalette: TPTCPalette); override;
+    function Palette: TPTCPalette; override;
+    procedure Clip(const AArea: TPTCArea); override;
+    function GetWidth: Integer; override;
+    function GetHeight: Integer; override;
+    function GetPitch: Integer; override;
+    function GetPages: Integer; override;
+    function GetArea: TPTCArea; override;
+    function Clip: TPTCArea; override;
+    function GetFormat: TPTCFormat; override;
+    function GetName: string; override;
+    function GetTitle: string; override;
+    function GetInformation: string; override;
+    function NextEvent(var AEvent: TPTCEvent; AWait: Boolean; const AEventMask: TPTCEventMask): Boolean; override;
+    function PeekEvent(AWait: Boolean; const AEventMask: TPTCEventMask): TPTCEvent; override;
+  end;

packages/ptc/src/core/consolei.inc

@@ -0,0 +1,753 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+const
+ {$IFDEF GO32V2}
+  ConsoleTypesNumber = 4;
+ {$ENDIF GO32V2}
+ {$IF defined(Win32) OR defined(Win64)}
+  ConsoleTypesNumber = 2;
+ {$ENDIF defined(Win32) OR defined(Win64)}
+ {$IFDEF WinCE}
+  ConsoleTypesNumber = 2;
+ {$ENDIF WinCE}
+ {$IFDEF UNIX}
+  ConsoleTypesNumber = 1;
+ {$ENDIF UNIX}
+  ConsoleTypes: array [0..ConsoleTypesNumber - 1] of
+    record
+      ConsoleClass: class of TPTCBaseConsole;
+      Names: array [1..2] of string;
+    end =
+  (
+  {$IFDEF GO32V2}
+   (ConsoleClass: TVESAConsole;      Names: ('VESA', '')),
+   (ConsoleClass: TVGAConsole;       Names: ('VGA', 'Fakemode')),
+   (ConsoleClass: TCGAConsole;       Names: ('CGA', '')),
+   (ConsoleClass: TTEXTFX2Console;   Names: ('TEXTFX2', 'Text'))
+  {$ENDIF GO32V2}
+
+  {$IF defined(Win32) OR defined(Win64)}
+   (ConsoleClass: TDirectXConsole;   Names: ('DirectX', '')),
+   (ConsoleClass: TGDIConsole;       Names: ('GDI', ''))
+  {$ENDIF defined(Win32) OR defined(Win64)}
+
+  {$IFDEF WinCE}
+   (ConsoleClass: TWinCEGAPIConsole; Names: ('GAPI', '')),
+   (ConsoleClass: TWinCEGDIConsole;  Names: ('GDI', ''))
+  {$ENDIF WinCE}
+
+  {$IFDEF UNIX}
+   (ConsoleClass: TX11Console;       Names: ('X11', ''))
+  {$ENDIF UNIX}
+  );
+
+constructor TPTCConsole.Create;
+var
+  I: Integer;
+  {$IFDEF UNIX}
+  s: AnsiString;
+  {$ENDIF UNIX}
+begin
+  inherited Create;
+  FConsole := nil;
+  FHackyOptionConsoleFlag := False;
+  FillChar(FModes, SizeOf(FModes), 0);
+  for I := Low(FModes) to High(FModes) do
+    FModes[I] := TPTCMode.Create;
+
+  {$IFDEF UNIX}
+    Configure('/usr/share/ptcpas/ptcpas.conf');
+    s := fpgetenv('HOME');
+    if s = '' then
+      s := '/';
+    if s[Length(s)] <> '/' then
+      s := s + '/';
+    s := s + '.ptcpas.conf';
+    Configure(s);
+  {$ENDIF UNIX}
+
+  {$IFDEF Win32}
+    Configure('ptcpas.cfg');
+  {$ENDIF Win32}
+
+  {$IFDEF GO32V2}
+    Configure('ptcpas.cfg');
+  {$ENDIF GO32V2}
+
+  {$IFDEF WinCE}
+  {todo: configure WinCE}
+  {$ENDIF WinCE}
+end;
+
+destructor TPTCConsole.Destroy;
+var
+  I: Integer;
+begin
+  close;
+  FConsole.Free;
+  for I := Low(FModes) to High(FModes) do
+    FModes[I].Free;
+  inherited Destroy;
+end;
+
+procedure TPTCConsole.Configure(const AFile: string);
+var
+  F: TextFile;
+  S: string;
+begin
+  AssignFile(F, AFile);
+  {$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;
+
+procedure TPTCConsole.AddOptionToOptionsQueue(const AOption: string);
+begin
+  SetLength(FOptionsQueue, Length(FOptionsQueue) + 1);
+  FOptionsQueue[High(FOptionsQueue)] := AOption;
+end;
+
+procedure TPTCConsole.ExecuteOptionsFromOptionsQueue;
+var
+  I: Integer;
+begin
+  for I := Low(FOptionsQueue) to High(FOptionsQueue) do
+    FConsole.Option(FOptionsQueue[I]);
+end;
+
+procedure TPTCConsole.ClearOptionsQueue;
+begin
+  SetLength(FOptionsQueue, 0);
+end;
+
+function TPTCConsole.Option(const AOption: String): Boolean;
+begin
+  if AOption = 'enable logging' then
+  begin
+    LOG_enabled := True;
+    Result := True;
+    exit;
+  end;
+  if AOption = 'disable logging' then
+  begin
+    LOG_enabled := False;
+    Result := True;
+    exit;
+  end;
+
+  if Assigned(FConsole) then
+    Result := FConsole.Option(AOption)
+  else
+  begin
+    FConsole := ConsoleCreate(AOption);
+    if Assigned(FConsole) then
+    begin
+      FHackyOptionConsoleFlag := True;
+      ExecuteOptionsFromOptionsQueue;
+{      ClearOptionsQueue;}
+      Result := True;
+    end
+    else
+    begin
+      { TODO: check if the option is supported by at least one console... }
+      if {OptionSupported}True then
+      begin
+        AddOptionToOptionsQueue(AOption);
+        Result := True;
+      end
+      else
+        Result := False;
+    end;
+  end;
+end;
+
+function TPTCConsole.Modes: PPTCMode;
+var
+  _console: TPTCBaseConsole;
+  index, mode: Integer;
+  local: Integer;
+  _modes: PPTCMode;
+  tmp: TPTCMode;
+begin
+  if Assigned(FConsole) then
+    Result := FConsole.Modes
+  else
+  begin
+    _console := nil;
+    index := -1;
+    mode := 0;
+    try
+      repeat
+        Inc(index);
+        try
+          _console := ConsoleCreate(index);
+        except
+          on TPTCError do begin
+            FreeAndNil(_console);
+            Continue;
+          end;
+        end;
+        if _console = nil then
+          Break;
+        _modes := _console.modes;
+        local := 0;
+        while _modes[local].valid do
+        begin
+          FModes[mode].Assign(_modes[local]);
+          Inc(local);
+          Inc(mode);
+        end;
+        FreeAndNil(_console);
+      until False;
+    finally
+      _console.Free;
+    end;
+    { todo: strip duplicate modes from list? }
+    tmp := TPTCMode.Create;
+    try
+      FModes[mode].Assign(tmp);
+    finally
+      tmp.Free;
+    end;
+    Result := FModes;
+  end;
+end;
+
+procedure TPTCConsole.Open(const ATitle: string; APages: Integer);
+var
+  composite, tmp: TPTCError;
+  index: Integer;
+  success: Boolean;
+begin
+  if Assigned(FConsole) then
+  begin
+    try
+      FConsole.open(ATitle, APages);
+      exit;
+    except
+      on error: TPTCError do begin
+        FreeAndNil(FConsole);
+        if FHackyOptionConsoleFlag then
+        begin
+          FHackyOptionConsoleFlag := False;
+          raise TPTCError.Create('could not open console', error);
+        end;
+      end;
+    end;
+  end;
+  index := -1;
+  composite := TPTCError.Create;
+  success := False;
+  try
+    repeat
+      Inc(index);
+      try
+        FConsole := ConsoleCreate(index);
+        if FConsole = nil then
+          break;
+        ExecuteOptionsFromOptionsQueue;
+        FConsole.Open(ATitle, APages);
+{        ClearOptionsQueue;}
+        success := True;
+        exit;
+      except
+        on error: TPTCError do begin
+          tmp := TPTCError.Create(error.message, composite);
+          try
+            composite.Assign(tmp);
+          finally
+            tmp.Free;
+          end;
+          FreeAndNil(FConsole);
+          continue;
+        end;
+      end;
+    until False;
+    FConsole := nil;
+    raise TPTCError.Create(composite);
+  finally
+    composite.Free;
+    if not success then
+      FreeAndNil(FConsole);
+  end;
+end;
+
+procedure TPTCConsole.Open(const ATitle: string; const AFormat: TPTCFormat;
+                           APages: Integer);
+var
+  composite, tmp: TPTCError;
+  index: Integer;
+  success: Boolean;
+begin
+  if Assigned(FConsole) then
+  begin
+    try
+      FConsole.open(ATitle, AFormat, APages);
+      exit;
+    except
+      on error: TPTCError do begin
+        FreeAndNil(FConsole);
+        if FHackyOptionConsoleFlag then
+        begin
+          FHackyOptionConsoleFlag := False;
+          raise TPTCError.Create('could not open console', error);
+        end;
+      end;
+    end;
+  end;
+  index := -1;
+  composite := TPTCError.Create;
+  success := False;
+  try
+    repeat
+      Inc(index);
+      try
+        FConsole := ConsoleCreate(index);
+        if FConsole = nil then
+          break;
+        ExecuteOptionsFromOptionsQueue;
+        FConsole.open(ATitle, AFormat, APages);
+{        ClearOptionsQueue;}
+        success := True;
+        exit;
+      except
+        on error: TPTCError do begin
+          tmp := TPTCError.Create(error.message, composite);
+          try
+            composite.Assign(tmp);
+          finally
+            tmp.Free;
+          end;
+          FreeAndNil(FConsole);
+          Continue;
+        end;
+      end;
+    until False;
+    FConsole := nil;
+    raise TPTCError.Create(composite);
+  finally
+    composite.Free;
+    if not success then
+      FreeAndNil(FConsole);
+  end;
+end;
+
+procedure TPTCConsole.Open(const ATitle: string; AWidth, AHeight: Integer;
+                           const AFormat: TPTCFormat; APages: Integer);
+var
+  composite, tmp: TPTCError;
+  index: Integer;
+  success: Boolean;
+begin
+  if Assigned(FConsole) then
+  begin
+    try
+      FConsole.Open(ATitle, AWidth, AHeight, AFormat, APages);
+      exit;
+    except
+      on error: TPTCError do begin
+        FreeAndNil(FConsole);
+        if FHackyOptionConsoleFlag then
+        begin
+          FHackyOptionConsoleFlag := False;
+          raise TPTCError.Create('could not open console', error);
+        end;
+      end;
+    end;
+  end;
+  index := -1;
+  composite := TPTCError.Create;
+  success := False;
+  try
+    repeat
+      Inc(index);
+      try
+        FConsole := ConsoleCreate(index);
+        if FConsole = nil then
+          Break;
+        ExecuteOptionsFromOptionsQueue;
+        FConsole.Open(ATitle, AWidth, AHeight, AFormat, APages);
+{        ClearOptionsQueue;}
+        success := True;
+        exit;
+      except
+        on error: TPTCError do begin
+          tmp := TPTCError.Create(error.message, composite);
+          try
+            composite.Assign(tmp);
+          finally
+            tmp.Free;
+          end;
+          FreeAndNil(FConsole);
+          Continue;
+        end;
+      end;
+    until False;
+    FConsole := nil;
+    raise TPTCError.Create(composite);
+  finally
+    composite.Free;
+    if not success then
+      FreeAndNil(FConsole);
+  end;
+end;
+
+procedure TPTCConsole.Open(const ATitle: string; const AMode: TPTCMode;
+                           APages: Integer);
+var
+  composite, tmp: TPTCError;
+  index: Integer;
+  success: Boolean;
+begin
+  if Assigned(FConsole) then
+  begin
+    try
+      FConsole.Open(ATitle, AMode, APages);
+      exit;
+    except
+      on error: TPTCError do begin
+        FreeAndNil(FConsole);
+        if FHackyOptionConsoleFlag then
+        begin
+          FHackyOptionConsoleFlag := False;
+          raise TPTCError.Create('could not open console', error);
+        end;
+      end;
+    end;
+  end;
+  index := -1;
+  composite := TPTCError.Create;
+  success := False;
+  try
+    repeat
+      Inc(index);
+      try
+        FConsole := ConsoleCreate(index);
+        if FConsole = nil then
+          Break;
+        ExecuteOptionsFromOptionsQueue;
+        FConsole.Open(ATitle, AMode, APages);
+{        ClearOptionsQueue;}
+        success := True;
+        exit;
+      except
+        on error: TPTCError do begin
+          tmp := TPTCError.Create(error.message, composite);
+          try
+            composite.Assign(tmp);
+          finally
+            tmp.Free;
+          end;
+          FreeAndNil(FConsole);
+          Continue;
+        end;
+      end;
+    until False;
+    FConsole := nil;
+    raise TPTCError.Create(composite);
+  finally
+    composite.Free;
+    if not success then
+      FreeAndNil(FConsole);
+  end;
+end;
+
+procedure TPTCConsole.Close;
+begin
+  if Assigned(FConsole) then
+    FConsole.Close;
+  FHackyOptionConsoleFlag := False;
+end;
+
+procedure TPTCConsole.Flush;
+begin
+  Check;
+  FConsole.Flush;
+end;
+
+procedure TPTCConsole.Finish;
+begin
+  Check;
+  FConsole.Finish;
+end;
+
+procedure TPTCConsole.Update;
+begin
+  Check;
+  FConsole.Update;
+end;
+
+procedure TPTCConsole.Update(const AArea: TPTCArea);
+begin
+  Check;
+  FConsole.Update(AArea);
+end;
+
+procedure TPTCConsole.Copy(ASurface: TPTCBaseSurface);
+begin
+  Check;
+  FConsole.Copy(ASurface);
+end;
+
+procedure TPTCConsole.Copy(ASurface: TPTCBaseSurface;
+                           const ASource, ADestination: TPTCArea);
+begin
+  Check;
+  FConsole.Copy(ASurface, ASource, ADestination);
+end;
+
+function TPTCConsole.Lock: Pointer;
+begin
+  Check;
+  Result := FConsole.Lock;
+end;
+
+procedure TPTCConsole.Unlock;
+begin
+  Check;
+  FConsole.Unlock;
+end;
+
+procedure TPTCConsole.Load(const APixels: Pointer;
+                           AWidth, AHeight, APitch: Integer;
+                           const AFormat: TPTCFormat;
+                           const APalette: TPTCPalette);
+begin
+  Check;
+  FConsole.Load(APixels, AWidth, AHeight, APitch, AFormat, APalette);
+end;
+
+procedure TPTCConsole.Load(const APixels: Pointer;
+                           AWidth, AHeight, APitch: Integer;
+                           const AFormat: TPTCFormat;
+                           const APalette: TPTCPalette;
+                           const ASource, ADestination: TPTCArea);
+begin
+  Check;
+  FConsole.Load(APixels, AWidth, AHeight, APitch, AFormat, APalette,
+                ASource, ADestination);
+end;
+
+procedure TPTCConsole.Save(Apixels: Pointer;
+                           AWidth, AHeight, APitch: Integer;
+                           const AFormat: TPTCFormat;
+                           const APalette: TPTCPalette);
+begin
+  Check;
+  FConsole.Save(APixels, AWidth, AHeight, APitch, AFormat, APalette);
+end;
+
+procedure TPTCConsole.Save(APixels: Pointer;
+                           AWidth, AHeight, APitch: Integer;
+                           const AFormat: TPTCFormat;
+                           const APalette: TPTCPalette;
+                           const ASource, ADestination: TPTCArea);
+begin
+  Check;
+  FConsole.Save(APixels, AWidth, AHeight, APitch, AFormat, APalette,
+                ASource, ADestination);
+end;
+
+procedure TPTCConsole.Clear;
+begin
+  Check;
+  FConsole.clear;
+end;
+
+procedure TPTCConsole.Clear(const AColor: TPTCColor);
+begin
+  Check;
+  FConsole.clear(AColor);
+end;
+
+procedure TPTCConsole.Clear(const AColor: TPTCColor;
+                           const AArea: TPTCArea);
+begin
+  Check;
+  FConsole.clear(AColor, AArea);
+end;
+
+procedure TPTCConsole.Palette(const APalette: TPTCPalette);
+begin
+  Check;
+  FConsole.Palette(APalette);
+end;
+
+function TPTCConsole.Palette: TPTCPalette;
+begin
+  Check;
+  Result := FConsole.Palette;
+end;
+
+procedure TPTCConsole.Clip(const AArea: TPTCArea);
+begin
+  Check;
+  FConsole.Clip(AArea);
+end;
+
+function TPTCConsole.GetWidth: Integer;
+begin
+  Check;
+  Result := FConsole.GetWidth;
+end;
+
+function TPTCConsole.GetHeight: Integer;
+begin
+  Check;
+  Result := FConsole.GetHeight;
+end;
+
+function TPTCConsole.GetPitch: Integer;
+begin
+  Check;
+  Result := FConsole.GetPitch;
+end;
+
+function TPTCConsole.GetPages: Integer;
+begin
+  Check;
+  Result := FConsole.GetPages;
+end;
+
+function TPTCConsole.GetArea: TPTCArea;
+begin
+  Check;
+  Result := FConsole.GetArea;
+end;
+
+function TPTCConsole.Clip: TPTCArea;
+begin
+  Check;
+  Result := FConsole.Clip;
+end;
+
+function TPTCConsole.GetFormat: TPTCFormat;
+begin
+  Check;
+  Result := FConsole.GetFormat;
+end;
+
+function TPTCConsole.GetName: string;
+begin
+  Result := '';
+  if Assigned(FConsole) then
+    Result := FConsole.GetName
+  else
+{$IFDEF GO32V2}
+    Result := 'DOS';
+{$ENDIF GO32V2}
+{$IFDEF WIN32}
+    Result := 'Win32';
+{$ENDIF WIN32}
+{$IFDEF WIN64}
+    Result := 'Win64';
+{$ENDIF WIN64}
+{$IFDEF LINUX}
+    Result := 'Linux';
+{$ENDIF LINUX}
+end;
+
+function TPTCConsole.GetTitle: string;
+begin
+  Check;
+  Result := FConsole.GetTitle;
+end;
+
+function TPTCConsole.GetInformation: string;
+begin
+  Check;
+  Result := FConsole.GetInformation;
+end;
+
+function TPTCConsole.NextEvent(var AEvent: TPTCEvent; AWait: Boolean; const AEventMask: TPTCEventMask): Boolean;
+begin
+  Check;
+  Result := FConsole.NextEvent(AEvent, AWait, AEventMask);
+end;
+
+function TPTCConsole.PeekEvent(AWait: Boolean; const AEventMask: TPTCEventMask): TPTCEvent;
+begin
+  Check;
+  Result := FConsole.PeekEvent(AWait, AEventMask);
+end;
+
+function TPTCConsole.ConsoleCreate(AIndex: Integer): TPTCBaseConsole;
+begin
+  Result := nil;
+  if (AIndex >= Low(ConsoleTypes)) and (AIndex <= High(ConsoleTypes)) then
+    Result := ConsoleTypes[AIndex].ConsoleClass.Create;
+
+  if Result <> nil then
+    Result.KeyReleaseEnabled := KeyReleaseEnabled;
+end;
+
+function TPTCConsole.ConsoleCreate(const AName: string): TPTCBaseConsole;
+var
+  I, J: Integer;
+begin
+  Result := nil;
+
+  if AName = '' then
+    exit;
+
+  for I := Low(ConsoleTypes) to High(ConsoleTypes) do
+    for J := Low(ConsoleTypes[I].Names) to High(ConsoleTypes[I].Names) do
+      if AName = ConsoleTypes[I].Names[J] then
+      begin
+        Result := ConsoleTypes[I].ConsoleClass.Create;
+
+        if Result <> nil then
+        begin
+          Result.KeyReleaseEnabled := KeyReleaseEnabled;
+          exit;
+        end;
+      end;
+end;
+
+procedure TPTCConsole.Check;
+begin
+  if FConsole = nil then
+    raise TPTCError.Create('console is not open (core)');
+end;

packages/ptc/src/core/copyd.inc

@@ -0,0 +1,50 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCCopy = class
+  private
+    FHandle: THermesConverterHandle;
+    FFlags: LongInt;
+
+    procedure Update;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure Request(const ASource, ADestination: TPTCFormat);
+    procedure Palette(const ASource, ADestination: TPTCPalette);
+    procedure Copy(const ASourcePixels: Pointer; ASourceX, ASourceY,
+                   ASourceWidth, ASourceHeight, ASourcePitch: Integer;
+                   ADestinationPixels: Pointer; ADestinationX, ADestinationY,
+                   ADestinationWidth, ADestinationHeight, ADestinationPitch: Integer);
+    function Option(const AOption: String): Boolean;
+  end;

packages/ptc/src/core/copyi.inc

@@ -0,0 +1,131 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+constructor TPTCCopy.Create;
+begin
+  if not Hermes_Init then
+    raise TPTCError.Create('could not initialize hermes');
+  FFlags := HERMES_CONVERT_NORMAL;
+  FHandle := Hermes_ConverterInstance(FFlags);
+  if FHandle = nil then
+    raise TPTCError.Create('could not create hermes converter instance');
+end;
+
+destructor TPTCCopy.Destroy;
+begin
+  Hermes_ConverterReturn(FHandle);
+  Hermes_Done;
+  inherited Destroy;
+end;
+
+procedure TPTCCopy.Request(const ASource, ADestination: TPTCFormat);
+var
+  hermes_source_format, hermes_destination_format: PHermesFormat;
+begin
+  hermes_source_format := @ASource.FFormat;
+  hermes_destination_format := @ADestination.FFormat;
+  if not Hermes_ConverterRequest(FHandle, hermes_source_format,
+     hermes_destination_format) then
+    raise TPTCError.Create('unsupported hermes pixel format conversion');
+end;
+
+procedure TPTCCopy.Palette(const ASource, ADestination: TPTCPalette);
+begin
+  if not Hermes_ConverterPalette(FHandle, ASource.FHandle,
+         ADestination.FHandle) then
+    raise TPTCError.Create('could not set hermes conversion palettes');
+end;
+
+procedure TPTCCopy.copy(const ASourcePixels: Pointer; ASourceX, ASourceY,
+                   ASourceWidth, ASourceHeight, ASourcePitch: Integer;
+                   ADestinationPixels: Pointer; ADestinationX, ADestinationY,
+                   ADestinationWidth, ADestinationHeight, ADestinationPitch: Integer);
+begin
+{$IFDEF DEBUG}
+{
+  This checking is performed only when DEBUG is defined,
+  and can be used to track down errors early caused by passing
+  nil pointers to surface and console functions.
+
+  Even though technicially it is the users responsibility
+  to ensure that all pointers are non-nil, it is useful
+  to provide a check here in debug build to prevent such
+  bugs from ever occuring.
+
+  The checking function also tests that the source and destination
+  pointers are not the same, a bug that can be caused by copying
+  a surface to itself. The nature of the copy routine is that
+  this operation is undefined if the source and destination memory
+  areas overlap.
+}
+  if ASourcePixels = nil then
+    raise TPTCError.Create('nil source pointer in copy');
+  if ADestinationPixels = nil then
+    raise TPTCError.Create('nil destination pointer in copy');
+  if ASourcePixels = ADestinationPixels then
+    raise TPTCError.Create('identical source and destination pointers in copy');
+{$ELSE DEBUG}
+    { in release build no checking is performed for the sake of efficiency. }
+{$ENDIF DEBUG}
+  if not Hermes_ConverterCopy(FHandle, ASourcePixels, ASourceX, ASourceY,
+          ASourceWidth, ASourceHeight, ASourcePitch, ADestinationPixels,
+          ADestinationX, ADestinationY, ADestinationWidth, ADestinationHeight,
+          ADestinationPitch) then
+    raise TPTCError.Create('hermes conversion failure');
+end;
+
+function TPTCCopy.Option(const AOption: String): Boolean;
+begin
+  if (AOption = 'attempt dithering') and ((FFlags and HERMES_CONVERT_DITHER) = 0) then
+  begin
+    FFlags := FFlags or HERMES_CONVERT_DITHER;
+    Update;
+    Result := True;
+    exit;
+  end;
+  if (AOption = 'disable dithering') and ((FFlags and HERMES_CONVERT_DITHER) <> 0) then
+  begin
+    FFlags := FFlags and (not HERMES_CONVERT_DITHER);
+    Update;
+    Result := True;
+    exit;
+  end;
+  Result := False;
+end;
+
+procedure TPTCCopy.Update;
+begin
+  Hermes_ConverterReturn(FHandle);
+  FHandle := Hermes_ConverterInstance(FFlags);
+  if FHandle = nil then
+    raise TPTCError.Create('could not update hermes converter instance');
+end;

packages/ptc/src/core/errord.inc

@@ -0,0 +1,47 @@
+{
+    Free Pascal port of the OpenPTC C++ library.
+    Copyright (C) 2001-2006  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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCError = class
+  private
+    FMessage: string;
+  public
+    constructor Create;
+    constructor Create(const AMessage: String);
+    constructor Create(const AMessage: string; const AError: TPTCError);
+    constructor Create(const AError: TPTCError);
+    destructor Destroy; override;
+    procedure Assign(const AError: TPTCError);
+    function Equals(const AError: TPTCError): Boolean;
+    procedure Report;
+    property Message: string read FMessage;
+  end;

packages/ptc/src/errori.inc → packages/ptc/src/core/errori.inc

@@ -6,7 +6,19 @@
     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.
+    version 2.1 of the License, or (at your option) any later version
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,63 +30,53 @@
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 }
 
-Constructor TPTCError.Create;
-
-Begin
+constructor TPTCError.Create;
+begin
   FMessage := '';
-End;
-
-Constructor TPTCError.Create(Const AMessage : String);
+end;
 
-Begin
+constructor TPTCError.Create(const AMessage: String);
+begin
   FMessage := AMessage;
   LOG('error', Self);
-End;
-
-Constructor TPTCError.Create(Const AMessage : String; Const AError : TPTCError);
+end;
 
-Begin
+constructor TPTCError.Create(const AMessage: string; const AError: TPTCError);
+begin
   FMessage := AMessage + #10 + AError.FMessage;
   LOG('composite error', Self);
-End;
+end;
 
-Constructor TPTCError.Create(Const AError : TPTCError);
-
-Begin
+constructor TPTCError.Create(const AError: TPTCError);
+begin
   FMessage := AError.FMessage;
-End;
-
-Destructor TPTCError.Destroy;
+end;
 
-Begin
-  Inherited Destroy;
-End;
+destructor TPTCError.Destroy;
+begin
+  inherited Destroy;
+end;
 
-Procedure TPTCError.Assign(Const AError : TPTCError);
-
-Begin
+procedure TPTCError.Assign(const AError: TPTCError);
+begin
   FMessage := AError.FMessage;
-End;
-
-Function TPTCError.Equals(Const AError : TPTCError) : Boolean;
+end;
 
-Begin
+function TPTCError.Equals(const AError: TPTCError): Boolean;
+begin
   Equals := (FMessage = AError.FMessage);
-End;
-
-Procedure TPTCError.Report;
+end;
 
+procedure TPTCError.Report;
 {$IFDEF Win32}
-Var
-  txt : AnsiString;
+var
+  txt: AnsiString;
 {$ENDIF Win32}
-
 {$IFDEF WinCE}
-Var
-  txt : WideString;
+var
+  txt: WideString;
 {$ENDIF WinCE}
-
-Begin
+begin
   LOG('error report', Self);
   {$IFDEF GO32V2}
   RestoreTextMode;
@@ -82,14 +84,14 @@ Begin
   {$ENDIF GO32V2}
 
   {$IFDEF Win32}
-  Win32Cursor_resurrect;
+//  Win32Cursor_resurrect;
   txt := FMessage;
-  MessageBox(0, PChar(txt), 'Error', MB_OK Or MB_ICONERROR Or MB_SETFOREGROUND Or MB_TOPMOST);
+  MessageBox(0, PChar(txt), 'Error', MB_OK or MB_ICONERROR or MB_SETFOREGROUND or MB_TOPMOST);
   {$ENDIF Win32}
 
   {$IFDEF WinCE}
   txt := FMessage;
-  MessageBox(0, PWideChar(txt), 'Error', MB_OK Or MB_ICONERROR Or MB_SETFOREGROUND Or MB_TOPMOST);
+  MessageBox(0, PWideChar(txt), 'Error', MB_OK or MB_ICONERROR or MB_SETFOREGROUND or MB_TOPMOST);
   {$ENDIF WinCE}
 
   {$IFDEF UNIX}
@@ -97,4 +99,4 @@ Begin
   {$ENDIF UNIX}
 
   Halt(1);
-End;
+end;

packages/ptc/src/core/eventd.inc

@@ -0,0 +1,50 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCEventType = (PTCKeyEvent, PTCMouseEvent{, PTCExposeEvent});
+  TPTCEventMask = set of TPTCEventType;
+  TPTCEvent = class
+  protected
+    function GetType: TPTCEventType; virtual; abstract;
+  public
+    property EventType: TPTCEventType read GetType;
+  end;
+
+const
+  PTCAnyEvent: TPTCEventMask = [PTCKeyEvent, PTCMouseEvent{, PTCExposeEvent}];
+
+{type
+  TPTCExposeEvent = Class(TPTCEvent)
+  protected
+    function GetType: TPTCEventType; override;
+  End;}

packages/ptc/src/core/eventi.inc

@@ -0,0 +1,143 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+{function TPTCExposeEvent.GetType: TPTCEventType;
+begin
+  Result := PTCExposeEvent;
+end;}
+
+type
+  PEventLinkedList = ^TEventLinkedList;
+  TEventLinkedList = record
+    Event: TPTCEvent;
+    Next: PEventLinkedList;
+  end;
+  TEventQueue = class
+  private
+    FHead, FTail: PEventLinkedList;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure AddEvent(event: TPTCEvent);
+    function PeekEvent(const EventMask: TPTCEventMask): TPTCEvent;
+    function NextEvent(const EventMask: TPTCEventMask): TPTCEvent;
+  end;
+
+constructor TEventQueue.Create;
+begin
+  FHead := nil;
+  FTail := nil;
+end;
+
+destructor TEventQueue.Destroy;
+var
+  p, pnext: PEventLinkedList;
+begin
+  p := FHead;
+  while p <> nil do
+  begin
+    FreeAndNil(p^.Event);
+    pnext := p^.Next;
+    Dispose(p);
+    p := pnext;
+  end;
+  inherited Destroy;
+end;
+
+procedure TEventQueue.AddEvent(event: TPTCEvent);
+var
+  tmp: PEventLinkedList;
+begin
+  New(tmp);
+  FillChar(tmp^, SizeOf(tmp^), 0);
+  tmp^.Next := nil;
+  tmp^.Event := event;
+
+  if FTail <> nil then
+  begin
+    FTail^.Next := tmp;
+    FTail := tmp;
+  end
+  else
+  begin { FTail = nil }
+    FHead := tmp;
+    FTail := tmp;
+  end;
+end;
+
+function TEventQueue.PeekEvent(const EventMask: TPTCEventMask): TPTCEvent;
+var
+  p: PEventLinkedList;
+begin
+  p := FHead;
+  while p <> nil do
+  begin
+    if p^.Event.EventType In EventMask then
+    begin
+      Result := p^.Event;
+      exit;
+    end;
+    p := p^.Next;
+  end;
+
+  Result := nil;
+end;
+
+function TEventQueue.NextEvent(const EventMask: TPTCEventMask): TPTCEvent;
+var
+  prev, p: PEventLinkedList;
+begin
+  prev := nil;
+  p := FHead;
+  while p <> nil do
+  begin
+    if p^.Event.EventType In EventMask then
+    begin
+      Result := p^.Event;
+
+      { delete the element from the linked list }
+      if prev <> nil then
+        prev^.Next := p^.Next
+      else
+        FHead := p^.Next;
+      if p^.Next = nil then
+        FTail := prev;
+      Dispose(p);
+
+      exit;
+    end;
+    prev := p;
+    p := p^.Next;
+  end;
+
+  Result := nil;
+end;

packages/ptc/src/core/formatd.inc

@@ -0,0 +1,57 @@
+{
+    Free Pascal port of the OpenPTC C++ library.
+    Copyright (C) 2001-2006  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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCFormat = class
+  private
+    FFormat: THermesFormat;
+    function GetDirect: Boolean;
+    function GetBytes: Integer;
+  public
+    constructor Create;
+    constructor Create(ABits: Integer);
+    constructor Create(ABits: Integer;
+                       ARedMask, AGreenMask, ABlueMask: Uint32;
+                       AAlphaMask: Uint32 = 0);
+    constructor Create(const format: TPTCFormat);
+    destructor Destroy; override;
+    procedure Assign(const format: TPTCFormat);
+    function Equals(const format: TPTCFormat): Boolean;
+    property R: Uint32 read FFormat.r;
+    property G: Uint32 read FFormat.g;
+    property B: Uint32 read FFormat.b;
+    property A: Uint32 read FFormat.a;
+    property Bits: Integer read FFormat.bits;
+    property Indexed: Boolean read FFormat.indexed;
+    property Direct: Boolean read GetDirect;
+    property Bytes: Integer read GetBytes;
+  end;

packages/ptc/src/core/formati.inc

@@ -0,0 +1,125 @@
+{
+    Free Pascal port of the OpenPTC C++ library.
+    Copyright (C) 2001-2006  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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+constructor TPTCFormat.Create;
+begin
+  { defaults }
+  FFormat.r := 0;
+  FFormat.g := 0;
+  FFormat.b := 0;
+  FFormat.a := 0;
+  FFormat.bits := 0;
+  FFormat.indexed := False;
+
+  { initialize hermes }
+  if not Hermes_Init then
+    raise TPTCError.Create('could not initialize hermes');
+end;
+
+constructor TPTCFormat.Create(ABits: Integer);
+begin
+  { check bits per pixel }
+  if ABits <> 8 then
+    raise TPTCError.Create('unsupported bits per pixel');
+
+  { indexed color }
+  FFormat.r := 0;
+  FFormat.g := 0;
+  FFormat.b := 0;
+  FFormat.a := 0;
+  FFormat.bits := ABits;
+  FFormat.indexed := True;
+
+  { initialize hermes }
+  if not Hermes_Init then
+    raise TPTCError.Create('could not initialize hermes');
+end;
+
+constructor TPTCFormat.Create(ABits: Integer;
+                              ARedMask, AGreenMask, ABlueMask: Uint32;
+                              AAlphaMask: Uint32 = 0);
+begin
+  { check bits per pixel }
+  if ((ABits and 7) <> 0) or (ABits <= 0) or (ABits > 32) then
+    raise TPTCError.Create('unsupported bits per pixel');
+
+  { direct color }
+  FFormat.r := ARedMask;
+  FFormat.g := AGreenMask;
+  FFormat.b := ABlueMask;
+  FFormat.a := AAlphaMask;
+  FFormat.bits := ABits;
+  FFormat.indexed := False;
+
+  { initialize hermes }
+  if not Hermes_Init then
+    raise TPTCError.Create('could not initialize hermes');
+end;
+
+constructor TPTCFormat.Create(const format: TPTCFormat);
+begin
+  { initialize hermes }
+  if not Hermes_Init then
+    raise TPTCError.Create('could not initialize hermes');
+
+  Hermes_FormatCopy(@format.FFormat, @FFormat)
+end;
+
+{$INFO TODO: check what happens if Hermes_Init blows up in the constructor...}
+destructor TPTCFormat.Destroy;
+
+begin
+  Hermes_Done;
+  inherited Destroy;
+end;
+
+procedure TPTCFormat.Assign(const format: TPTCFormat);
+begin
+  if Self = format then
+    exit;
+  Hermes_FormatCopy(@format.Fformat, @Fformat);
+end;
+
+function TPTCFormat.Equals(const format: TPTCFormat): Boolean;
+begin
+  Result := Hermes_FormatEquals(@format.FFormat, @FFormat);
+end;
+
+function TPTCFormat.GetDirect: Boolean;
+begin
+  Result := not FFormat.indexed;
+end;
+
+function TPTCFormat.GetBytes: Integer;
+begin
+  Result := FFormat.bits shr 3;
+end;

packages/ptc/src/keyeventd.inc → packages/ptc/src/core/keyeventd.inc

@@ -6,7 +6,19 @@
     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.
+    version 2.1 of the License, or (at your option) any later version
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,43 +30,43 @@
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 }
 
-Type
-  TPTCKeyEvent=Class(TPTCEvent)
-  Private
-    FCode : Integer;
-    FUnicode : Integer;
-    FAlt : Boolean;
-    FShift : Boolean;
-    FControl : Boolean;
-    FPress : Boolean;
+type
+  TPTCKeyEvent = class(TPTCEvent)
+  private
+    FCode: Integer;
+    FUnicode: Integer;
+    FAlt: Boolean;
+    FShift: Boolean;
+    FControl: Boolean;
+    FPress: Boolean;
 
-    Function GetRelease : Boolean;
-  Protected
-    Function GetType : TPTCEventType; Override;
-  Public
-    Constructor Create;
-    Constructor Create(ACode : Integer);
-    Constructor Create(ACode, AUnicode : Integer);
-    Constructor Create(ACode, AUnicode : Integer; APress : Boolean);
-    Constructor Create(ACode : Integer; AAlt, AShift, AControl : Boolean);
-    Constructor Create(ACode : Integer; AAlt, AShift, AControl, APress : Boolean);
-    Constructor Create(ACode, AUnicode : Integer;
-                       AAlt, AShift, AControl : Boolean);
-    Constructor Create(ACode, AUnicode : Integer;
-                       AAlt, AShift, AControl, APress : Boolean);
-    Constructor Create(Const AKey : TPTCKeyEvent);
-    Procedure Assign(Const AKey : TPTCKeyEvent);
-    Function Equals(Const AKey : TPTCKeyEvent) : Boolean;
-    Property Code : Integer read FCode;
-    Property Unicode : Integer read FUnicode;
-    Property Alt : Boolean read FAlt;
-    Property Shift : Boolean read FShift;
-    Property Control : Boolean read FControl;
-    Property Press : Boolean read FPress;
-    Property Release : Boolean read GetRelease;
-  End;
+    function GetRelease: Boolean;
+  protected
+    function GetType: TPTCEventType; override;
+  public
+    constructor Create;
+    constructor Create(ACode: Integer);
+    constructor Create(ACode, AUnicode: Integer);
+    constructor Create(ACode, AUnicode: Integer; APress: Boolean);
+    constructor Create(ACode: Integer; AAlt, AShift, AControl: Boolean);
+    constructor Create(ACode: Integer; AAlt, AShift, AControl, APress: Boolean);
+    constructor Create(ACode, AUnicode: Integer;
+                       AAlt, AShift, AControl: Boolean);
+    constructor Create(ACode, AUnicode: Integer;
+                       AAlt, AShift, AControl, APress: Boolean);
+    constructor Create(const AKey: TPTCKeyEvent);
+    procedure Assign(const AKey: TPTCKeyEvent);
+    function Equals(const AKey: TPTCKeyEvent): Boolean;
+    property Code: Integer read FCode;
+    property Unicode: Integer read FUnicode;
+    property Alt: Boolean read FAlt;
+    property Shift: Boolean read FShift;
+    property Control: Boolean read FControl;
+    property Press: Boolean read FPress;
+    property Release: Boolean read GetRelease;
+  end;
 
-Const
+const
   PTCKEY_UNDEFINED    = $00;
   PTCKEY_CANCEL       = $03;
   PTCKEY_BACKSPACE    = $08; {'\b'}

packages/ptc/src/keyeventi.inc → packages/ptc/src/core/keyeventi.inc

@@ -6,7 +6,19 @@
     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.
+    version 2.1 of the License, or (at your option) any later version
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,136 +30,123 @@
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 }
 
-Function TPTCKeyEvent.GetType : TPTCEventType;
-
-Begin
+function TPTCKeyEvent.GetType: TPTCEventType;
+begin
   Result := PTCKeyEvent;
-End;
-
-Constructor TPTCKeyEvent.Create;
+end;
 
-Begin
+constructor TPTCKeyEvent.Create;
+begin
   FCode    := Integer(PTCKEY_UNDEFINED);
   FUnicode := -1;
   FAlt     := False;
   FShift   := False;
   FControl := False;
   FPress   := True;
-End;
+end;
 
-Constructor TPTCKeyEvent.Create(ACode : Integer);
-
-Begin
+constructor TPTCKeyEvent.Create(ACode: Integer);
+begin
   FCode    := ACode;
   FUnicode := -1;
   FAlt     := False;
   FShift   := False;
   FControl := False;
   FPress   := True;
-End;
-
-Constructor TPTCKeyEvent.Create(ACode, AUnicode : Integer);
+end;
 
-Begin
+constructor TPTCKeyEvent.Create(ACode, AUnicode: Integer);
+begin
   FCode    := ACode;
   FUnicode := AUnicode;
   FAlt     := False;
   FShift   := False;
   FControl := False;
   FPress   := True;
-End;
+end;
 
-Constructor TPTCKeyEvent.Create(ACode, AUnicode : Integer; APress : Boolean);
-
-Begin
+constructor TPTCKeyEvent.Create(ACode, AUnicode: Integer; APress: Boolean);
+begin
   FCode    := ACode;
   FUnicode := AUnicode;
   FAlt     := False;
   FShift   := False;
   FControl := False;
   FPress   := APress;
-End;
-
-Constructor TPTCKeyEvent.Create(ACode : Integer; AAlt, AShift, AControl : Boolean);
+end;
 
-Begin
+constructor TPTCKeyEvent.Create(ACode: Integer; AAlt, AShift, AControl: Boolean);
+begin
   FCode    := ACode;
   FUnicode := -1;
   FAlt     := AAlt;
   FShift   := AShift;
   FControl := AControl;
   FPress   := True;
-End;
-
-Constructor TPTCKeyEvent.Create(ACode : Integer; AAlt, AShift, AControl, APress : Boolean);
+end;
 
-Begin
+constructor TPTCKeyEvent.Create(ACode: Integer; AAlt, AShift, AControl, APress: Boolean);
+begin
   FCode    := ACode;
   FUnicode := -1;
   FAlt     := AAlt;
   FShift   := AShift;
   FControl := AControl;
   FPress   := APress;
-End;
+end;
 
-Constructor TPTCKeyEvent.Create(ACode, AUnicode : Integer; AAlt, AShift, AControl : Boolean);
-
-Begin
+constructor TPTCKeyEvent.Create(ACode, AUnicode: Integer; AAlt, AShift, AControl: Boolean);
+begin
   FCode    := ACode;
   FUnicode := AUnicode;
   FAlt     := AAlt;
   FShift   := AShift;
   FControl := AControl;
   FPress   := True;
-End;
-
-Constructor TPTCKeyEvent.Create(ACode, AUnicode : Integer;
-                                AAlt, AShift, AControl, APress : Boolean);
+end;
 
-Begin
+constructor TPTCKeyEvent.Create(ACode, AUnicode: Integer;
+                                AAlt, AShift, AControl, APress: Boolean);
+begin
   FCode    := ACode;
   FUnicode := AUnicode;
   FAlt     := AAlt;
   FShift   := AShift;
   FControl := AControl;
   FPress   := APress;
-End;
+end;
 
-Constructor TPTCKeyEvent.Create(Const AKey : TPTCKeyEvent);
-
-Begin
+constructor TPTCKeyEvent.Create(const AKey: TPTCKeyEvent);
+begin
   FCode    := AKey.Code;
   FUnicode := AKey.Unicode;
   FAlt     := AKey.Alt;
   FShift   := AKey.Shift;
   FControl := AKey.Control;
   FPress   := AKey.Press;
-End;
-
-Procedure TPTCKeyEvent.Assign(Const AKey : TPTCKeyEvent);
+end;
 
-Begin
+procedure TPTCKeyEvent.Assign(const AKey: TPTCKeyEvent);
+begin
   FCode    := AKey.Code;
   FUnicode := AKey.Unicode;
   FAlt     := AKey.Alt;
   FShift   := AKey.Shift;
   FControl := AKey.Control;
   FPress   := AKey.Press;
-End;
-
-Function TPTCKeyEvent.Equals(Const AKey : TPTCKeyEvent) : Boolean;
-
-Begin
-  Result := (FCode    = AKey.FCode) And
-            (FUnicode = AKey.FUnicode) And
-            (FAlt     = AKey.FAlt) And
-            (FShift   = AKey.FShift) And
-            (FControl = AKey.FControl) And
+end;
+
+function TPTCKeyEvent.Equals(const AKey: TPTCKeyEvent): Boolean;
+begin
+  Result := (FCode    = AKey.FCode) and
+            (FUnicode = AKey.FUnicode) and
+            (FAlt     = AKey.FAlt) and
+            (FShift   = AKey.FShift) and
+            (FControl = AKey.FControl) and
             (FPress   = AKey.FPress);
-End;
-
-Function TPTCKeyEvent.GetRelease : Boolean;
+end;
 
-Begin
-  Result := Not FPress;
-End;
+function TPTCKeyEvent.GetRelease: Boolean;
+begin
+  Result := not FPress;
+end;

packages/ptc/src/log.inc → packages/ptc/src/core/log.inc

@@ -6,7 +6,19 @@
     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.
+    version 2.1 of the License, or (at your option) any later version
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -19,191 +31,176 @@
 }
 
 {$IFNDEF WinCE}
-Const
+const
   LOG_filename = 'ptcpas.log';
 {$ELSE WinCE}
-Function LOG_filename : WideString;
-
-Var
-  RequiredBufferLength : DWord;
-  ReturnedPathLength : DWord;
-  TempPathBuf : PWideChar;
-  dummy : Byte;
-
-Begin
+function LOG_filename: WideString;
+var
+  RequiredBufferLength: DWord;
+  ReturnedPathLength: DWord;
+  TempPathBuf: PWideChar;
+  dummy: Byte;
+begin
   RequiredBufferLength := GetTempPathW(0, @dummy);
   TempPathBuf := GetMem(RequiredBufferLength * SizeOf(WideChar));
-  Try
+  try
     ReturnedPathLength := GetTempPathW(RequiredBufferLength, TempPathBuf);
 
-    If ReturnedPathLength > RequiredBufferLength Then
-    Begin
+    if ReturnedPathLength > RequiredBufferLength then
+    begin
       { The temp path length increased between 2 consecutive calls to GetTempPath?! }
       Result := '';
-      Exit;
-    End;
+      exit;
+    end;
 
     Result := TempPathBuf;
     Result := Result + 'ptcpas.log';
-  Finally
+  finally
     FreeMem(TempPathBuf);
-  End;
-End;
+  end;
+end;
 {$ENDIF WinCE}
 
-Var
-  LOG_create : Boolean = True;
-  LOG_enabled : Boolean =
+var
+  LOG_create: Boolean = True;
+  LOG_enabled: Boolean =
   {$IFDEF DEBUG}
     True;
   {$ELSE DEBUG}
     False;
   {$ENDIF DEBUG}
-  LOG_file : Text;
+  LOG_file: Text;
 
-Procedure LOG_open;
-
-Begin
+procedure LOG_open;
+begin
   AssignFile(LOG_file, LOG_filename);
-  If LOG_create Then
-  Begin
+  if LOG_create then
+  begin
     Rewrite(LOG_file);
     Writeln(LOG_file, '[log start]');
     LOG_create := False;
-  End
-  Else
+  end
+  else
     Append(LOG_file);
-End;
-
-Procedure LOG_close;
+end;
 
-Begin
+procedure LOG_close;
+begin
   CloseFile(LOG_file);
-End;
+end;
 
-Procedure LOG(Const message : String);
-
-Begin
-  If Not LOG_enabled Then
-    Exit;
+procedure LOG(const message: String);
+begin
+  if not LOG_enabled then
+    exit;
   LOG_open;
   Writeln(LOG_file, message);
   LOG_close;
-End;
-
-Procedure LOG(Const message : String; data : Boolean);
+end;
 
-Begin
-  If Not LOG_enabled Then
-    Exit;
+procedure LOG(const message: string; data: Boolean);
+begin
+  if not LOG_enabled then
+    exit;
   LOG_open;
   Write(LOG_file, message, ' = ');
-  If data Then
+  if data then
     Writeln(LOG_file, 'true')
-  Else
+  else
     Writeln(LOG_file, 'false');
   LOG_close;
-End;
+end;
 
-Procedure LOG(Const message : String; data : Integer);
-
-Begin
-  If Not LOG_enabled Then
-    Exit;
+procedure LOG(const message: string; data: Integer);
+begin
+  if not LOG_enabled then
+    exit;
   LOG_open;
   Writeln(LOG_file, message, ' = ', data);
   LOG_close;
-End;
-
-Procedure LOG(Const message : String; data : DWord);
+end;
 
-Begin
-  If Not LOG_enabled Then
-    Exit;
+procedure LOG(const message: string; data: DWord);
+begin
+  if not LOG_enabled then
+    exit;
   LOG_open;
   Writeln(LOG_file, message, ' = ', data);
   LOG_close;
-End;
+end;
 
-Procedure LOG(Const message : String; data : Int64);
-
-Begin
-  If Not LOG_enabled Then
-    Exit;
+procedure LOG(const message: string; data: Int64);
+begin
+  if not LOG_enabled then
+    exit;
   LOG_open;
   Writeln(LOG_file, message, ' = ', data);
   LOG_close;
-End;
-
-Procedure LOG(Const message : String; data : QWord);
+end;
 
-Begin
-  If Not LOG_enabled Then
-    Exit;
+procedure LOG(const message: string; data: QWord);
+begin
+  if not LOG_enabled then
+    exit;
   LOG_open;
   Writeln(LOG_file, message, ' = ', data);
   LOG_close;
-End;
+end;
 
-Procedure LOG(Const message : String; data : Single);
-
-Begin
-  If Not LOG_enabled Then
-    Exit;
+procedure LOG(const message: string; data: Single);
+begin
+  if not LOG_enabled then
+    exit;
   LOG_open;
   Writeln(LOG_file, message, ' = ', data);
   LOG_close;
-End;
-
-Procedure LOG(Const message : String; data : Double);
+end;
 
-Begin
-  If Not LOG_enabled Then
-    Exit;
+procedure LOG(const message: string; data: Double);
+begin
+  if not LOG_enabled then
+    exit;
   LOG_open;
   Writeln(LOG_file, message, ' = ', data);
   LOG_close;
-End;
+end;
 
-Procedure LOG(Const message : String; Const data : String);
-
-Begin
-  If Not LOG_enabled Then
-    Exit;
+procedure LOG(const message: string; const data: String);
+begin
+  if not LOG_enabled then
+    exit;
   LOG_open;
   Writeln(LOG_file, message, ' = ', data);
   LOG_close;
-End;
-
-Procedure LOG(Const message : String; data : TPTCFormat);
+end;
 
-Begin
-  If Not LOG_enabled Then
-    Exit;
+procedure LOG(const message: string; data: TPTCFormat);
+begin
+  if not LOG_enabled then
+    exit;
   LOG_open;
   Write(LOG_file, message, ' = Format(');
-  If data = Nil Then
+  if data = nil then
     Write(LOG_file, 'NIL')
-  Else
-  Begin
+  else
+  begin
     Write(LOG_file, data.bits:2);
-    If data.direct Then
-    Begin
+    if data.direct then
+    begin
       Write(LOG_file, ',$', HexStr(data.r, 8), ',$', HexStr(data.g, 8), ',$', HexStr(data.b, 8));
-      If data.a <> 0 Then
+      if data.a <> 0 then
         Write(LOG_file, ',$', HexStr(data.a, 8));
-    End;
-  End;
+    end;
+  end;
   Writeln(LOG_file, ')');
   LOG_close;
-End;
-
-Procedure LOG(Const message : String; data : TPTCError);
+end;
 
-Begin
-  If Not LOG_enabled Then
-    Exit;
+procedure LOG(const message: string; data: TPTCError);
+begin
+  if not LOG_enabled then
+    exit;
   LOG_open;
   Writeln(LOG_file, message, ': ', data.message);
   LOG_close;
-End;
+end;

packages/ptc/src/core/moded.inc

@@ -0,0 +1,52 @@
+{
+    Free Pascal port of the OpenPTC C++ library.
+    Copyright (C) 2001-2006  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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  PPTCMode=^TPTCMode;
+  TPTCMode = class
+  private
+    FValid: Boolean;
+    FWidth: Integer;
+    FHeight: Integer;
+    FFormat: TPTCFormat;
+  public
+    constructor Create;
+    constructor Create(AWidth, AHeight: Integer; const AFormat: TPTCFormat);
+    constructor Create(const mode: TPTCMode);
+    destructor Destroy; override;
+    procedure Assign(const mode: TPTCMode);
+    function Equals(const mode: TPTCMode): Boolean;
+    property Valid: Boolean read FValid;
+    property Width: Integer read FWidth;
+    property Height: Integer read FHeight;
+    property Format: TPTCFormat read FFormat;
+  end;

packages/ptc/src/modei.inc → packages/ptc/src/core/modei.inc

@@ -6,7 +6,19 @@
     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.
+    version 2.1 of the License, or (at your option) any later version
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,57 +30,51 @@
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 }
 
-Type
-  TPTCModeDynArray = Array Of TPTCMode;
+type
+  TPTCModeDynArray = array of TPTCMode;
 
-Constructor TPTCMode.Create;
-
-Begin
+constructor TPTCMode.Create;
+begin
   FFormat := TPTCFormat.Create;
   FWidth := 0;
   FHeight := 0;
   FValid := False;
-End;
-
-Constructor TPTCMode.Create(AWidth, AHeight : Integer; Const AFormat : TPTCFormat);
+end;
 
-Begin
+constructor TPTCMode.Create(AWidth, AHeight: Integer; const AFormat: TPTCFormat);
+begin
   FFormat := TPTCFormat.Create(AFormat);
   FWidth := AWidth;
   FHeight := AHeight;
   FValid := True;
-End;
-
-Constructor TPTCMode.Create(Const mode : TPTCMode);
+end;
 
-Begin
+constructor TPTCMode.Create(const mode: TPTCMode);
+begin
   FFormat := TPTCFormat.Create(mode.FFormat);
   FWidth := mode.FWidth;
   FHeight := mode.FHeight;
   FValid := mode.FValid;
-End;
+end;
 
-Destructor TPTCMode.Destroy;
-
-Begin
+destructor TPTCMode.Destroy;
+begin
   FFormat.Free;
-  Inherited Destroy;
-End;
-
-Procedure TPTCMode.Assign(Const mode : TPTCMode);
+  inherited Destroy;
+end;
 
-Begin
+procedure TPTCMode.Assign(const mode: TPTCMode);
+begin
   FFormat.Assign(mode.FFormat);
   FWidth := mode.FWidth;
   FHeight := mode.FHeight;
   FValid := mode.FValid;
-End;
-
-Function TPTCMode.Equals(Const mode : TPTCMode) : Boolean;
+end;
 
-Begin
-  Result := (FValid = mode.FValid) And
-            (FWidth = mode.FWidth) And
-            (FHeight = mode.FHeight) And
+function TPTCMode.Equals(const mode: TPTCMode): Boolean;
+begin
+  Result := (FValid = mode.FValid) and
+            (FWidth = mode.FWidth) and
+            (FHeight = mode.FHeight) and
              FFormat.Equals(mode.FFormat);
-End;
+end;

packages/ptc/src/core/mouseeventd.inc

@@ -0,0 +1,68 @@
+{
+    Free Pascal port of the OpenPTC C++ library.
+    Copyright (C) 2001-2006  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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+{todo  TPTCMouseCursor = (PTCMouseCursorDefault,
+                     PTCMouseCursorAlwaysVisible,
+                     PTCMouseCursorAlwaysInvisible);}
+  TPTCMouseButton = (PTCMouseButton1, { left mouse button }
+                     PTCMouseButton2, { right mouse button }
+                     PTCMouseButton3, { middle mouse button }
+                     PTCMouseButton4,
+                     PTCMouseButton5);
+  TPTCMouseButtonState = Set of TPTCMouseButton;
+  TPTCMouseEvent = Class(TPTCEvent)
+  private
+    FX, FY: Integer;
+    FDeltaX, FDeltaY: Integer;
+    FButtonState: TPTCMouseButtonState;
+  protected
+    function GetType: TPTCEventType; override;
+  public
+    constructor Create(AX, AY, ADeltaX, ADeltaY: Integer; AButtonState: TPTCMouseButtonState);
+    property X: Integer read FX;
+    property Y: Integer read FY;
+    property DeltaX: Integer read FDeltaX;
+    property DeltaY: Integer read FDeltaY;
+    property ButtonState: TPTCMouseButtonState read FButtonState;
+  end;
+  TPTCMouseButtonEvent = Class(TPTCMouseEvent)
+  private
+    FPress: Boolean;
+    FButton: TPTCMouseButton;
+    function GetRelease: Boolean;
+  public
+    constructor Create(AX, AY, ADeltaX, ADeltaY: Integer; AButtonState: TPTCMouseButtonState; APress: Boolean; AButton: TPTCMouseButton);
+    property Press: Boolean read FPress;
+    property Release: Boolean read GetRelease;
+    property Button: TPTCMouseButton read FButton;
+  end;

packages/ptc/src/core/mouseeventi.inc

@@ -0,0 +1,61 @@
+{
+    Free Pascal port of the OpenPTC C++ library.
+    Copyright (C) 2001-2006  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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+function TPTCMouseEvent.GetType: TPTCEventType;
+begin
+  Result := PTCMouseEvent;
+end;
+
+constructor TPTCMouseEvent.Create(AX, AY, ADeltaX, ADeltaY: Integer; AButtonState: TPTCMouseButtonState);
+begin
+  FX := AX;
+  FY := AY;
+  FDeltaX := ADeltaX;
+  FDeltaY := ADeltaY;
+  FButtonState := AButtonState;
+end;
+
+constructor TPTCMouseButtonEvent.Create(AX, AY, ADeltaX, ADeltaY: Integer; AButtonState: TPTCMouseButtonState; APress: Boolean; AButton: TPTCMouseButton);
+begin
+  if APress xor (AButton In AButtonState) then
+    raise TPTCError.Create('Invalid ButtonState');
+
+  inherited Create(AX, AY, ADeltaX, ADeltaY, AButtonState);
+
+  FPress := APress;
+  FButton := AButton;
+end;
+
+function TPTCMouseButtonEvent.GetRelease: Boolean;
+begin
+  Result := not FPress;
+end;

packages/ptc/src/core/paletted.inc

@@ -0,0 +1,52 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCPalette = class
+  private
+    FLocked: Boolean;
+    FHandle: THermesPaletteHandle;
+  public
+    constructor Create;
+    constructor Create(const AData: array of Uint32);
+    constructor Create(const APalette: TPTCPalette);
+    destructor Destroy; override;
+    procedure Assign(const APalette: TPTCPalette);
+    function Equals(const APalette: TPTCPalette): Boolean;
+    function Lock: PUint32;
+    procedure Unlock;
+    procedure Load(const AData: array of Uint32);
+    procedure Load(AData: Pointer);
+    procedure Save(var AData: array of Uint32);
+    procedure Save(AData: Pointer);
+    function Data: PUint32;
+  end;

packages/ptc/src/core/palettei.inc

@@ -0,0 +1,129 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+constructor TPTCPalette.Create;
+var
+  zero: array [0..255] of Uint32;
+begin
+  FLocked := False;
+  if not Hermes_Init then
+    raise TPTCError.Create('could not initialize hermes');
+  FHandle := Hermes_PaletteInstance;
+  if FHandle = nil then
+    raise TPTCError.Create('could not create hermes palette instance');
+  FillChar(zero, SizeOf(zero), 0);
+  Load(zero);
+end;
+
+constructor TPTCPalette.Create(const AData: array of Uint32);
+begin
+  FLocked := False;
+  if not Hermes_Init then
+    raise TPTCError.Create('could not initialize hermes');
+  FHandle := Hermes_PaletteInstance;
+  if FHandle = nil then
+    raise TPTCError.Create('could not create hermes palette instance');
+  Load(AData);
+end;
+
+constructor TPTCPalette.Create(const APalette: TPTCPalette);
+begin
+  FLocked := False;
+  if not Hermes_Init then
+    raise TPTCError.Create('could not initialize hermes');
+  FHandle := Hermes_PaletteInstance;
+  if FHandle = nil then
+    raise TPTCError.Create('could not create hermes palette instance');
+  Assign(APalette);
+end;
+
+destructor TPTCPalette.Destroy;
+begin
+  if FLocked then
+    raise TPTCError.Create('palette is still locked');
+  Hermes_PaletteReturn(FHandle);
+  Hermes_Done;
+  inherited Destroy;
+end;
+
+procedure TPTCPalette.Assign(const APalette: TPTCPalette);
+begin
+  if Self = APalette then
+    exit;
+
+  Hermes_PaletteSet(FHandle, Hermes_PaletteGet(APalette.FHandle));
+end;
+
+function TPTCPalette.Equals(const APalette: TPTCPalette): Boolean;
+begin
+  Equals := CompareDWord(Hermes_PaletteGet(FHandle)^, Hermes_PaletteGet(APalette.FHandle)^, 1024 div 4) = 0;
+end;
+
+function TPTCPalette.Lock: PUint32;
+begin
+  if FLocked then
+    raise TPTCError.Create('palette is already locked');
+  FLocked := True;
+  Result := Hermes_PaletteGet(FHandle);
+end;
+
+procedure TPTCPalette.Unlock;
+begin
+  if not FLocked then
+    raise TPTCError.Create('palette is not locked');
+  FLocked := False;
+end;
+
+procedure TPTCPalette.Load(const AData: array of Uint32);
+begin
+  Hermes_PaletteSet(FHandle, @AData);
+end;
+
+procedure TPTCPalette.Load(AData: Pointer);
+begin
+  Hermes_PaletteSet(FHandle, AData);
+end;
+
+procedure TPTCPalette.Save(var AData: array of Uint32);
+begin
+  Move(Hermes_PaletteGet(FHandle)^, AData, 1024);
+end;
+
+procedure TPTCPalette.Save(AData: Pointer);
+begin
+  Move(Hermes_PaletteGet(FHandle)^, AData^, 1024);
+end;
+
+function TPTCPalette.Data: PUint32;
+begin
+  Result := Hermes_PaletteGet(FHandle);
+end;

packages/ptc/src/core/surfaced.inc

@@ -0,0 +1,88 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCSurface = class(TPTCBaseSurface)
+  private
+    {data}
+    FWidth: Integer;
+    FHeight: Integer;
+    FPitch: Integer;
+    FArea: TPTCArea;
+    FClip: TPTCArea;
+    FFormat: TPTCFormat;
+    FLocked: Boolean;
+    FPixels: Pointer;
+    {objects}
+    FCopy: TPTCCopy;
+    FClear: TPTCClear;
+    FPalette: TPTCPalette;
+  public
+    constructor Create(AWidth, AHeight: Integer; const AFormat: TPTCFormat);
+    destructor Destroy; override;
+    procedure Copy(ASurface: TPTCBaseSurface); override;
+    procedure Copy(ASurface: TPTCBaseSurface;
+                   const ASource, ADestination: TPTCArea); override;
+    function Lock: Pointer; override;
+    procedure Unlock; override;
+    procedure Load(const APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette); override;
+    procedure Load(const APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette;
+                   const ASource, ADestination: TPTCArea); override;
+    procedure Save(APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette); override;
+    procedure Save(APixels: Pointer;
+                   AWidth, AHeight, APitch: Integer;
+                   const AFormat: TPTCFormat;
+                   const APalette: TPTCPalette;
+                   const ASource, ADestination: TPTCArea); override;
+    procedure Clear; override;
+    procedure Clear(const AColor: TPTCColor); override;
+    procedure Clear(const AColor: TPTCColor; const AArea: TPTCArea); override;
+    procedure Palette(const APalette: TPTCPalette); override;
+    function Palette: TPTCPalette; override;
+    procedure Clip(const AArea: TPTCArea); override;
+    function GetWidth: Integer; override;
+    function GetHeight: Integer; override;
+    function GetPitch: Integer; override;
+    function GetArea: TPTCArea; override;
+    function Clip: TPTCArea; override;
+    function GetFormat: TPTCFormat; override;
+    function Option(const AOption: string): Boolean; override;
+  end;

packages/ptc/src/core/surfacei.inc

@@ -0,0 +1,298 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+constructor TPTCSurface.Create(AWidth, AHeight: Integer; const AFormat: TPTCFormat);
+var
+  size: Integer;
+begin
+  FLocked := False;
+  LOG('creating surface');
+  LOG('width', AWidth);
+  LOG('height', AHeight);
+  LOG('format', AFormat);
+  FWidth := AWidth;
+  FHeight := AHeight;
+  FFormat := TPTCFormat.Create(AFormat);
+  FArea := TPTCArea.Create(0, 0, AWidth, AHeight);
+  FClip := TPTCArea.Create(FArea);
+  FPitch := AWidth * AFormat.Bytes;
+  size := AWidth * AHeight * AFormat.Bytes;
+  if size = 0 then
+    raise TPTCError.Create('zero surface size');
+  FPixels := GetMem(size);
+  FCopy := TPTCCopy.Create;
+  FClear := TPTCClear.Create;
+  FPalette := TPTCPalette.Create;
+  clear;
+end;
+
+destructor TPTCSurface.Destroy;
+begin
+  if FLocked then
+  begin
+    LOG('destroying surface that is still locked!!!');
+  end;
+  FCopy.Free;
+  FClear.Free;
+  FPalette.Free;
+  FClip.Free;
+  FArea.Free;
+  FFormat.Free;
+  FreeMem(FPixels);
+  inherited Destroy;
+end;
+
+procedure TPTCSurface.Copy(ASurface: TPTCBaseSurface);
+begin
+  ASurface.Load(FPixels, FWidth, FHeight, FPitch, FFormat, FPalette);
+end;
+
+procedure TPTCSurface.Copy(ASurface: TPTCBaseSurface;
+                           const ASource, ADestination: TPTCArea);
+begin
+  ASurface.Load(FPixels, FWidth, FHeight, FPitch, FFormat, FPalette,
+                ASource, ADestination);
+end;
+
+function TPTCSurface.Lock: Pointer;
+begin
+  if FLocked then
+    raise TPTCError.Create('surface is already locked');
+  FLocked := True;
+  Result := FPixels;
+end;
+
+procedure TPTCSurface.Unlock;
+begin
+  if not FLocked then
+    raise TPTCError.Create('surface is not locked');
+  FLocked := False;
+end;
+
+procedure TPTCSurface.Load(const APixels: Pointer;
+                           AWidth, AHeight, APitch: Integer;
+                           const AFormat: TPTCFormat;
+                           const APalette: TPTCPalette);
+var
+  Area_: TPTCArea;
+begin
+  if FClip.Equals(FArea) then
+  begin
+    FCopy.Request(AFormat, FFormat);
+    FCopy.Palette(APalette, FPalette);
+    FCopy.Copy(APixels, 0, 0, AWidth, AHeight, APitch, FPixels, 0, 0,
+               FWidth, FHeight, FPitch);
+  end
+  else
+  begin
+    Area_ := TPTCArea.Create(0, 0, AWidth, AHeight);
+    try
+      Load(APixels, AWidth, AHeight, APitch, AFormat, APalette, Area_, FArea);
+    finally
+      Area_.Free;
+    end;
+  end;
+end;
+
+procedure TPTCSurface.Load(const APixels: Pointer;
+                           AWidth, AHeight, APitch: Integer;
+                           const AFormat: TPTCFormat;
+                           const APalette: TPTCPalette;
+                           const ASource, ADestination: TPTCArea);
+var
+  clipped_source: TPTCArea = nil;
+  clipped_destination: TPTCArea = nil;
+  area_: TPTCArea = nil;
+begin
+  try
+    clipped_source := TPTCArea.Create;
+    clipped_destination := TPTCArea.Create;
+    area_ := TPTCArea.Create(0, 0, AWidth, AHeight);
+    TPTCClipper.Clip(ASource, area_, clipped_source, ADestination, FClip,
+                     clipped_destination);
+    FCopy.Request(AFormat, FFormat);
+    FCopy.Palette(APalette, FPalette);
+    FCopy.Copy(APixels, clipped_source.left, clipped_source.top,
+               clipped_source.width, clipped_source.height, APitch,
+               FPixels, clipped_destination.left, clipped_destination.top,
+               clipped_destination.width, clipped_destination.height, FPitch);
+  finally
+    clipped_source.Free;
+    clipped_destination.Free;
+    area_.Free;
+  end;
+end;
+
+procedure TPTCSurface.Save(APixels: Pointer;
+                           AWidth, AHeight, APitch: Integer;
+                           const AFormat: TPTCFormat;
+                           const APalette: TPTCPalette);
+var
+  area_: TPTCArea;
+begin
+  if FClip.Equals(FArea) then
+  begin
+    FCopy.Request(FFormat, AFormat);
+    FCopy.Palette(FPalette, APalette);
+    FCopy.Copy(FPixels, 0, 0, FWidth, FHeight, FPitch, APixels, 0, 0,
+               AWidth, AHeight, APitch);
+  end
+  else
+  begin
+    area_ := TPTCArea.Create(0, 0, width, height);
+    try
+      Save(APixels, AWidth, AHeight, APitch, AFormat, APalette, FArea, area_);
+    finally
+      area_.Free;
+    end;
+  end;
+end;
+
+procedure TPTCSurface.Save(APixels: Pointer;
+                           AWidth, AHeight, APitch: Integer;
+                           const AFormat: TPTCFormat;
+                           const APalette: TPTCPalette;
+                           const ASource, ADestination: TPTCArea);
+var
+  clipped_source: TPTCArea = nil;
+  clipped_destination: TPTCArea = nil;
+  area_: TPTCArea = nil;
+begin
+  try
+    clipped_source := TPTCArea.Create;
+    clipped_destination := TPTCArea.Create;
+    area_ := TPTCArea.Create(0, 0, AWidth, AHeight);
+    TPTCClipper.Clip(ASource, FClip, clipped_source, ADestination, area_,
+                     clipped_destination);
+    FCopy.Request(FFormat, AFormat);
+    FCopy.Palette(FPalette, APalette);
+    FCopy.Copy(FPixels, clipped_source.left, clipped_source.top,
+               clipped_source.width, clipped_source.height, FPitch,
+               APixels, clipped_destination.left, clipped_destination.top,
+               clipped_destination.width, clipped_destination.height, APitch);
+  finally
+    clipped_source.Free;
+    clipped_destination.Free;
+    area_.Free;
+  end;
+end;
+
+procedure TPTCSurface.Clear;
+var
+  Color: TPTCColor;
+begin
+  if Format.Direct then
+    Color := TPTCColor.Create(0, 0, 0, 0)
+  else
+    Color := TPTCColor.Create(0);
+  try
+    Clear(Color);
+  finally
+    Color.Free;
+  end;
+end;
+
+procedure TPTCSurface.Clear(const AColor: TPTCColor);
+begin
+  Clear(AColor, FArea);
+end;
+
+procedure TPTCSurface.Clear(const AColor: TPTCColor; const AArea: TPTCArea);
+var
+  clipped_area: TPTCArea;
+begin
+  clipped_area := TPTCClipper.clip(AArea, FClip);
+  try
+    FClear.Request(FFormat);
+    FClear.Clear(FPixels, clipped_area.left, clipped_area.top,
+                 clipped_area.width, clipped_area.height, FPitch, AColor);
+  finally
+    clipped_area.Free;
+  end;
+end;
+
+procedure TPTCSurface.Palette(const APalette: TPTCPalette);
+begin
+  FPalette.Load(APalette.data^);
+end;
+
+function TPTCSurface.Palette: TPTCPalette;
+begin
+  Result := FPalette;
+end;
+
+procedure TPTCSurface.Clip(const AArea: TPTCArea);
+var
+  tmp: TPTCArea;
+begin
+  tmp := TPTCClipper.Clip(AArea, FArea);
+  try
+    FClip.Assign(tmp);
+  finally
+    tmp.Free;
+  end;
+end;
+
+function TPTCSurface.GetWidth: Integer;
+begin
+  Result := FWidth;
+end;
+
+function TPTCSurface.GetHeight: Integer;
+begin
+  Result := FHeight;
+end;
+
+function TPTCSurface.GetPitch: Integer;
+begin
+  Result := FPitch;
+end;
+
+function TPTCSurface.GetArea: TPTCArea;
+begin
+  Result := FArea;
+end;
+
+function TPTCSurface.Clip: TPTCArea;
+begin
+  Result := FClip;
+end;
+
+function TPTCSurface.GetFormat: TPTCFormat;
+begin
+  Result := FFormat;
+end;
+
+function TPTCSurface.Option(const AOption: string): Boolean;
+begin
+  Result := FCopy.Option(AOption);
+end;

packages/ptc/src/core/timerd.inc

@@ -0,0 +1,59 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TPTCTimer = class
+  private
+    FOld: Double;
+    FTime: Double;
+    FStart: Double;
+    FCurrent: Double;
+    FRunning: Boolean;
+    {$IF defined(WIN32) OR defined(WIN64)}
+    FFrequency: QWord;
+    {$ENDIF defined(WIN32) OR defined(WIN64)}
+    function Clock: Double;
+    procedure internal_init_timer;
+  public
+    constructor Create;
+    constructor Create(ATime: Double);
+    constructor Create(const ATimer: TPTCTimer);
+    destructor Destroy; override;
+    procedure Assign(const ATimer: TPTCTimer);
+    function Equals(const ATimer: TPTCTimer): Boolean;
+    procedure SetTime(ATime: Double); {was 'set' in the C++ version}
+    procedure Start;
+    procedure Stop;
+    function Time: Double;
+    function Delta: Double;
+    function Resolution: Double;
+  end;

packages/ptc/src/core/timeri.inc

@@ -0,0 +1,204 @@
+{
+    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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+{Function timeGetTime: DWord; StdCall; external 'WINMM' name 'timeGetTime';}
+
+constructor TPTCTimer.Create;
+begin
+  internal_init_timer;
+  FOld := 0;
+  FTime := 0;
+  FStart := 0;
+  FCurrent := 0;
+  FRunning := False;
+end;
+
+constructor TPTCTimer.Create(ATime: Double);
+begin
+  internal_init_timer;
+  FOld := 0;
+  FTime := 0;
+  FStart := 0;
+  FCurrent := 0;
+  FRunning := False;
+  SetTime(ATime);
+end;
+
+constructor TPTCTimer.Create(const ATimer: TPTCTimer);
+begin
+  internal_init_timer;
+  Assign(ATimer);
+end;
+
+destructor TPTCTimer.Destroy;
+begin
+  Stop;
+  inherited Destroy;
+end;
+
+procedure TPTCTimer.Assign(const ATimer: TPTCTimer);
+begin
+  if Self = ATimer then
+    exit;
+
+  FOld := ATimer.FOld;
+  FTime := ATimer.FTime;
+  FStart := ATimer.FStart;
+  FCurrent := ATimer.FCurrent;
+  FRunning := ATimer.FRunning;
+end;
+
+function TPTCTimer.Equals(const ATimer: TPTCTimer): Boolean;
+begin
+  Result := (FOld = ATimer.FOld) and (FTime = ATimer.FTime) and
+            (FStart = ATimer.FStart) and (FCurrent = ATimer.FCurrent) and
+            (FRunning = ATimer.FRunning);
+end;
+
+procedure TPTCTimer.SetTime(ATime: Double);
+begin
+  FCurrent := ATime;
+  FStart := Clock;
+  FTime := FStart + ATime;
+  FOld := FTime - Delta;
+end;
+
+procedure TPTCTimer.Start;
+begin
+  if not FRunning then
+  begin
+    FStart := Clock;
+    FOld := Clock;
+    FRunning := True;
+  end;
+end;
+
+procedure TPTCTimer.Stop;
+begin
+  FRunning := False;
+end;
+
+function TPTCTimer.Time: Double;
+var
+  _time: Double;
+begin
+  if FRunning then
+  begin
+    _time := Clock;
+    if _time > FTime then
+      FTime := _time;
+    FCurrent := FTime - FStart;
+  end;
+  Result := FCurrent;
+end;
+
+function TPTCTimer.Delta: Double;
+var
+  _time: Double;
+  _delta: Double;
+begin
+  if FRunning then
+  begin
+    _time := Clock;
+    _delta := _time - FOld;
+    FOld := _time;
+    if _delta < 0 then
+      _delta := 0;
+    Result := _delta;
+  end
+  else
+    Result := 0;
+end;
+
+function TPTCTimer.Resolution: Double;
+begin
+  {$IFDEF GO32V2}
+  Result := TimerResolution;
+  {$ENDIF GO32V2}
+  {$IF defined(Win32) OR defined(Win64)}
+  Result := 1 / FFrequency;
+{  Result := 1 / 1000;}
+  {$ENDIF defined(Win32) OR defined(Win64)}
+  {$IFDEF WinCE}
+  Result := 1 / 1000;
+  {$ENDIF WinCE}
+  {$IFDEF UNIX}
+  Result := 1 / 1000000;
+  {$ENDIF UNIX}
+end;
+
+procedure TPTCTimer.internal_init_timer;
+{$IF defined(WIN32) OR defined(WIN64)}
+var
+  _freq: QWord;
+{$ENDIF defined(WIN32) OR defined(WIN64)}
+begin
+{$IF defined(WIN32) OR defined(WIN64)}
+  QueryPerformanceFrequency(PLARGE_INTEGER(@_freq));
+  FFrequency := _freq;
+{$ENDIF defined(WIN32) OR defined(WIN64)}
+end;
+
+{$IFDEF GO32V2}
+function TPTCTimer.Clock: Double;
+begin
+  Result := GetClockTics() * TimerResolution;
+end;
+{$ENDIF GO32V2}
+
+{$IF defined(WIN32) OR defined(WIN64)}
+function TPTCTimer.Clock: Double;
+var
+  _time: QWord;
+begin
+  QueryPerformanceCounter(PLARGE_INTEGER(@_time));
+  Result := _time / FFrequency;
+{  Result := timeGetTime / 1000;}
+end;
+{$ENDIF defined(WIN32) OR defined(WIN64)}
+
+{$IFDEF WinCE}
+function TPTCTimer.Clock: Double;
+begin
+  Result := GetTickCount / 1000;
+end;
+{$ENDIF WinCE}
+
+{$IFDEF UNIX}
+function TPTCTimer.Clock: Double;
+var
+  tm: TimeVal;
+begin
+  fpGetTimeOfDay(@tm, nil);
+  Result := tm.tv_sec + (Double(tm.tv_usec)) / 1000000;
+end;
+{$ENDIF UNIX}

packages/ptc/src/dos/base/go32fix.pp

@@ -0,0 +1,1299 @@
+{
+    This file is part of the Free Pascal run time library.
+    and implements some stuff for protected mode programming
+    Copyright (c) 1999-2000 by the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+
+unit go32fix;
+
+{$S-,R-,I-,Q-} {no stack check, used by DPMIEXCP !! }
+
+interface
+
+    const
+    { contants for the run modes returned by get_run_mode }
+       rm_unknown = 0;
+       rm_raw     = 1;     { raw (without HIMEM) }
+       rm_xms     = 2;     { XMS (for example with HIMEM, without EMM386) }
+       rm_vcpi    = 3;     { VCPI (for example HIMEM and EMM386) }
+       rm_dpmi    = 4;     { DPMI (for example DOS box or 386Max) }
+
+    { flags }
+       carryflag     = $001;
+       parityflag    = $004;
+       auxcarryflag  = $010;
+       zeroflag      = $040;
+       signflag      = $080;
+       trapflag      = $100;
+       interruptflag = $200;
+       directionflag = $400;
+       overflowflag  = $800;
+
+    type
+       tmeminfo = record
+          available_memory,
+          available_pages,
+          available_lockable_pages,
+          linear_space,
+          unlocked_pages,
+          available_physical_pages,
+          total_physical_pages,
+          free_linear_space,
+          max_pages_in_paging_file,
+          reserved0,
+          reserved1,
+          reserved2: longint;
+       end;
+
+       tseginfo = record
+          offset: pointer;
+          segment: word;
+       end;
+
+       trealregs = record
+         case integer of
+          1: { 32-bit } (EDI, ESI, EBP, Res, EBX, EDX, ECX, EAX: longint;
+                         Flags, ES, DS, FS, GS, IP, CS, SP, SS: word);
+          2: { 16-bit } (DI, DI2, SI, SI2, BP, BP2, R1, R2: word;
+                         BX, BX2, DX, DX2, CX, CX2, AX, AX2: word);
+          3: { 8-bit }  (stuff: array[1..4] of longint;
+                         BL, BH, BL2, BH2, DL, DH, DL2, DH2,
+                         CL, CH, CL2, CH2, AL, AH, AL2, AH2: byte);
+          4: { Compat } (RealEDI, RealESI, RealEBP, RealRES,
+                         RealEBX, RealEDX, RealECX, RealEAX: longint;
+                         RealFlags,
+                         RealES, RealDS, RealFS, RealGS,
+                         RealIP, RealCS, RealSP, RealSS: word);
+       end;
+
+      registers = trealregs;
+
+      tdpmiversioninfo = record
+        major, minor: byte;
+	flags: word;
+	cpu: byte;
+	master_pic, slave_pic: byte;
+      end;
+
+    { this works only with real DPMI }
+    function allocate_ldt_descriptors(count: word): word;
+    function free_ldt_descriptor(d: word): boolean;
+    function segment_to_descriptor(seg: word): word;
+    function get_next_selector_increment_value: word;
+    function get_segment_base_address(d: word): longint;
+    function set_segment_base_address(d: word;s: dword): boolean;
+    function set_segment_limit(d: word;s: dword): boolean;
+    function set_descriptor_access_right(d: word;w: word): boolean;
+    function create_code_segment_alias_descriptor(seg: word): word;
+    function get_linear_addr(phys_addr: dword;size: longint): dword;
+    function free_linear_addr_mapping(linear_addr: dword): boolean;
+    function get_segment_limit(d: word): dword;
+    function get_descriptor_access_right(d: word): longint;
+    function get_page_size:longint;
+    function map_device_in_memory_block(handle,offset,pagecount,device:dword):boolean;
+    function get_page_attributes(handle, offset, pagecount: dword; buf: pointer): boolean;
+    function set_page_attributes(handle, offset, pagecount: dword; buf: pointer): boolean;
+    function realintr(intnr: word;var regs: trealregs): boolean;
+    function get_dpmi_version(var version: tdpmiversioninfo): boolean;
+
+    { is needed for functions which need a real mode buffer }
+    function global_dos_alloc(bytes: longint): longint;
+    function global_dos_free(selector: word): boolean;
+
+    var
+       { selector for the DOS memory (only usable if in DPMI mode) }
+       dosmemselector: word;
+       { result of dpmi call }
+       int31error: word;
+
+    { this procedure copies data where the source and destination }
+    { are specified by 48 bit pointers                            }
+    { Note: the procedure checks only for overlapping if          }
+    { source selector=destination selector                        }
+    procedure seg_move(sseg: word;source: longint;dseg: word;dest: longint;count: longint);
+
+    { fills a memory area specified by a 48 bit pointer with c }
+    procedure seg_fillchar(seg: word;ofs: longint;count: longint;c: char);
+    procedure seg_fillword(seg: word;ofs: longint;count: longint;w: word);
+
+    {************************************}
+    { this works with all PM interfaces: }
+    {************************************}
+
+    function get_meminfo(var meminfo: tmeminfo): boolean;
+    function get_pm_interrupt(vector: byte;var intaddr: tseginfo): boolean;
+    function set_pm_interrupt(vector: byte;const intaddr: tseginfo): boolean;
+    function get_rm_interrupt(vector: byte;var intaddr: tseginfo): boolean;
+    function set_rm_interrupt(vector: byte;const intaddr: tseginfo): boolean;
+    function get_exception_handler(e: byte;var intaddr: tseginfo): boolean;
+    function set_exception_handler(e: byte;const intaddr: tseginfo): boolean;
+    function get_pm_exception_handler(e: byte;var intaddr: tseginfo): boolean;
+    function set_pm_exception_handler(e: byte;const intaddr: tseginfo): boolean;
+    function free_rm_callback(var intaddr: tseginfo): boolean;
+    function get_rm_callback(pm_func: pointer;const reg: trealregs;var rmcb: tseginfo): boolean;
+    function get_cs: word;
+    function get_ds: word;
+    function get_ss: word;
+
+    { locking functions }
+    function allocate_memory_block(size:longint):longint;
+    function free_memory_block(blockhandle: longint): boolean;
+    function request_linear_region(linearaddr, size: longint;
+                                   var blockhandle: longint): boolean;
+    function lock_linear_region(linearaddr, size: longint): boolean;
+    function lock_data(var data;size: longint): boolean;
+    function lock_code(functionaddr: pointer;size: longint): boolean;
+    function unlock_linear_region(linearaddr, size: longint): boolean;
+    function unlock_data(var data;size: longint): boolean;
+    function unlock_code(functionaddr: pointer;size: longint): boolean;
+
+    { disables and enables interrupts }
+    procedure disable;
+    procedure enable;
+
+    function inportb(port: word): byte;
+    function inportw(port: word): word;
+    function inportl(port: word): longint;
+
+    procedure outportb(port: word;data: byte);
+    procedure outportw(port: word;data: word);
+    procedure outportl(port: word;data: longint);
+    function get_run_mode: word;
+
+    function transfer_buffer: longint;
+    function tb_segment: longint;
+    function tb_offset: longint;
+    function tb_size: longint;
+    procedure copytodos(var addr; len: longint);
+    procedure copyfromdos(var addr; len: longint);
+
+    procedure dpmi_dosmemput(seg: word;ofs: word;var data;count: longint);
+    procedure dpmi_dosmemget(seg: word;ofs: word;var data;count: longint);
+    procedure dpmi_dosmemmove(sseg,sofs,dseg,dofs: word;count: longint);
+    procedure dpmi_dosmemfillchar(seg,ofs: word;count: longint;c: char);
+    procedure dpmi_dosmemfillword(seg,ofs: word;count: longint;w: word);
+
+
+
+    const
+       { this procedures are assigned to the procedure which are needed }
+       { for the current mode to access DOS memory                      }
+       { It's strongly recommended to use this procedures!              }
+       dosmemput: procedure(seg: word;ofs: word;var data;count: longint)=@dpmi_dosmemput;
+       dosmemget: procedure(seg: word;ofs: word;var data;count: longint)=@dpmi_dosmemget;
+       dosmemmove: procedure(sseg,sofs,dseg,dofs: word;count: longint)=@dpmi_dosmemmove;
+       dosmemfillchar: procedure(seg,ofs: word;count: longint;c: char)=@dpmi_dosmemfillchar;
+       dosmemfillword: procedure(seg,ofs: word;count: longint;w: word)=@dpmi_dosmemfillword;
+
+  implementation
+
+{$asmmode ATT}
+
+
+    { the following procedures copy from and to DOS memory using DPMI }
+    procedure dpmi_dosmemput(seg: word;ofs: word;var data;count: longint);
+
+      begin
+         seg_move(get_ds,longint(@data),dosmemselector,seg*16+ofs,count);
+      end;
+
+    procedure dpmi_dosmemget(seg: word;ofs: word;var data;count: longint);
+
+      begin
+         seg_move(dosmemselector,seg*16+ofs,get_ds,longint(@data),count);
+      end;
+
+    procedure dpmi_dosmemmove(sseg,sofs,dseg,dofs: word;count: longint);
+
+      begin
+         seg_move(dosmemselector,sseg*16+sofs,dosmemselector,dseg*16+dofs,count);
+      end;
+
+    procedure dpmi_dosmemfillchar(seg,ofs: word;count: longint;c: char);
+
+      begin
+         seg_fillchar(dosmemselector,seg*16+ofs,count,c);
+      end;
+
+    procedure dpmi_dosmemfillword(seg,ofs: word;count: longint;w: word);
+
+      begin
+         seg_fillword(dosmemselector,seg*16+ofs,count,w);
+      end;
+
+
+    procedure test_int31(flag: longint); stdcall; { stack-args! }
+      begin
+         asm
+            pushl %ebx
+            movw  $0,INT31ERROR
+            movl  flag,%ebx
+            testb $1,%bl
+            jz    .Lti31_1
+            movw  %ax,INT31ERROR
+            xorl  %eax,%eax
+            jmp   .Lti31_2
+            .Lti31_1:
+            movl  $1,%eax
+            .Lti31_2:
+            popl  %ebx
+         end;
+      end;
+
+    function global_dos_alloc(bytes: longint): longint;
+
+      begin
+         asm
+            pushl %ebx
+            movl bytes,%ebx
+            addl $0xf,%ebx              // round up
+            shrl $0x4,%ebx              // convert to Paragraphs
+            movl $0x100,%eax            // function 0x100
+            int  $0x31
+            jnc  .LDos_OK
+            movw %ax,INT31ERROR
+            xorl %eax,%eax
+            jmp  .LDos_end
+          .LDos_OK:
+            shll $0x10,%eax             // return Segment in hi(Result)
+            movw %dx,%ax                // return Selector in lo(Result)
+          .LDos_end:
+            movl %eax,__result
+            popl %ebx
+         end;
+      end;
+
+    function  global_dos_free(selector: word): boolean;
+
+      begin
+         asm
+            movw Selector,%dx
+            movl $0x101,%eax
+            int  $0x31
+            setnc %al
+            movb %al,__RESULT
+         end;
+      end;
+
+    function realintr(intnr: word;var regs: trealregs): boolean;
+
+      begin
+         regs.realsp:=0;
+         regs.realss:=0;
+         regs.realres:=0; { play it safe }
+         asm
+            { save all used registers to avoid crash under NTVDM }
+            { when spawning a 32-bit DPMI application            }
+            pushl %edi
+            pushl %ebx
+            pushw %fs
+            movw  intnr,%bx
+            xorl  %ecx,%ecx
+            movl  regs,%edi
+            { es is always equal ds }
+            movl  $0x300,%eax
+            int   $0x31
+            popw  %fs
+            setnc %al
+            movb  %al,__RESULT
+            popl  %ebx
+            popl  %edi
+         end;
+      end;
+
+    procedure seg_fillchar(seg: word;ofs: longint;count: longint;c: char);
+
+      begin
+         asm
+            pushl %edi
+            movl ofs,%edi
+            movl count,%ecx
+            movb c,%dl
+            { load es with selector }
+            pushw %es
+            movw seg,%ax
+            movw %ax,%es
+            { fill eax with duplicated c }
+            { so we can use stosl        }
+            movb %dl,%dh
+            movw %dx,%ax
+            shll $16,%eax
+            movw %dx,%ax
+            movl %ecx,%edx
+            shrl $2,%ecx
+            cld
+            rep
+            stosl
+            movl %edx,%ecx
+            andl $3,%ecx
+            rep
+            stosb
+            popw %es
+            popl %edi
+         end;
+      end;
+
+    procedure seg_fillword(seg: word;ofs: longint;count: longint;w: word);
+
+      begin
+         asm
+            pushl %edi
+            movl ofs,%edi
+            movl count,%ecx
+            movw w,%dx
+            { load segment }
+            pushw %es
+            movw seg,%ax
+            movw %ax,%es
+            { fill eax }
+            movw %dx,%ax
+            shll $16,%eax
+            movw %dx,%ax
+            movl %ecx,%edx
+            shrl $1,%ecx
+            cld
+            rep
+            stosl
+            movl %edx,%ecx
+            andl $1,%ecx
+            rep
+            stosw
+            popw %es
+            popl %edi
+         end;
+      end;
+
+    procedure seg_move(sseg: word;source: longint;dseg: word;dest: longint;count: longint);
+
+      begin
+         if count=0 then
+           exit;
+         if (sseg<>dseg) or ((sseg=dseg) and (source>dest)) then
+           asm
+              pushl %esi
+              pushl %edi
+              pushw %es
+              pushw %ds
+              cld
+              movl count,%ecx
+              movl source,%esi
+              movl dest,%edi
+              movw dseg,%ax
+              movw %ax,%es
+              movw sseg,%ax
+              movw %ax,%ds
+              movl %ecx,%eax
+              shrl $2,%ecx
+              rep
+              movsl
+              movl %eax,%ecx
+              andl $3,%ecx
+              rep
+              movsb
+              popw %ds
+              popw %es
+              popl %edi
+              popl %esi
+           end ['ECX','EAX']
+         else if (source<dest) then
+           { copy backward for overlapping }
+           asm
+              pushl %esi
+              pushl %edi
+              pushw %es
+              pushw %ds
+              std
+              movl count,%ecx
+              movl source,%esi
+              movl dest,%edi
+              movw dseg,%ax
+              movw %ax,%es
+              movw sseg,%ax
+              movw %ax,%ds
+              addl %ecx,%esi
+              addl %ecx,%edi
+              movl %ecx,%eax
+              andl $3,%ecx
+              orl %ecx,%ecx
+              jz .LSEG_MOVE1
+
+              { calculate esi and edi}
+              decl %esi
+              decl %edi
+              rep
+              movsb
+              incl %esi
+              incl %edi
+           .LSEG_MOVE1:
+              subl $4,%esi
+              subl $4,%edi
+              movl %eax,%ecx
+              shrl $2,%ecx
+              rep
+              movsl
+              cld
+              popw %ds
+              popw %es
+              popl %edi
+              popl %esi
+           end ['ECX','EAX'];
+      end;
+
+    procedure outportb(port: word;data: byte);
+
+      begin
+         asm
+            movw port,%dx
+            movb data,%al
+            outb %al,%dx
+         end ['EAX','EDX'];
+      end;
+
+    procedure outportw(port: word;data: word);
+
+      begin
+         asm
+            movw port,%dx
+            movw data,%ax
+            outw %ax,%dx
+         end ['EAX','EDX'];
+      end;
+
+    procedure outportl(port: word;data: longint);
+
+      begin
+         asm
+            movw port,%dx
+            movl data,%eax
+            outl %eax,%dx
+         end ['EAX','EDX'];
+      end;
+
+    function inportb(port: word): byte;
+
+      begin
+         asm
+            movw port,%dx
+            inb %dx,%al
+            movb %al,__RESULT
+         end ['EAX','EDX'];
+      end;
+
+    function inportw(port: word): word;
+
+      begin
+         asm
+            movw port,%dx
+            inw %dx,%ax
+            movw %ax,__RESULT
+         end ['EAX','EDX'];
+      end;
+
+    function inportl(port: word): longint;
+
+      begin
+         asm
+            movw port,%dx
+            inl %dx,%eax
+            movl %eax,__RESULT
+         end ['EAX','EDX'];
+      end;
+
+
+
+    function get_cs: word;assembler;
+      asm
+            movw %cs,%ax
+      end;
+
+
+    function get_ss: word;assembler;
+      asm
+            movw %ss,%ax
+      end;
+
+
+    function get_ds: word;assembler;
+      asm
+            movw %ds,%ax
+      end;
+
+
+    function set_pm_interrupt(vector: byte;const intaddr: tseginfo): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movl intaddr,%eax
+            movl (%eax),%edx
+            movw 4(%eax),%cx
+            movl $0x205,%eax
+            movb vector,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            popl %ebx
+         end;
+      end;
+
+    function set_rm_interrupt(vector: byte;const intaddr: tseginfo): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movl intaddr,%eax
+            movw (%eax),%dx
+            movw 4(%eax),%cx
+            movl $0x201,%eax
+            movb vector,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            popl %ebx
+         end;
+      end;
+
+    function set_pm_exception_handler(e: byte;const intaddr: tseginfo): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movl intaddr,%eax
+            movl (%eax),%edx
+            movw 4(%eax),%cx
+            movl $0x212,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            popl %ebx
+         end;
+      end;
+
+    function set_exception_handler(e: byte;const intaddr: tseginfo): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movl intaddr,%eax
+            movl (%eax),%edx
+            movw 4(%eax),%cx
+            movl $0x203,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            popl %ebx
+         end;
+      end;
+
+    function get_pm_exception_handler(e: byte;var intaddr: tseginfo): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movl $0x210,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+            popl %ebx
+         end;
+      end;
+
+    function get_exception_handler(e: byte;var intaddr: tseginfo): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movl $0x202,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+            popl %ebx
+         end;
+      end;
+
+    function get_pm_interrupt(vector: byte;var intaddr: tseginfo): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movb vector,%bl
+            movl $0x204,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+            popl %ebx
+         end;
+      end;
+
+    function get_rm_interrupt(vector: byte;var intaddr: tseginfo): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movb vector,%bl
+            movl $0x200,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movzwl %dx,%edx
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+            popl %ebx
+         end;
+      end;
+
+    function free_rm_callback(var intaddr: tseginfo): boolean;
+      begin
+         asm
+            movl intaddr,%eax
+            movw (%eax),%dx
+            movw 4(%eax),%cx
+            movl $0x304,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    { here we must use ___v2prt0_ds_alias instead of from v2prt0.s
+    because the exception processor sets the ds limit to $fff
+    at hardware exceptions }
+
+    var
+       ___v2prt0_ds_alias: word; external name '___v2prt0_ds_alias';
+
+    function get_rm_callback(pm_func: pointer;const reg: trealregs;var rmcb: tseginfo): boolean;
+      begin
+         asm
+            pushl %esi
+            pushl %edi
+            movl  pm_func,%esi
+            movl  reg,%edi
+            pushw %es
+            movw  ___v2prt0_ds_alias,%ax
+            movw  %ax,%es
+            pushw %ds
+            movw  %cs,%ax
+            movw  %ax,%ds
+            movl  $0x303,%eax
+            int   $0x31
+            popw  %ds
+            popw  %es
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl  rmcb,%eax
+            movzwl %dx,%edx
+            movl  %edx,(%eax)
+            movw  %cx,4(%eax)
+            popl %edi
+            popl %esi
+         end;
+      end;
+
+    function allocate_ldt_descriptors(count: word): word;
+
+      begin
+         asm
+            movw count,%cx
+            xorl %eax,%eax
+            int $0x31
+            movw %ax,__RESULT
+         end;
+      end;
+
+    function free_ldt_descriptor(d: word): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movw d,%bx
+            movl $1,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            popl %ebx
+         end;
+      end;
+
+    function segment_to_descriptor(seg: word): word;
+
+      begin
+         asm
+            pushl %ebx
+            movw seg,%bx
+            movl $2,%eax
+            int $0x31
+            movw %ax,__RESULT
+            popl %ebx
+         end;
+      end;
+
+    function get_next_selector_increment_value: word;
+
+      begin
+         asm
+            movl $3,%eax
+            int $0x31
+            movw %ax,__RESULT
+         end;
+      end;
+
+    function get_segment_base_address(d: word): longint;
+
+      begin
+         asm
+            pushl %ebx
+            movw d,%bx
+            movl $6,%eax
+            int $0x31
+            xorl %eax,%eax
+            movw %dx,%ax
+            shll $16,%ecx
+            orl %ecx,%eax
+            movl %eax,__RESULT
+            popl %ebx
+         end;
+      end;
+
+    function get_page_size:longint;
+      begin
+        asm
+           pushl %ebx
+           movl $0x604,%eax
+           int $0x31
+           shll $16,%ebx
+           movw %cx,%bx
+           movl %ebx,__RESULT
+           popl %ebx
+        end;
+      end;
+
+    function request_linear_region(linearaddr, size: longint;
+                                   var blockhandle: longint): boolean;
+      var
+         pageofs: longint;
+
+      begin
+         pageofs:=linearaddr and $3ff;
+         linearaddr:=linearaddr-pageofs;
+         size:=size+pageofs;
+         asm
+            pushl %ebx
+            pushl %esi
+            movl $0x504,%eax
+            movl linearaddr,%ebx
+            movl size,%ecx
+            movl $1,%edx
+            xorl %esi,%esi
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl blockhandle,%eax
+            movl %esi,(%eax)
+            movl %ebx,pageofs
+            popl %esi
+            popl %ebx
+         end;
+         if pageofs<>linearaddr then
+           request_linear_region:=false;
+      end;
+
+    function allocate_memory_block(size:longint):longint;
+      begin
+        asm
+          pushl %ebx
+          pushl %esi
+          movl  $0x501,%eax
+          movl  size,%ecx
+          movl  %ecx,%ebx
+          shrl  $16,%ebx
+          andl  $65535,%ecx
+          int   $0x31
+          jnc   .Lallocate_mem_block_err
+          xorl  %ebx,%ebx
+          xorl  %ecx,%ecx
+       .Lallocate_mem_block_err:
+          shll  $16,%ebx
+          movw  %cx,%bx
+          shll  $16,%esi
+          movw  %di,%si
+          movl  %ebx,__RESULT
+          popl %esi
+          popl %ebx
+        end;
+     end;
+
+    function free_memory_block(blockhandle: longint): boolean;
+      begin
+         asm
+            pushl %edi
+            pushl %esi
+            movl blockhandle,%esi
+            movl %esi,%edi
+            shll $16,%esi
+            movl $0x502,%eax
+            int  $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            popl %esi
+            popl %edi
+         end;
+      end;
+
+    function lock_linear_region(linearaddr, size: longint): boolean;
+
+      begin
+          asm
+            pushl %ebx
+            pushl %edi
+            pushl %esi
+            movl  $0x600,%eax
+            movl  linearaddr,%ecx
+            movl  %ecx,%ebx
+            shrl  $16,%ebx
+            movl  size,%esi
+            movl  %esi,%edi
+            shrl  $16,%esi
+            int   $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            popl %esi
+            popl %edi
+            popl %ebx
+          end;
+      end;
+
+    function lock_data(var data;size: longint): boolean;
+
+      var
+         linearaddr: longint;
+
+      begin
+         if get_run_mode<>rm_dpmi then
+           exit;
+         linearaddr:=longint(@data)+get_segment_base_address(get_ds);
+         lock_data:=lock_linear_region(linearaddr,size);
+      end;
+
+    function lock_code(functionaddr: pointer;size: longint): boolean;
+
+      var
+         linearaddr: longint;
+
+      begin
+         if get_run_mode<>rm_dpmi then
+           exit;
+         linearaddr:=longint(functionaddr)+get_segment_base_address(get_cs);
+         lock_code:=lock_linear_region(linearaddr,size);
+      end;
+
+    function unlock_linear_region(linearaddr,size: longint): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            pushl %edi
+            pushl %esi
+            movl  $0x601,%eax
+            movl  linearaddr,%ecx
+            movl  %ecx,%ebx
+            shrl  $16,%ebx
+            movl  size,%esi
+            movl  %esi,%edi
+            shrl  $16,%esi
+            int   $0x31
+            pushf
+            call  test_int31
+            movb  %al,__RESULT
+            popl %esi
+            popl %edi
+            popl %ebx
+         end;
+      end;
+
+    function unlock_data(var data;size: longint): boolean;
+
+      var
+         linearaddr: longint;
+      begin
+         if get_run_mode<>rm_dpmi then
+           exit;
+         linearaddr:=longint(@data)+get_segment_base_address(get_ds);
+         unlock_data:=unlock_linear_region(linearaddr,size);
+      end;
+
+    function unlock_code(functionaddr: pointer;size: longint): boolean;
+
+      var
+         linearaddr: longint;
+      begin
+         if get_run_mode<>rm_dpmi then
+           exit;
+         linearaddr:=longint(functionaddr)+get_segment_base_address(get_cs);
+         unlock_code:=unlock_linear_region(linearaddr,size);
+      end;
+
+    function set_segment_base_address(d: word;s: dword): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movw d,%bx
+            leal s,%eax
+            movw (%eax),%dx
+            movw 2(%eax),%cx
+            movl $7,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            popl %ebx
+         end;
+      end;
+
+    function set_descriptor_access_right(d: word;w: word): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movw d,%bx
+            movw w,%cx
+            movl $9,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            popl %ebx
+         end;
+      end;
+
+    function set_segment_limit(d: word;s: dword): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            movw d,%bx
+            leal s,%eax
+            movw (%eax),%dx
+            movw 2(%eax),%cx
+            movl $8,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            popl %ebx
+         end;
+      end;
+
+    function get_descriptor_access_right(d: word): longint;
+
+      begin
+         asm
+            movzwl d,%eax
+            lar %eax,%eax
+            jz .L_ok
+            xorl %eax,%eax
+         .L_ok:
+            movl %eax,__RESULT
+         end;
+      end;
+    function get_segment_limit(d: word): dword;
+
+      begin
+         asm
+            movzwl d,%eax
+            lsl %eax,%eax
+            jz .L_ok2
+            xorl %eax,%eax
+         .L_ok2:
+            movl %eax,__RESULT
+         end;
+      end;
+
+    function create_code_segment_alias_descriptor(seg: word): word;
+
+      begin
+         asm
+            pushl %ebx
+            movw seg,%bx
+            movl $0xa,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movw %ax,__RESULT
+            popl %ebx
+         end;
+      end;
+
+    function get_meminfo(var meminfo: tmeminfo): boolean;
+
+      begin
+         asm
+            pushl %edi
+            movl meminfo,%edi
+            movl $0x500,%eax
+            int $0x31
+            pushf
+            movb %al,__RESULT
+            call test_int31
+            popl %edi
+         end;
+      end;
+
+    function get_linear_addr(phys_addr: dword;size: longint): dword;
+
+      begin
+         asm
+            pushl %ebx
+            pushl %edi
+            pushl %esi
+            movl phys_addr,%ebx
+            movl %ebx,%ecx
+            shrl $16,%ebx
+            movl size,%esi
+            movl %esi,%edi
+            shrl $16,%esi
+            movl $0x800,%eax
+            int $0x31
+            pushf
+            call test_int31
+            shll $16,%ebx
+            movw %cx,%bx
+            movl %ebx,__RESULT
+            popl %esi
+            popl %edi
+            popl %ebx
+         end;
+      end;
+
+    function free_linear_addr_mapping(linear_addr: dword): boolean;
+
+      begin
+         asm
+            pushl %ebx
+            pushl %ecx
+            movl linear_addr,%ebx
+            movl %ebx,%ecx
+            shrl $16,%ebx
+            movl $0x801,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+	    popl %ecx
+            popl %ebx
+         end;
+      end;
+
+    procedure disable;assembler;
+
+      asm
+         cli
+      end;
+
+    procedure enable;assembler;
+
+      asm
+         sti
+      end;
+
+
+    var
+      _run_mode: word;external name '_run_mode';
+
+    function get_run_mode: word;
+
+      begin
+         get_run_mode:=_run_mode;
+      end;
+
+    function map_device_in_memory_block(handle,offset,pagecount,device:dword):boolean;
+      begin
+         asm
+           pushl %ebx
+           pushl %edi
+           pushl %esi
+           movl device,%edx
+           movl handle,%esi
+           movl offset,%ebx
+           movl pagecount,%ecx
+           movl $0x0508,%eax
+           int $0x31
+           pushf
+           call test_int31
+           movb %al,__RESULT
+           popl %esi
+           popl %edi
+           popl %ebx
+         end;
+      end;
+
+    function get_page_attributes(handle, offset, pagecount: dword; buf: pointer): boolean;
+      begin
+         asm
+           pushl %ebx
+           pushl %ecx
+           pushl %edx
+           pushl %esi
+           pushw %es
+	   pushw %ds
+	   popw %es
+           movl buf,%edx
+           movl handle,%esi
+           movl offset,%ebx
+           movl pagecount,%ecx
+           movl $0x0506,%eax
+           int $0x31
+           pushf
+           call test_int31
+           movb %al,__RESULT
+	   popw %es
+           popl %esi
+           popl %edx
+           popl %ecx
+           popl %ebx
+	 end;
+      end;
+
+    function set_page_attributes(handle, offset, pagecount: dword; buf: pointer): boolean;
+      begin
+         asm
+           pushl %ebx
+           pushl %ecx
+           pushl %edx
+           pushl %esi
+           pushw %es
+	   pushw %ds
+	   popw %es
+           movl buf,%edx
+           movl handle,%esi
+           movl offset,%ebx
+           movl pagecount,%ecx
+           movl $0x0507,%eax
+           int $0x31
+           pushf
+           call test_int31
+           movb %al,__RESULT
+	   popw %es
+           popl %esi
+           popl %edx
+           popl %ecx
+           popl %ebx
+	 end;
+      end;
+
+    function get_dpmi_version(var version: tdpmiversioninfo): boolean;
+      var
+        _version, _flags, _cpu, _pic: word;
+      begin
+         asm
+           movl $0x0400,%eax
+           int $0x31
+           pushf
+	   movw %ax,_version
+	   movw %bx,_flags
+	   movw %cx,_cpu
+	   movw %dx,_pic
+           call test_int31
+           movb %al,__RESULT
+	 end ['EAX','EBX','ECX','EDX'];
+
+	 if get_dpmi_version then
+	 begin
+	   FillChar(version, SizeOf(version), 0);
+	   version.major := _version shr 8;
+	   version.minor := _version and $ff;
+	   version.flags := _flags;
+	   version.cpu := _cpu and $ff;
+	   version.master_pic := _pic shr 8;
+	   version.slave_pic := _pic and $ff;
+	 end;
+      end;
+
+{*****************************************************************************
+                              Transfer Buffer
+*****************************************************************************}
+
+    function transfer_buffer: longint;
+      begin
+         transfer_buffer := go32_info_block.linear_address_of_transfer_buffer;
+      end;
+
+
+    function tb_segment: longint;
+      begin
+        tb_segment:=go32_info_block.linear_address_of_transfer_buffer shr 4;
+      end;
+
+
+    function tb_offset: longint;
+      begin
+        tb_offset:=go32_info_block.linear_address_of_transfer_buffer and $f;
+      end;
+
+
+    function tb_size: longint;
+      begin
+         tb_size := go32_info_block.size_of_transfer_buffer;
+      end;
+
+
+    procedure copytodos(var addr; len: longint);
+       begin
+          if len>tb_size then
+            runerror(217);
+          seg_move(get_ds,longint(@addr),dosmemselector,transfer_buffer,len);
+       end;
+
+
+    procedure copyfromdos(var addr; len: longint);
+       begin
+          if len>tb_size then
+            runerror(217);
+          seg_move(dosmemselector,transfer_buffer,get_ds,longint(@addr),len);
+       end;
+
+
+    var
+      _core_selector: word;external name '_core_selector';
+
+begin
+   int31error:=0;
+   dosmemselector:=_core_selector;
+end.

packages/ptc/src/dos/base/kbd.inc

@@ -1,123 +1,93 @@
-Constructor TDosKeyboard.Create;
-
-Begin
-  { defaults }
-  m_key := False;
-  m_head := 0;
-  m_tail := 0;
-End;
-
-Destructor TDosKeyboard.Destroy;
-
-Begin
-  Inherited Destroy;
-End;
-
-Procedure TDosKeyboard.internal_ReadKey(k : TPTCKey);
-
-Var
-  read : TPTCKey;
-
-Begin
-  While Not ready Do;
-  read := remove;
-  Try
-    k.ASSign(read);
-  Finally
-    read.Free;
-  End;
-End;
-
-Function TDosKeyboard.internal_PeekKey(k : TPTCKey) : Boolean;
-
-Begin
-  Result := ready;
-  If Result = True Then
-    k.ASSign(m_buffer[m_tail]);
-End;
-
-Procedure TDosKeyboard.insert(_key : TPTCKey);
-
-Begin
-  { check for overflow }
-  If (m_head <> (m_tail - 1)) And
-    ((m_tail <> 0) Or (m_head <> High(m_buffer))) Then
-  Begin
-    { insert key at head }
-    m_buffer[m_head] := _key;
-
-    { increase head }
-    Inc(m_head);
-
-    { wrap head from end to start }
-    If m_head > High(m_buffer) Then
-      m_head := Low(m_buffer);
-  End;
-End;
-
-Function TDosKeyboard.remove : TPTCKey;
-
-Begin
-  { return key data from tail }
-  remove := m_buffer[m_tail];
-
-  { increase tail }
-  Inc(m_tail);
-
-  { wrap tail from end to start }
-  If m_tail > High(m_buffer) Then
-    m_tail := Low(m_buffer);
-End;
-
-Function TDosKeyboard.ready : Boolean;
-
-Var
-  c : Integer;
-  Ch, Ex : Char;
-
-Begin
-  If KeyPressed Then
-  Begin
+{
+    This file is part of the PTCPas framebuffer library
+    Copyright (C) 2001-2010 Nikolay Nikolov ([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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+{Constructor TDosKeyboard.Create;
+
+begin
+end;
+
+destructor TDosKeyboard.Destroy;
+
+begin
+  inherited Destroy;
+End;}
+
+procedure TDosKeyboard.GetPendingEvents(queue: TEventQueue);
+
+var
+  c: Integer;
+  Ch, Ex: Char;
+
+begin
+  while KeyPressed do
+  begin
     Ch := ReadKey;
-    If Ch = #0 Then
+    if Ch = #0 then
       Ex := ReadKey
-    Else
+    else
       Ex := #0;
-    If Ch <> #0 Then
-    Begin
+    if Ch <> #0 then
+    begin
       Ch := UpCase(Ch);
       c := Ord(Ch);
-    End
-    Else
-    Begin
-      Case Ord(Ex) Of
-        59 : c := PTCKEY_F1;
-        60 : c := PTCKEY_F2;
-        61 : c := PTCKEY_F3;
-        62 : c := PTCKEY_F4;
-        63 : c := PTCKEY_F5;
-        64 : c := PTCKEY_F6;
-        65 : c := PTCKEY_F7;
-        66 : c := PTCKEY_F8;
-        67 : c := PTCKEY_F9;
-        68 : c := PTCKEY_F10;
-        71 : c := PTCKEY_HOME;
-        72 : c := PTCKEY_UP;
-        73 : c := PTCKEY_PAGEUP;
-        75 : c := PTCKEY_LEFT;
-        76 : c := PTCKEY_NUMPAD5;
-        77 : c := PTCKEY_RIGHT;
-        79 : c := PTCKEY_END;
-        80 : c := PTCKEY_DOWN;
-        81 : c := PTCKEY_PAGEDOWN;
-        82 : c := PTCKEY_INSERT;
-        83 : c := PTCKEY_DELETE;
-        133 : c := PTCKEY_F11;
-        134 : c := PTCKEY_F12;
-      End;
-    End;
-    insert(TPTCKey.Create(c, False, False, False, True));
-    insert(TPTCKey.Create(c, False, False, False, False));
-  End;
-  ready := m_head <> m_tail;
-End;
+    end
+    else
+    begin
+      case Ord(Ex) of
+        59: c := PTCKEY_F1;
+        60: c := PTCKEY_F2;
+        61: c := PTCKEY_F3;
+        62: c := PTCKEY_F4;
+        63: c := PTCKEY_F5;
+        64: c := PTCKEY_F6;
+        65: c := PTCKEY_F7;
+        66: c := PTCKEY_F8;
+        67: c := PTCKEY_F9;
+        68: c := PTCKEY_F10;
+        71: c := PTCKEY_HOME;
+        72: c := PTCKEY_UP;
+        73: c := PTCKEY_PAGEUP;
+        75: c := PTCKEY_LEFT;
+        76: c := PTCKEY_NUMPAD5;
+        77: c := PTCKEY_RIGHT;
+        79: c := PTCKEY_END;
+        80: c := PTCKEY_DOWN;
+        81: c := PTCKEY_PAGEDOWN;
+        82: c := PTCKEY_INSERT;
+        83: c := PTCKEY_DELETE;
+        133: c := PTCKEY_F11;
+        134: c := PTCKEY_F12;
+      end;
+    end;
+    queue.AddEvent(TPTCKeyEvent.Create(c, False, False, False, True));
+    queue.AddEvent(TPTCKeyEvent.Create(c, False, False, False, False));
+  end;
+end;

packages/ptc/src/dos/base/kbdd.inc

@@ -1,29 +1,41 @@
-Type
-  TDosKeyboard = Class(TObject)
-  Private
-    { internal key functions }
-    Procedure insert(_key : TPTCKey);
-    Function remove : TPTCKey;
-    Function ready : Boolean;
+{
+    This file is part of the PTCPas framebuffer library
+    Copyright (C) 2001-2010 Nikolay Nikolov ([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
+    with the following modification:
 
-    { data }
-    m_key : Boolean;
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your version.
 
-    { modifiers }
-    m_alt : Boolean;
-    m_shift : Boolean;
-    m_control : Boolean;
+    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.
 
-    { key buffer }
-    m_head : Integer;
-    m_tail : Integer;
-    m_buffer : Array[0..1023] Of TPTCKey;
-  Public
+    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
+}
+
+type
+  TDosKeyboard = Class(TObject)
+  private
+  public
     { setup }
-    Constructor Create;
-    Destructor Destroy; Override;
+{    constructor Create;
+    destructor Destroy; Override;}
 
-    { input }
-    Procedure internal_ReadKey(k : TPTCKey);
-    Function internal_PeekKey(k : TPTCKey) : Boolean;
-  End;
+    procedure GetPendingEvents(queue: TEventQueue);
+  end;

packages/ptc/src/dos/base/mouse33h.pp

@@ -0,0 +1,170 @@
+{
+    This file is part of the PTCPas framebuffer library
+    Copyright (C) 2001-2010 Nikolay Nikolov ([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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+unit mouse33h;
+
+{$MODE objfpc}
+
+interface
+
+procedure InitMouse;
+procedure ShowCursor;
+procedure HideCursor;
+procedure ReadMouse(Out X, Y: Integer; Out Left, Right, Middle: Boolean);
+procedure MoveMouseTo(const X, Y: Integer);
+procedure SetHCursorRange(const MinX, MaxX: Integer);
+procedure SetVCursorRange(const MinY, MaxY: Integer);
+procedure SetCursorRange(const MinX, MinY, MaxX, MaxY: Integer);
+
+var
+  MousePresent: Boolean = False;
+
+implementation
+
+uses
+  go32fix;
+
+procedure InitMouse;
+
+var
+  RealRegs: TRealRegs;
+
+begin
+  { todo: check if INT 33 vector is neither 0000h:0000h nor points at an IRET instruction (BYTE CFh) }
+  RealRegs.AX := $0000;
+  realintr($33, RealRegs);
+  MousePresent := RealRegs.AX = $FFFF;
+  if MousePresent then
+  begin
+    { RealRegs.BX is number of buttons:
+      according to ralf brown's interrupts list
+      0000h other than two
+      0002h two buttons (many drivers)
+      0003h Mouse Systems/Logitech three-button mouse
+      FFFFh two buttons }
+
+    { ... }
+  end;
+end;
+
+procedure ShowCursor;
+
+var
+  RealRegs: TRealRegs;
+
+begin
+  Assert(MousePresent);
+
+  RealRegs.AX := $0001;
+  realintr($33, RealRegs);
+end;
+
+procedure HideCursor;
+
+var
+  RealRegs: TRealRegs;
+
+begin
+  Assert(MousePresent);
+
+  RealRegs.AX := $0002;
+  realintr($33, RealRegs);
+end;
+
+procedure ReadMouse(Out X, Y: Integer; Out Left, Right, Middle: Boolean);
+
+var
+  RealRegs: TRealRegs;
+
+begin
+  Assert(MousePresent);
+
+  RealRegs.AX := $0003;
+  realintr($33, RealRegs);
+  X := RealRegs.CX;
+  Y := RealRegs.DX;
+  Left := RealRegs.BX and 1 <> 0;
+  Right := RealRegs.BX and 2 <> 0;
+  Middle := RealRegs.BX and 4 <> 0;
+end;
+
+procedure MoveMouseTo(const X, Y: Integer);
+
+var
+  RealRegs: TRealRegs;
+
+begin
+  Assert(MousePresent);
+
+  RealRegs.AX := $0004;
+  RealRegs.CX := X;
+  RealRegs.DX := Y;
+  realintr($33, RealRegs);
+end;
+
+procedure SetHCursorRange(const MinX, MaxX: Integer);
+
+var
+  RealRegs: TRealRegs;
+
+begin
+  Assert(MousePresent);
+  Assert(MinX <= MaxX);
+
+  RealRegs.AX := $0007;
+  RealRegs.CX := MinX;
+  RealRegs.DX := MaxX;
+  realintr($33, RealRegs);
+end;
+
+procedure SetVCursorRange(const MinY, MaxY: Integer);
+
+var
+  RealRegs: TRealRegs;
+
+begin
+  Assert(MousePresent);
+  Assert(MinY <= MaxY);
+
+  RealRegs.AX := $0008;
+  RealRegs.CX := MinY;
+  RealRegs.DX := MaxY;
+  realintr($33, RealRegs);
+end;
+
+procedure SetCursorRange(const MinX, MinY, MaxX, MaxY: Integer);
+
+begin
+  SetHCursorRange(MinX, MaxX);
+  SetVCursorRange(MinY, MaxY);
+end;
+
+end.

packages/ptc/src/dos/base/moused.inc

@@ -0,0 +1,50 @@
+{
+    Free Pascal port of the OpenPTC C++ library.
+    Copyright (C) 2001-2006  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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TDosMouse = Class(TObject)
+  private
+    FMousePresent: Boolean;
+
+    FWidth, FHeight: Integer;
+
+    FPreviousMouseButtonState: TPTCMouseButtonState;
+    FPreviousMouseX, FPreviousMouseY: Integer; { for calculating the deltas }
+    FPreviousMousePositionSaved: Boolean; { true, if FPreviousMouseX,
+           FPreviousMouseY and FPreviousMouseButtonState contain valid values }
+  public
+    { setup }
+    constructor Create(Width, Height: Integer);
+{    destructor Destroy; Override;}
+
+    procedure GetPendingEvents(queue: TEventQueue);
+  end;

packages/ptc/src/dos/base/mousei.inc

@@ -0,0 +1,127 @@
+{
+    Free Pascal port of the OpenPTC C++ library.
+    Copyright (C) 2001-2006  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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+constructor TDosMouse.Create(Width, Height: Integer);
+
+begin
+  FWidth := Width;
+  FHeight := Height;
+
+  FPreviousMousePositionSaved := False;
+
+  mouse33h.InitMouse;
+  FMousePresent := mouse33h.MousePresent;
+
+  if FMousePresent then
+  begin
+    mouse33h.SetCursorRange(0, 0, FWidth - 1, FHeight - 1);
+    mouse33h.MoveMouseTo(FWidth div 2, FHeight div 2);
+  end;
+end;
+
+procedure TDosMouse.GetPendingEvents(queue: TEventQueue);
+
+var
+  X, Y: Integer;
+  Left, Right, Middle: Boolean;
+  PTCMouseButtonState: TPTCMouseButtonState;
+
+  button: TPTCMouseButton;
+  before, after: Boolean;
+  cstate: TPTCMouseButtonState;
+
+begin
+  if not FMousePresent then
+    exit;
+
+  mouse33h.ReadMouse(X, Y, Left, Right, Middle);
+
+  PTCMouseButtonState := [];
+  if Left then
+    PTCMouseButtonState := PTCMouseButtonState + [PTCMouseButton1];
+  if Right then
+    PTCMouseButtonState := PTCMouseButtonState + [PTCMouseButton2];
+  if Middle then
+    PTCMouseButtonState := PTCMouseButtonState + [PTCMouseButton3];
+
+  if X >= FWidth - 1 then
+    X := FWidth - 1;
+  if Y >= FHeight - 1 then
+    Y := FHeight - 1;
+  if X <= 0 then
+    X := 0;
+  if Y <= 0 then
+    Y := 0;
+
+  { has something new happened? }
+  if (not FPreviousMousePositionSaved) or
+     (X <> FPreviousMouseX) or (Y <> FPreviousMouseY) or
+     (PTCMouseButtonState <> FPreviousMouseButtonState) then
+  begin
+    if not FPreviousMousePositionSaved then
+    begin
+      FPreviousMouseX := X; { first DeltaX will be 0 }
+      FPreviousMouseY := Y; { first DeltaY will be 0 }
+      FPreviousMouseButtonState := [];
+    end;
+
+    { movement? }
+    if (X <> FPreviousMouseX) or (Y <> FPreviousMouseY) then
+      queue.AddEvent(TPTCMouseEvent.Create(X, Y, X - FPreviousMouseX, Y - FPreviousMouseY, FPreviousMouseButtonState));
+
+    { button presses/releases? }
+    cstate := FPreviousMouseButtonState;
+    for button := Low(button) to High(button) do
+    begin
+      before := button In FPreviousMouseButtonState;
+      after := button In PTCMouseButtonState;
+      if after and (not before) then
+      begin
+        { button was pressed }
+        cstate := cstate + [button];
+        queue.AddEvent(TPTCMouseButtonEvent.Create(x, y, 0, 0, cstate, True, button));
+      end
+      else
+        if before and (not after) then
+        begin
+          { button was released }
+          cstate := cstate - [button];
+          queue.AddEvent(TPTCMouseButtonEvent.Create(x, y, 0, 0, cstate, False, button));
+        end;
+    end;
+
+    FPreviousMouseX := X;
+    FPreviousMouseY := Y;
+    FPreviousMouseButtonState := PTCMouseButtonState;
+    FPreviousMousePositionSaved := True;
+  end;
+end;

packages/ptc/src/dos/cga/cga.pp

@@ -1,257 +1,292 @@
+{
+    This file is part of the PTCPas framebuffer library
+    Copyright (C) 2001-2010 Nikolay Nikolov ([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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+unit CGA;
+
 {$MODE objfpc}
 {$ASMMODE intel}
+{$INLINE on}
 
-Unit CGA;
-
-Interface
+interface
 
-Procedure CGAText;
-Procedure CGA320;
-Procedure CGA640;
-Procedure CGADump(q : PByte);
-Procedure CGASetPalette(palette, border : Integer);
-Procedure CGAPrecalc;
+procedure CGAText;
+procedure CGA320;
+procedure CGA640;
+procedure CGADump(q: PByte);
+procedure CGASetPalette(palette, border: Integer);
+procedure CGAPrecalc;
+procedure CGAFree;
 
-Implementation
+implementation
 
-Uses
-  go32, crt;
+uses
+  go32fix, crt;
 
-Const
-  palette : Array[0..15, 0..2] Of Byte = (
+const
+  palette: array[0..15, 0..2] of Byte = (
     ( 0, 0, 0), ( 0, 0,42), ( 0,42, 0), ( 0,42,42), (42, 0, 0), (42, 0,42), (42,21, 0), (42,42,42),
     (21,21,21), (21,21,63), (21,63,21), (21,63,63), (63,21,21), (63,21,63), (63,63,21), (63,63,63));
-  cgaback : Array[0..3, 0..12] Of Integer = (
+  cgaback: array[0..3, 0..12] of Integer = (
     (  0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 11, 13, 15),
     (  0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 12, 14),
     (  0,  1,  3,  5,  7,  8,  9, 10, 11, 12, 13, 14, 15),
     (  0,  1,  2,  4,  6,  8,  9, 10, 11, 12, 13, 14, 15));
 
-Type
+type
   Float = Extended;
-  TCGAVideoBuffer = Array[0..16383] Of Byte;
+  TCGAVideoBuffer = array[0..16383] of Byte;
   PCGAPrecalc = ^TCGAPrecalc;
-  TCGAPrecalc = Array[0..15{r}, 0..15{g}, 0..15{b}, 0..3{y}, 0..3{x}] Of Byte;
+  TCGAPrecalc = array[0..15{r}, 0..15{g}, 0..15{b}, 0..3{y}, 0..3{x}] of Byte;
   PCGAPrecalcError = ^TCGAPrecalcError;
-  TCGAPrecalcError = Array[0..15{r}, 0..15{g}, 0..15{b}] Of Integer;
+  TCGAPrecalcError = array[0..15{r}, 0..15{g}, 0..15{b}] of Integer;
 
-Var
-  cgapal : Array[0..3] Of Integer;
-  videobuf : TCGAVideoBuffer;
-  precalcbuf : Array[0..12, 0..3] Of PCGAPrecalc; {3.25mb}
-  precalcerror : Array[0..12, 0..3] Of PCGAPrecalcError; {0.8125mb}
-  error : Integer;
-  lastpalette, lastback : Integer;
+var
+  cgapal: array[0..3] of Integer;
+  videobuf: TCGAVideoBuffer;
+  precalcbuf: array[0..12, 0..3] of PCGAPrecalc; {3.25mb}
+  precalcerror: array[0..12, 0..3] of PCGAPrecalcError; {0.8125mb}
+  error: Integer;
+  lastpalette, lastback: Integer;
 
-Procedure CGA320;
+procedure CGA320;
 
-Var
-  regs : TRealRegs;
+var
+  regs: TRealRegs;
 
-Begin
+begin
   regs.ax := $0004;
   RealIntr($10, regs);
   lastpalette := -1;
   lastback := -1;
-End;
+end;
 
-Procedure CGA640;
+procedure CGA640;
 
-Var
-  regs : TRealRegs;
+var
+  regs: TRealRegs;
 
-Begin
-  regs.ax := $0004;
+begin
+  regs.ax := $0006;
   RealIntr($10, regs);
-End;
+end;
 
-Procedure CGAText;
+procedure CGAText;
 
-Var
-  regs : TRealRegs;
+var
+  regs: TRealRegs;
 
-Begin
+begin
   regs.ax := $0003;
   RealIntr($10, regs);
-End;
+end;
 
-Procedure CGASetPalette(palette, border : Integer);
+procedure CGASetPalette(palette, border: Integer);
 
-Var
-  regs : TRealRegs;
+var
+  regs: TRealRegs;
 
-Begin
-  If (palette = lastpalette) And (border = lastback) Then
-    Exit;
+begin
+  if (palette = lastpalette) and (border = lastback) then
+    exit;
   lastpalette := palette;
   lastback := border;
   regs.ah := $0B;
   regs.bh := 1;
-  regs.bl := palette And 1;
+  regs.bl := palette and 1;
   RealIntr($10, regs);
-  If (palette And 2) = 0 Then
+  if (palette and 2) = 0 then
     Inc(border, 16);
   regs.ah := $0B;
   regs.bh := 0;
   regs.bl := border;
   RealIntr($10, regs);
-End;
+end;
 
-Procedure CGABlitToScreen(p : Pointer); Assembler;
+procedure CGABlitToScreen(p: Pointer); assembler; register;
 
-Asm
+asm
+  mov esi, p
   mov edi, $B8000
   push es
   mov ax, fs
   mov es, ax
-  mov esi, [p]
   mov ecx, 16192/4
   rep movsd
   pop es
-End;
+end;
+
+function ColorDistance(r1, g1, b1, r2, g2, b2: Integer): Integer;
+
+var
+  RMean: Integer;
 
-Function CGACalc2(r, g, b : Integer; dx, dy : Integer; back, pal : Integer) : Integer;{ Inline;}
+begin
+//  Result := Sqr(r1 - r2) + Sqr(g1 - g2) + Sqr(b1 - b2);
 
-Begin
-  CGACalc2 := precalcbuf[back, pal]^[r Shr 4, g Shr 4, b Shr 4, dy, dx];
-End;
+  { formula taken from: http://www.compuphase.com/cmetric.htm }
+  RMean := (r1 + r2) div 2;
+  Result := ((512 + RMean)*Sqr(r1 - r2) shr 8) + 4*Sqr(g1 - g2) + ((767 - RMean)*Sqr(b1 - b2) shr 8);
+end;
 
-Procedure CGACalc(r, g, b : Integer; {dx, dy : Integer;}
-                  Var dither, best1, best2 : Integer);
+function CGACalc2(r, g, b: Integer; dx, dy: Integer; back, pal: Integer): Integer; inline;
 
-Var
-  I, J : Integer;
-  mindist : Float;
-  dist : Float;
-  r1, g1, b1 : Integer;
-  tmp : Integer;
-{  dither : Integer;} {0-none; 1-50%; 2-25%; 3-12.5%; 4-37.5%}
+begin
+  Result := precalcbuf[back, pal]^[r shr 4, g shr 4, b shr 4, dy, dx];
+end;
 
-Begin
+procedure CGACalc(r, g, b: Integer; var dither, best1, best2: Integer);
+
+var
+  I, J: Integer;
+  mindist: Float;
+  dist: Float;
+  r1, g1, b1: Integer;
+  tmp: Integer;
+{  dither: Integer;} {0-none; 1-50%; 2-25%; 3-12.5%; 4-37.5%}
+
+begin
   r := Round(r*63 / 15);
   g := Round(g*63 / 15);
   b := Round(b*63 / 15);
   mindist := $7FFFFFFF;
-  For I := 0 To 3 Do
-  Begin
-    dist := Sqr(r - palette[cgapal[I], 0]) +
-            Sqr(g - palette[cgapal[I], 1]) +
-            Sqr(b - palette[cgapal[I], 2]);
-    If dist < mindist Then
-    Begin
+  for I := 0 to 3 do
+  begin
+    dist := ColorDistance(r, g, b, palette[cgapal[I], 0], palette[cgapal[I], 1], palette[cgapal[I], 2]);
+    if dist < mindist then
+    begin
       mindist := dist;
       best1 := I;
       dither := 0;
-    End;
-  End;
+    end;
+  end;
 
-  For J := 0 To 3 Do
-  Begin
+  for J := 0 to 3 do
+  begin
     r1 := palette[cgapal[J], 0];
     g1 := palette[cgapal[J], 1];
     b1 := palette[cgapal[J], 2];
-    For I := 0 To 3 Do
-    Begin
-      If I = J Then
-        Continue;
-      dist := Sqr(r - (palette[cgapal[I], 0] + r1)*0.5) +
-              Sqr(g - (palette[cgapal[I], 1] + g1)*0.5) +
-              Sqr(b - (palette[cgapal[I], 2] + b1)*0.5);
-      If dist < mindist Then
-      Begin
+    for I := 0 to 3 do
+    begin
+      if I = J then
+        continue;
+      dist := ColorDistance(r, g, b, (palette[cgapal[I], 0] + r1) div 2, (palette[cgapal[I], 1] + g1) div 2, (palette[cgapal[I], 2] + b1) div 2);
+      if dist < mindist then
+      begin
         mindist := dist;
         best1 := J;
         best2 := I;
         dither := 1;
-      End;
-      dist := Sqr(r - (0.25*palette[cgapal[I], 0] + 0.75*r1)) +
-              Sqr(g - (0.25*palette[cgapal[I], 1] + 0.75*g1)) +
-              Sqr(b - (0.25*palette[cgapal[I], 2] + 0.75*b1));
-      If dist < mindist Then
-      Begin
+      end;
+      dist := ColorDistance(r, g, b, (palette[cgapal[I], 0] + 3*r1) div 4, (palette[cgapal[I], 1] + 3*g1) div 4, (palette[cgapal[I], 2] + 3*b1) div 4);
+      if dist < mindist then
+      begin
         mindist := dist;
         best1 := J;
         best2 := I;
         dither := 2;
-      End;
-      dist := Sqr(r - (0.125*palette[cgapal[I], 0] + 0.875*r1)) +
-              Sqr(g - (0.125*palette[cgapal[I], 1] + 0.875*g1)) +
-              Sqr(b - (0.125*palette[cgapal[I], 2] + 0.875*b1));
-      If dist < mindist Then
-      Begin
+      end;
+      dist := ColorDistance(r, g, b, (palette[cgapal[I], 0] + 7*r1) div 8, (palette[cgapal[I], 1] + 7*g1) div 8, (palette[cgapal[I], 2] + 7*b1) div 8);
+      if dist < mindist then
+      begin
         mindist := dist;
         best1 := J;
         best2 := I;
         dither := 3;
-      End;
-      dist := Sqr(r - (0.375*palette[cgapal[I], 0] + 0.625*r1)) +
-              Sqr(g - (0.375*palette[cgapal[I], 1] + 0.625*g1)) +
-              Sqr(b - (0.375*palette[cgapal[I], 2] + 0.625*b1));
-      If dist < mindist Then
-      Begin
+      end;
+      dist := ColorDistance(r, g, b, (3*palette[cgapal[I], 0] + 5*r1) div 8, (3*palette[cgapal[I], 1] + 5*g1) div 8, (3*palette[cgapal[I], 2] + 5*b1) div 8);
+      if dist < mindist then
+      begin
         mindist := dist;
         best1 := J;
         best2 := I;
         dither := 4;
-      End;
-    End;
-  End;
-
-  error:=error+round(Sqrt(mindist) * 290);
-  Case dither Of
-    0 : best2 := best1;
-    1 : Begin
-      If best1 > best2 Then
-      Begin
+      end;
+    end;
+  end;
+
+  error := error + Round(Sqrt(mindist) * {290}40);
+  case dither of
+    0: best2 := best1;
+    1: begin
+      if best1 > best2 then
+      begin
         tmp := best1;
         best1 := best2;
         best2 := tmp;
-      End;
-    End;
-  End;
-End;
-
-Function CGACalcError(s : PByte; back, pal : Integer) : Integer;
-
-Var
-  X, Y : Integer;
-  r, g, b : Integer;
-
-Begin
-  CGACalcError := 0;
-  For Y := 0 To 199 {Div 4} Do
-  Begin
-    For X := 0 To 319 {Div 4} Do
-    Begin
+      end;
+    end;
+  end;
+end;
+
+function CGACalcError(s: PByte; back, pal: Integer): Integer;
+
+var
+  X, Y: Integer;
+  r, g, b: Integer;
+
+begin
+  Result := 0;
+  for Y := 0 to 199 {div 4} do
+  begin
+    for X := 0 to 319 {div 4} do
+    begin
       b := s[0];
       g := s[1];
       r := s[2];
-      inc(CGACalcError,precalcerror[back, pal]^[b Shr 4, g Shr 4, r Shr 4]);
-      Inc(s, 4{ + 4 + 4 + 4});
-    End;
-//    Inc(s, 320*4*3);
-  End;
-End;
-
-Procedure CGADump2(s, d : PByte; back, pal : Integer);
-
-Var
-  I : Integer;
-  src, dest : PByte;
-  X, Y : Integer;
-  r1, g1, b1 : Integer;
-  r2, g2, b2 : Integer;
-  r3, g3, b3 : Integer;
-  r4, g4, b4 : Integer;
-
-Begin
+      Inc(Result, precalcerror[back, pal]^[b shr 4, g shr 4, r shr 4]);
+      Inc(s, 4 {+ 4 + 4 + 4});
+    end;
+    {Inc(s, 320*4*3);}
+  end;
+end;
+
+procedure CGADump2(s, d: PByte; back, pal: Integer);
+
+var
+  I: Integer;
+  src, dest: PByte;
+  X, Y: Integer;
+  r1, g1, b1: Integer;
+  r2, g2, b2: Integer;
+  r3, g3, b3: Integer;
+  r4, g4, b4: Integer;
+
+begin
   error := 0;
   src := s;
   dest := d;
-  For Y := 0 To 99 Do
-  Begin
-    For X := 0 To 79 Do
-    Begin
+  for Y := 0 to 99 do
+  begin
+    for X := 0 to 79 do
+    begin
       b1 := src[0];
       g1 := src[1];
       r1 := src[2];
@@ -264,22 +299,22 @@ Begin
       b4 := src[12];
       g4 := src[13];
       r4 := src[14];
-      dest^ := (CGACalc2(r1, g1, b1, 0, (Y And 1) Shl 1, back, pal) Shl 6) Or
-               (CGACalc2(r2, g2, b2, 1, (Y And 1) Shl 1, back, pal) Shl 4) Or
-               (CGACalc2(r3, g3, b3, 2, (Y And 1) Shl 1, back, pal) Shl 2) Or
-               (CGACalc2(r4, g4, b4, 3, (Y And 1) Shl 1, back, pal));
+      dest^ := (CGACalc2(r1, g1, b1, 0, (Y and 1) shl 1, back, pal) shl 6) or
+               (CGACalc2(r2, g2, b2, 1, (Y and 1) shl 1, back, pal) shl 4) or
+               (CGACalc2(r3, g3, b3, 2, (Y and 1) shl 1, back, pal) shl 2) or
+               (CGACalc2(r4, g4, b4, 3, (Y and 1) shl 1, back, pal));
 
       Inc(src, 4*4);
       Inc(dest);
-    End;
+    end;
     Inc(src, 320*4);
-  End;
+  end;
   src := s + 320*4;
   dest := d + 8192;
-  For Y := 0 To 99 Do
-  Begin
-    For X := 0 To 79 Do
-    Begin
+  for Y := 0 to 99 do
+  begin
+    for X := 0 to 79 do
+    begin
       b1 := src[0];
       g1 := src[1];
       r1 := src[2];
@@ -292,95 +327,96 @@ Begin
       b4 := src[12];
       g4 := src[13];
       r4 := src[14];
-      dest^ := (CGACalc2(r1, g1, b1, 0, ((Y And 1) Shl 1) + 1, back, pal) Shl 6) Or
-               (CGACalc2(r2, g2, b2, 1, ((Y And 1) Shl 1) + 1, back, pal) Shl 4) Or
-               (CGACalc2(r3, g3, b3, 2, ((Y And 1) Shl 1) + 1, back, pal) Shl 2) Or
-               (CGACalc2(r4, g4, b4, 3, ((Y And 1) Shl 1) + 1, back, pal));
+      dest^ := (CGACalc2(r1, g1, b1, 0, ((Y and 1) shl 1) + 1, back, pal) shl 6) or
+               (CGACalc2(r2, g2, b2, 1, ((Y and 1) shl 1) + 1, back, pal) shl 4) or
+               (CGACalc2(r3, g3, b3, 2, ((Y and 1) shl 1) + 1, back, pal) shl 2) or
+               (CGACalc2(r4, g4, b4, 3, ((Y and 1) shl 1) + 1, back, pal));
 
       Inc(src, 4*4);
       Inc(dest);
-    End;
+    end;
     Inc(src, 320*4);
-  End;
-End;
+  end;
+end;
 
-Procedure CGADump(q : PByte);
+procedure CGADump(q: PByte);
 
-Var
-  pal, back : Integer;
-  bestpal, bestback : Integer;
-  besterror : Integer;
+var
+  pal, back: Integer;
+  bestpal, bestback: Integer;
+  besterror: Integer;
 
-Begin
+begin
   besterror := $7FFFFFFF;
-  For pal := 0 To 3 Do
-  Begin
-    For back := 0 To 12 Do
-    Begin
+  for pal := 0 to 3 do
+  begin
+    for back := 0 to 12 do
+    begin
       error := CGACalcError(q, back, pal);
-      If error < besterror Then
-      Begin
+      if error < besterror then
+      begin
         besterror := error;
         bestpal := pal;
         bestback := back;
-      End;
-    End;
-  End;
+      end;
+    end;
+  end;
 
   CGADump2(q, videobuf, bestback, bestpal);
 
   CGASetPalette(bestpal, cgaback[bestpal, bestback]);
   CGABlitToScreen(@videobuf);
-End;
-
-Procedure CGAPrecalc;
-
-Var
-  pal, back : Integer;
-  r, g, b : Integer;
-  x, y : Integer;
-  dither : Integer;
-  best1, best2 : Integer;
-  res : Integer;
-
-Begin
-  For pal := 0 To 3 Do
-  Begin
-    Case pal Of
-      0 : Begin
+end;
+
+procedure CGAPrecalc;
+
+var
+  pal, back: Integer;
+  r, g, b: Integer;
+  x, y: Integer;
+  dither: Integer;
+  best1, best2: Integer;
+  res: Integer;
+
+begin
+  Writeln('Precalculating CGA lookup tables, please wait...');
+  for pal := 0 to 3 do
+  begin
+    case pal of
+      0: begin
         cgapal[1] := 10;
         cgapal[2] := 12;
         cgapal[3] := 14;
-      End;
-      1 : Begin
+      end;
+      1: begin
         cgapal[1] := 11;
         cgapal[2] := 13;
         cgapal[3] := 15;
-      End;
-      2 : Begin
+      end;
+      2: begin
         cgapal[1] := 2;
         cgapal[2] := 4;
         cgapal[3] := 6;
-      End;
-      3 : Begin
+      end;
+      3: begin
         cgapal[1] := 3;
         cgapal[2] := 5;
         cgapal[3] := 7;
-      End;
-    End;
-    For back := 0 To 12 Do
-    Begin
-      If (precalcbuf[back, pal] = Nil) And (precalcerror[back, pal] = Nil) Then
-      Begin
-        New(precalcbuf[back, pal]);
-        New(precalcerror[back, pal]);
-      End
-      Else
-        Continue;
+      end;
+    end;
+    for back := 0 to 12 do
+    begin
+      if (precalcbuf[back, pal] = nil) and (precalcerror[back, pal] = nil) then
+      begin
+        new(precalcbuf[back, pal]);
+        new(precalcerror[back, pal]);
+      end
+      else
+        continue;
 
       cgapal[0] := cgaback[pal, back];
       error := 0;
-      Write(pal, back:3, ' ');
+      Write('  (');
       TextAttr := cgapal[0];
       Write('*');
       TextAttr := cgapal[1];
@@ -388,54 +424,83 @@ Begin
       TextAttr := cgapal[2];
       Write('*');
       TextAttr := cgapal[3];
-      Writeln('*');
+      Write('*');
       TextAttr := 7;
-      For r := 0 To 15 Do
-        For g := 0 To 15 Do
-          For b := 0 To 15 Do
-          Begin
+      Write(')');
+      for r := 0 to 15 do
+        for g := 0 to 15 do
+          for b := 0 to 15 do
+          begin
             error := 0;
             CGACalc(r, g, b, dither, best1, best2);
             precalcerror[back, pal]^[r, g, b] := error;
-            For y := 0 To 3 Do
-              For x := 0 To 3 Do
-              Begin
-                Case dither Of
-                  0 : res := best1;
-                  1 : Begin
-                    If ((x + y) And 1) <> 0 Then
+            for y := 0 to 3 do
+              for x := 0 to 3 do
+              begin
+                case dither of
+                  0: res := best1;
+                  1: begin
+                    if ((x + y) and 1) <> 0 then
                       res := best1
-                    Else
+                    else
                       res := best2;
-                  End;
-                  2 : Begin
-                    If ((x And 1) = 0) And ((y And 1) = 0) Then
+                  end;
+                  2: begin
+                    if ((x and 1) = 0) and ((y and 1) = 0) then
                       res := best2
-                    Else
+                    else
                       res := best1;
-                  End;
-                  3 : Begin
-                    If (x = y) And ((x And 1) = 0) Then
+                  end;
+                  3: begin
+                    if (x = y) and ((x and 1) = 0) then
                       res := best2
-                    Else
+                    else
                       res := best1;
-                  End;
-                  4 : Begin
-                    If (((x And 1) = 0) And ((y And 1) = 0)) Or (x = y) Then
+                  end;
+                  4: begin
+                    if (((x and 1) = 0) and ((y and 1) = 0)) or (x = y) then
                       res := best2
-                    Else
+                    else
                       res := best1;
-                  End;
-                End;
+                  end;
+                end;
                 precalcbuf[back, pal]^[r, g, b, y, x] := res;
-              End;
-          End;
-      //Function CGACalc(r, g, b : Integer; dx, dy : Integer) : Integer;
-    End;
-  End;
-End;
-
-Begin
+              end;
+          end;
+    end;
+  end;
+end;
+
+procedure CGAFree;
+
+var
+  pal, back: Integer;
+
+begin
+  for pal := 0 to 3 do
+  begin
+    for back := 0 to 12 do
+    begin
+      if precalcbuf[back, pal] <> nil then
+      begin
+        dispose(precalcbuf[back, pal]);
+	precalcbuf[back, pal] := nil;
+      end;
+      
+      if precalcerror[back, pal] <> nil then
+      begin
+        dispose(precalcerror[back, pal]);
+	precalcerror[back, pal] := nil;
+      end;
+    end;
+  end;
+end;
+
+initialization
   FillChar(precalcbuf, SizeOf(precalcbuf), 0);
   FillChar(precalcerror, SizeOf(precalcerror), 0);
-End.
+
+finalization
+  CGAFree;
+
+end.

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

@@ -0,0 +1,134 @@
+{
+    This file is part of the PTCPas framebuffer library
+    Copyright (C) 2001-2010 Nikolay Nikolov ([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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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
+}
+
+type
+  TCGAConsole = Class(TPTCBaseConsole)
+  private
+    { data }
+    m_modes: array [0..255] of TPTCMode;
+    m_title: string;
+    m_information: string;
+
+    { flags }
+    m_open: Boolean;
+    m_locked: Boolean;
+
+    { option data }
+    m_default_width: Integer;
+    m_default_height: Integer;
+    m_default_format: TPTCFormat;
+
+    { objects }
+    m_copy: TPTCCopy;
+    m_clear: TPTCClear;
+
+    FEventQueue: TEventQueue;
+
+    { Dos objects }
+    m_keyboard: TDosKeyboard;
+    FMouse: TDosMouse;
+    m_primary: TPTCSurface;
+
+    { internal console management routines }
+    procedure internal_pre_open_setup(const _title: String);
+    procedure internal_open_fullscreen_start;
+    procedure internal_open_fullscreen(_width, _height: Integer; const _format: TPTCFormat);
+    procedure internal_open_fullscreen_finish(_pages: Integer);
+    procedure internal_post_open_setup;
+    procedure internal_reset;
+    procedure internal_close;
+
+    procedure HandleEvents;
+
+    { console debug checks }
+    procedure check_open;
+    procedure check_unlocked;
+  public
+    constructor Create; override;
+    destructor Destroy; override;
+    procedure Configure(const AFileName: String); override;
+    function option(const _option: String): Boolean; override;
+    function modes: PPTCMode; override;
+    procedure open(const _title: string; _pages: Integer); overload; override;
+    procedure open(const _title: string; const _format: TPTCFormat;
+                   _pages: Integer); overload; override;
+    procedure open(const _title: string; _width, _height: Integer;
+                   const _format: TPTCFormat; _pages: Integer); overload; override;
+    procedure open(const _title: string; const _mode: TPTCMode;
+                   _pages: Integer); overload; override;
+    procedure close; override;
+    procedure flush; override;
+    procedure finish; override;
+    procedure update; override;
+    procedure update(const _area: TPTCArea); override;
+    procedure copy(surface: TPTCBaseSurface); override;
+    procedure copy(surface: TPTCBaseSurface;
+                   const source, destination: TPTCArea); override;
+    function lock: Pointer; override;
+    procedure unlock; override;
+    procedure load(const pixels: Pointer;
+                   _width, _height, _pitch: Integer;
+                   const _format: TPTCFormat;
+                   const _palette: TPTCPalette); override;
+    procedure load(const pixels: Pointer;
+                   _width, _height, _pitch: Integer;
+                   const _format: TPTCFormat;
+                   const _palette: TPTCPalette;
+                   const source, destination: TPTCArea); override;
+    procedure save(pixels: Pointer;
+                   _width, _height, _pitch: Integer;
+                   const _format: TPTCFormat;
+                   const _palette: TPTCPalette); override;
+    procedure save(pixels: Pointer;
+                   _width, _height, _pitch: Integer;
+                   const _format: TPTCFormat;
+                   const _palette: TPTCPalette;
+                   const source, destination: TPTCArea); override;
+    procedure clear; override;
+    procedure clear(const color: TPTCColor); override;
+    procedure clear(const color: TPTCColor;
+                    const _area: TPTCArea); override;
+    procedure Palette(const _palette: TPTCPalette); override;
+    function Palette: TPTCPalette; override;
+    procedure Clip(const _area: TPTCArea); override;
+    function GetWidth: Integer; override;
+    function GetHeight: Integer; override;
+    function GetPitch: Integer; override;
+    function GetPages: Integer; override;
+    function GetArea: TPTCArea; override;
+    function Clip: TPTCArea; override;
+    function GetFormat: TPTCFormat; override;
+    function GetName: string; override;
+    function GetTitle: string; override;
+    function GetInformation: string; override;
+    function NextEvent(var event: TPTCEvent; wait: Boolean; const EventMask: TPTCEventMask): Boolean; override;
+    function PeekEvent(wait: Boolean; const EventMask: TPTCEventMask): TPTCEvent; override;
+  end;

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

@@ -0,0 +1,739 @@
+{
+    This file is part of the PTCPas framebuffer library
+    Copyright (C) 2001-2010 Nikolay Nikolov ([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
+    with the following modification:
+
+    As a special exception, the copyright holders of this library give you
+    permission to link this library with independent modules to produce an
+    executable, regardless of the license terms of these independent modules,and
+    to copy and distribute the resulting executable under terms of your choice,
+    provided that you also meet, for each linked independent module, the terms
+    and conditions of the license of that module. An independent module is a
+    module which is not derived from or based on this library. If you modify
+    this library, you may extend this exception to your version of the library,
+    but you are not obligated to do so. If you do not wish to do so, delete this
+    exception statement from your 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)}
+
+constructor TCGAConsole.Create;
+
+var
+  I: Integer;
+
+begin
+  inherited Create;
+
+  m_open := False;
+  m_locked := False;
+  FillChar(m_modes, SizeOf(m_modes), 0);
+  m_title := '';
+  m_information := '';
+  m_default_width := DEFAULT_WIDTH;
+  m_default_height := DEFAULT_HEIGHT;
+  m_default_format := DEFAULT_FORMAT;
+
+  for I := 0 to 255 do
+    m_modes[I] := TPTCMode.Create;
+
+  m_copy := TPTCCopy.Create;
+  m_clear := TPTCClear.Create;
+  Configure('ptcpas.cfg');
+end;
+
+destructor TCGAConsole.Destroy;
+
+var
+  I: Integer;
+
+begin
+  close;
+  for I := 0 to 255 do
+    m_modes[I].Free;
+  m_keyboard.Free;
+  FMouse.Free;
+  FEventQueue.Free;
+  m_copy.Free;
+  m_clear.Free;
+  m_default_format.Free;
+  inherited Destroy;
+end;
+
+procedure TCGAConsole.Configure(const AFileName: String);
+
+var
+  F: Text;
+  S: string;
+
+begin
+  AssignFile(F, AFileName);
+  {$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 TCGAConsole.option(const _option: String): Boolean;
+
+begin
+  {...}
+  if _option = 'enable logging' then
+  begin
+    LOG_enabled := True;
+    Result := True;
+    exit;
+  end;
+  if _option = 'disable logging' then
+  begin
+    LOG_enabled := False;
+    Result := True;
+    exit;
+  end;
+
+  Result := m_copy.option(_option);
+end;
+
+function TCGAConsole.modes: PPTCMode;
+
+begin
+  Result := @m_modes;
+end;
+
+procedure TCGAConsole.open(const _title: string; _pages: Integer); overload;
+
+begin
+  open(_title, m_default_format, _pages);
+end;
+
+procedure TCGAConsole.open(const _title: string; const _format: TPTCFormat;
+                           _pages: Integer); overload;
+
+begin
+  open(_title, m_default_width, m_default_height, _format, _pages);
+end;
+
+procedure TCGAConsole.open(const _title: string; _width, _height: Integer;
+                           const _format: TPTCFormat; _pages: Integer); overload;
+
+var
+  m: TPTCMode;
+
+begin
+  m := TPTCMode.Create(_width, _height, _format);
+  try
+    open(_title, m, _pages);
+  finally
+    m.Free;
+  end;
+end;
+
+procedure TCGAConsole.open(const _title: string; const _mode: TPTCMode;
+                           _pages: Integer); overload;
+
+var
+  _width, _height: Integer;
+  _format: TPTCFormat;
+
+begin
+  if not _mode.valid then
+    raise TPTCError.Create('invalid mode');
+
+  _width := _mode.width;
+  _height := _mode.height;
+  _format := _mode.format;
+
+  internal_pre_open_setup(_title);
+  internal_open_fullscreen_start;
+  internal_open_fullscreen(_width, _height, _format);
+  internal_open_fullscreen_finish(_pages);
+  internal_post_open_setup;
+end;
+
+procedure TCGAConsole.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;
+    internal_close;
+    m_open := False;
+  end;
+end;
+
+procedure TCGAConsole.flush;
+
+begin
+  check_open;
+  check_unlocked;
+end;
+
+procedure TCGAConsole.finish;
+
+begin
+  check_open;
+  check_unlocked;
+end;
+
+procedure TCGAConsole.update;
+
+var
+  framebuffer: PByte;
+
+begin
+  check_open;
+  check_unlocked;
+  framebuffer := m_primary.lock;
+  try
+{    vrc;}
+    CGADump(framebuffer);
+  finally
+    m_primary.unlock;
+  end;
+end;
+
+procedure TCGAConsole.update(const _area: TPTCArea);
+
+begin
+  update;
+end;
+
+procedure TCGAConsole.copy(surface: TPTCBaseSurface);
+
+var
+  pixels: Pointer;
+
+begin
+  check_open;
+  check_unlocked;
+  pixels := lock;
+  try
+    try
+      surface.load(pixels, width, height, pitch, format, palette);
+    finally
+      unlock;
+    end;
+  except
+    on error: TPTCError do
+      raise TPTCError.Create('failed to copy console to surface', error);
+
+  end;
+end;
+
+procedure TCGAConsole.copy(surface: TPTCBaseSurface;
+                           const source, destination: TPTCArea);
+
+var
+  pixels: Pointer;
+
+begin
+  check_open;
+  check_unlocked;
+  pixels := lock;
+  try
+    try
+      surface.load(pixels, width, height, pitch, format, palette, source, destination);
+    finally
+      unlock;
+    end;
+  except
+    on error: TPTCError do
+      raise TPTCError.Create('failed to copy console to surface', error);
+
+  end;
+end;
+
+function TCGAConsole.lock: Pointer;
+
+var
+  pixels: Pointer;
+
+begin
+  check_open;
+  if m_locked then
+    raise TPTCError.Create('console is already locked');
+
+  pixels := m_primary.lock;
+  m_locked := True;
+  Result := pixels;
+end;
+
+procedure TCGAConsole.unlock;
+
+begin
+  check_open;
+  if not m_locked then
+    raise TPTCError.Create('console is not locked');
+
+  m_primary.unlock;
+  m_locked := False;
+end;
+
+procedure TCGAConsole.load(const pixels: Pointer;
+                           _width, _height, _pitch: Integer;
+                           const _format: TPTCFormat;
+                           const _palette: TPTCPalette);
+var
+  Area_: TPTCArea;
+  console_pixels: Pointer;
+
+begin
+  check_open;
+  check_unlocked;
+  if clip.Equals(area) then
+  begin
+    try
+      console_pixels := lock;
+      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);
+      finally
+        unlock;
+      end;
+    except
+      on error: TPTCError do
+        raise TPTCError.Create('failed to load pixels to console', error);
+
+    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 TCGAConsole.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;
+  check_unlocked;
+  clipped_source := nil;
+  clipped_destination := nil;
+  try
+    console_pixels := lock;
+    try
+      clipped_source := TPTCArea.Create;
+      clipped_destination := TPTCArea.Create;
+      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);
+    finally
+      unlock;
+      clipped_source.Free;
+      clipped_destination.Free;
+    end;
+  except
+    on error:TPTCError do
+      raise TPTCError.Create('failed to load pixels to console area', error);
+
+  end;
+end;
+
+procedure TCGAConsole.save(pixels: Pointer;
+                           _width, _height, _pitch: Integer;
+                           const _format: TPTCFormat;
+                           const _palette: TPTCPalette);
+var
+  Area_: TPTCArea;
+  console_pixels: Pointer;
+
+begin
+  check_open;
+  check_unlocked;
+  if clip.Equals(area) then
+  begin
+    try
+      console_pixels := lock;
+      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);
+      finally
+        unlock;
+      end;
+    except
+      on error: TPTCError do
+        raise TPTCError.Create('failed to save console pixels', error);
+
+    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 TCGAConsole.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;
+  check_unlocked;
+  clipped_source := nil;
+  clipped_destination := nil;
+  try
+    console_pixels := lock;
+    try
+      clipped_source := TPTCArea.Create;
+      clipped_destination := TPTCArea.Create;
+      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);
+    finally
+      unlock;
+      clipped_source.Free;
+      clipped_destination.Free;
+    end;
+  except
+    on error:TPTCError do
+      raise TPTCError.Create('failed to save console area pixels', error);
+
+  end;
+end;
+
+procedure TCGAConsole.clear;
+
+var
+  tmp: TPTCColor;
+
+begin
+  check_open;
+  check_unlocked;
+  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 TCGAConsole.clear(const color: TPTCColor);
+
+var
+  tmp: TPTCArea;
+
+begin
+  check_open;
+  check_unlocked;
+  tmp := TPTCArea.Create;
+  try
+    clear(color, tmp);
+  finally
+    tmp.Free;
+  end;
+end;
+
+procedure TCGAConsole.clear(const color: TPTCColor;
+                            const _area: TPTCArea);
+
+var
+  pixels: Pointer;
+  clipped_area: TPTCArea;
+
+begin
+  check_open;
+  check_unlocked;
+  try
+    clipped_area := nil;
+    pixels := lock;
+    try
+      clipped_area := TPTCClipper.clip(_area, clip);
+      m_clear.request(format);
+      m_clear.clear(pixels, clipped_area.left, clipped_area.right, clipped_area.width, clipped_area.height, pitch, color);
+    finally
+      unlock;
+      clipped_area.Free;
+    end;
+  except
+    on error: TPTCError do
+      raise TPTCError.Create('failed to clear console area', error);
+
+  end;
+end;
+
+procedure TCGAConsole.Palette(const _palette: TPTCPalette);
+
+begin
+  check_open;
+  m_primary.palette(_palette);
+end;
+
+function TCGAConsole.Palette: TPTCPalette;
+
+begin
+  check_open;
+  Result := m_primary.palette;
+end;
+
+procedure TCGAConsole.Clip(const _area: TPTCArea);
+
+begin
+  check_open;
+  m_primary.clip(_area);
+end;
+
+function TCGAConsole.GetWidth: Integer;
+
+begin
+  check_open;
+  Result := m_primary.width;
+end;
+
+function TCGAConsole.GetHeight: Integer;
+
+begin
+  check_open;
+  Result := m_primary.height;
+end;
+
+function TCGAConsole.GetPitch: Integer;
+
+begin
+  check_open;
+  Result := m_primary.pitch;
+end;
+
+function TCGAConsole.GetPages: Integer;
+
+begin
+  check_open;
+  Result := 2;
+end;
+
+function TCGAConsole.GetArea: TPTCArea;
+
+begin
+  check_open;
+  Result := m_primary.area;
+end;
+
+function TCGAConsole.Clip: TPTCArea;
+
+begin
+  check_open;
+  Result := m_primary.clip;
+end;
+
+function TCGAConsole.GetFormat: TPTCFormat;
+
+begin
+  check_open;
+  Result := m_primary.format;
+end;
+
+function TCGAConsole.GetName: string;
+
+begin
+  Result := 'CGA';
+end;
+
+function TCGAConsole.GetTitle: string;
+
+begin
+  Result := m_title;
+end;
+
+function TCGAConsole.GetInformation: string;
+
+begin
+  Result := m_information;
+end;
+
+procedure TCGAConsole.internal_pre_open_setup(const _title: String);
+
+begin
+  m_title := _title;
+end;
+
+procedure TCGAConsole.internal_open_fullscreen_start;
+
+var
+  f: TPTCFormat;
+
+begin
+  CGAPrecalc;
+
+  f := TPTCFormat.Create(32, $FF0000, $00FF00, $0000FF);
+  try
+    m_primary := TPTCSurface.Create(320, 200, f);
+  finally
+    f.Free;
+  end;
+
+  CGA320;
+end;
+
+procedure TCGAConsole.internal_open_fullscreen(_width, _height: Integer; const _format: TPTCFormat);
+
+begin
+end;
+
+procedure TCGAConsole.internal_open_fullscreen_finish(_pages: Integer);
+
+begin
+end;
+
+procedure TCGAConsole.internal_post_open_setup;
+
+begin
+  FreeAndNil(m_keyboard);
+  FreeAndNil(FMouse);
+  FreeAndNil(FEventQueue);
+  m_keyboard := TDosKeyboard.Create;
+  FMouse := TDosMouse.Create(m_primary.width, m_primary.height);
+  FEventQueue := TEventQueue.Create;
+
+  { temporary platform dependent information fudge }
+  m_information := 'dos version x.xx.x, CGA, 320x200 - 4 colors';
+
+  { set open flag }
+  m_open := True;
+end;
+
+procedure TCGAConsole.internal_reset;
+
+begin
+  FreeAndNil(m_primary);
+  FreeAndNil(m_keyboard);
+  FreeAndNil(FMouse);
+  FreeAndNil(FEventQueue);
+end;
+
+procedure TCGAConsole.internal_close;
+
+begin
+  FreeAndNil(m_primary);
+  FreeAndNil(m_keyboard);
+  FreeAndNil(FMouse);
+  FreeAndNil(FEventQueue);
+
+  CGAText;
+end;
+
+procedure TCGAConsole.HandleEvents;
+
+begin
+  m_keyboard.GetPendingEvents(FEventQueue);
+  FMouse.GetPendingEvents(FEventQueue);
+end;
+
+function TCGAConsole.NextEvent(var event: TPTCEvent; wait: Boolean; const EventMask: TPTCEventMask): Boolean;
+
+begin
+  check_open;
+
+  FreeAndNil(event);
+  repeat
+    { get events }
+    HandleEvents;
+
+    { try to find an event that matches the EventMask }
+    event := FEventQueue.NextEvent(EventMask);
+  until (not Wait) or (event <> Nil);
+  Result := event <> nil;
+end;
+
+function TCGAConsole.PeekEvent(wait: Boolean; const EventMask: TPTCEventMask): TPTCEvent;
+
+begin
+  check_open;
+
+  repeat
+    { get events }
+    HandleEvents;
+
+    { try to find an event that matches the EventMask }
+    Result := FEventQueue.PeekEvent(EventMask);
+  until (not Wait) or (Result <> Nil);
+end;
+
+procedure TCGAConsole.check_open;
+
+begin
+  if not m_open then
+    raise TPTCError.Create('console is not open');
+end;
+
+procedure TCGAConsole.check_unlocked;
+
+begin
+  if m_locked then
+    raise TPTCError.Create('console is not unlocked');
+end;

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

@@ -1,600 +0,0 @@
-{$MACRO ON}
-
-{$DEFINE DEFAULT_WIDTH:=320}
-{$DEFINE DEFAULT_HEIGHT:=200}
-{$DEFINE DEFAULT_FORMAT:=TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF)}
-
-Constructor CGAConsole.Create;
-
-Var
-  I : Integer;
-
-Begin
-{  m_160x100buffer := Nil;}
-  m_primary := Nil;
-  m_keyboard := Nil;
-  m_copy := Nil;
-  m_default_format := Nil;
-  m_open := False;
-  m_locked := False;
-  FillChar(m_modes, SizeOf(m_modes), 0);
-  m_title[0] := #0;
-  m_information[0] := #0;
-  m_default_width := DEFAULT_WIDTH;
-  m_default_height := DEFAULT_HEIGHT;
-  m_default_format := DEFAULT_FORMAT;
-
-
-  For I := 0 To 255 Do
-    m_modes[I] := TPTCMode.Create;
-
-  calcpal := @calcpal_colorbase;
-  use_charset := @charset_b7asc;
-  build_colormap(0);
-  m_copy := TPTCCopy.Create;
-  configure('ptc.cfg');
-End;
-
-Destructor CGAConsole.Destroy;
-
-Var
-  I : Integer;
-
-Begin
-  close;
-  For I := 0 To 255 Do
-    If m_modes[I] <> Nil Then
-      m_modes[I].Destroy;
-  If m_keyboard <> Nil Then
-    m_keyboard.Destroy;
-  If m_copy <> Nil Then
-    m_copy.Destroy;
-  If m_default_format <> Nil Then
-    m_default_format.Destroy;
-  Inherited Destroy;
-End;
-
-Procedure CGAConsole.configure(Const _file : String);
-
-Var
-  F : Text;
-  S : String;
-
-Begin
-  ASSign(F, _file);
-  Try
-    Reset(F);
-  Except
-    Exit;
-  End;
-  Try
-    While Not EoF(F) Do
-    Begin
-      Readln(F, S);
-      option(S);
-    End;
-  Finally
-    CloseFile(F);
-  End;
-End;
-
-Function CGAConsole.option(Const _option : String) : Boolean;
-
-Begin
-  {...}
-  option := m_copy.option(_option);
-End;
-
-Function CGAConsole.modes : PPTCMode;
-
-Begin
-  {todo...}
-  modes := @m_modes;
-End;
-
-Procedure CGAConsole.open(Const _title : String; _pages : Integer); Overload;
-
-Begin
-  open(_title, m_default_format, _pages);
-End;
-
-Procedure CGAConsole.open(Const _title : String; Const _format : TPTCFormat;
-                           _pages : Integer); Overload;
-
-Begin
-  open(_title, m_default_width, m_default_height, _format, _pages);
-End;
-
-Procedure CGAConsole.open(Const _title : String; _width, _height : Integer;
-                           Const _format : TPTCFormat; _pages : Integer); Overload;
-
-Var
-  m : TPTCMode;
-
-Begin
-  m := TPTCMode.Create(_width, _height, _format);
-  open(_title, m, _pages);
-  m.Destroy;
-End;
-
-Procedure CGAConsole.open(Const _title : String; Const _mode : TPTCMode;
-                           _pages : Integer); Overload;
-
-Var
-  _width, _height : Integer;
-  _format : TPTCFormat;
-
-Begin
-  If Not _mode.valid Then
-    Raise TPTCError.Create('invalid mode');
-  _width := _mode.width;
-  _height := _mode.height;
-  _format := _mode.format;
-  internal_pre_open_setup(_title);
-  internal_open_fullscreen_start;
-  internal_open_fullscreen(_width, _height, _format);
-  internal_open_fullscreen_finish(_pages);
-  internal_post_open_setup;
-End;
-
-Procedure CGAConsole.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;
-    internal_close;
-    m_open := False;
-  End;
-End;
-
-Procedure CGAConsole.flush;
-
-Begin
-  check_open;
-  check_unlocked;
-End;
-
-Procedure CGAConsole.finish;
-
-Begin
-  check_open;
-  check_unlocked;
-End;
-
-Procedure CGAConsole.update;
-
-Var
-  framebuffer : PByte;
-
-Begin
-  check_open;
-  check_unlocked;
-  framebuffer := m_primary.lock;
-{  vrc;}
-  CGADump(framebuffer);
-  m_primary.unlock;
-End;
-
-Procedure CGAConsole.update(Const _area : TPTCArea);
-
-Begin
-  update;
-End;
-
-Procedure CGAConsole.internal_ReadKey(k : TPTCKey);
-
-Begin
-  check_open;
-  m_keyboard.internal_ReadKey(k);
-End;
-
-Function CGAConsole.internal_PeekKey(k : TPTCKey) : Boolean;
-
-Begin
-  check_open;
-  Result := m_keyboard.internal_PeekKey(k);
-End;
-
-Procedure CGAConsole.copy(Var surface : TPTCBaseSurface);
-
-Var
-  pixels : Pointer;
-
-Begin
-  check_open;
-  check_unlocked;
-  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 CGAConsole.copy(Var surface : TPTCBaseSurface;
-                           Const source, destination : TPTCArea);
-
-Begin
-End;
-
-Function CGAConsole.lock : Pointer;
-
-Var
-  pixels : Pointer;
-
-Begin
-  check_open;
-  If m_locked Then
-    Raise TPTCError.Create('console is already locked');
-  pixels := m_primary.lock;
-  m_locked := True;
-  lock := pixels;
-End;
-
-Procedure CGAConsole.unlock;
-
-Begin
-  check_open;
-  If Not m_locked Then
-    Raise TPTCError.Create('console is not locked');
-  m_primary.unlock;
-  m_locked := False;
-End;
-
-Procedure CGAConsole.load(Const pixels : Pointer;
-                           _width, _height, _pitch : Integer;
-                           Const _format : TPTCFormat;
-                           Const _palette : TPTCPalette);
-Var
-  Area_ : TPTCArea;
-  console_pixels : Pointer;
-  c, a : TPTCArea;
-
-Begin
-  c := clip; a := area;
-  If (c.left = a.left) And
-     (c.top = a.top) And
-     (c.right = a.right) And
-     (c.bottom = a.bottom) Then
-  Begin
-    check_open;
-    check_unlocked;
-    console_pixels := lock;
-    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);
-      unlock;
-    Except
-      On error : TPTCError Do
-      Begin
-        unlock;
-        Raise TPTCError.Create('failed to load pixels to console', error);
-      End;
-    End;
-  End
-  Else
-  Begin
-    Area_ := TPTCArea.Create(0, 0, width, height);
-    load(pixels, _width, _height, _pitch, _format, _palette, Area_, area);
-    Area_.Destroy;
-  End;
-End;
-
-Procedure CGAConsole.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;
-  check_unlocked;
-  console_pixels := lock;
-  clipped_source := TPTCArea.Create;
-  clipped_destination := TPTCArea.Create;
-  Try
-    tmp := TPTCArea.Create(0, 0, _width, _height);
-    TPTCClipper.clip(source, tmp, clipped_source, destination, clip, clipped_destination);
-    tmp.Destroy;
-    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);
-    unlock;
-  Except
-    On error:TPTCError Do
-    Begin
-      clipped_source.Destroy;
-      clipped_destination.Destroy;
-      unlock;
-      Raise TPTCError.Create('failed to load pixels to console area', error);
-    End;
-  End;
-  clipped_source.Destroy;
-  clipped_destination.Destroy;
-End;
-
-Procedure CGAConsole.save(pixels : Pointer;
-                           _width, _height, _pitch : Integer;
-                           Const _format : TPTCFormat;
-                           Const _palette : TPTCPalette);
-Var
-  Area_ : TPTCArea;
-  console_pixels : Pointer;
-  c, a : TPTCArea;
-
-Begin
-  c := clip; a := area;
-  If (c.left = a.left) And
-     (c.top = a.top) And
-     (c.right = a.right) And
-     (c.bottom = a.bottom) Then
-  Begin
-    check_open;
-    check_unlocked;
-    console_pixels := lock;
-    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);
-      unlock;
-    Except
-      On error : TPTCError Do
-      Begin
-        unlock;
-        Raise TPTCError.Create('failed to save console pixels', error);
-      End;
-    End;
-  End
-  Else
-  Begin
-    Area_ := TPTCArea.Create(0, 0, width, height);
-    save(pixels, _width, _height, _pitch, _format, _palette, area, Area_);
-    Area_.Destroy;
-  End;
-End;
-
-Procedure CGAConsole.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;
-  check_unlocked;
-  console_pixels := lock;
-  clipped_source := TPTCArea.Create;
-  clipped_destination := TPTCArea.Create;
-  Try
-    tmp := TPTCArea.Create(0, 0, _width, _height);
-    TPTCClipper.clip(source, clip, clipped_source, destination, tmp, clipped_destination);
-    tmp.Destroy;
-    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);
-    unlock;
-  Except
-    On error:TPTCError Do
-    Begin
-      clipped_source.Destroy;
-      clipped_destination.Destroy;
-      unlock;
-      Raise TPTCError.Create('failed to save console area pixels', error);
-    End;
-  End;
-  clipped_source.Destroy;
-  clipped_destination.Destroy;
-End;
-
-Procedure CGAConsole.clear;
-
-Begin
-End;
-
-Procedure CGAConsole.clear(Const color : TPTCColor);
-
-Begin
-End;
-
-Procedure CGAConsole.clear(Const color : TPTCColor;
-                           Const _area : TPTCArea);
-
-Begin
-End;
-
-Procedure CGAConsole.palette(Const _palette : TPTCPalette);
-
-Begin
-  check_open;
-  m_primary.palette(_palette);
-End;
-
-Function CGAConsole.palette : TPTCPalette;
-
-Begin
-  check_open;
-  palette := m_primary.palette;
-End;
-
-Procedure CGAConsole.clip(Const _area : TPTCArea);
-
-Begin
-  check_open;
-  m_primary.clip(_area);
-End;
-
-Function CGAConsole.width : Integer;
-
-Begin
-  check_open;
-  width := m_primary.width;
-End;
-
-Function CGAConsole.height : Integer;
-
-Begin
-  check_open;
-  height := m_primary.height;
-End;
-
-Function CGAConsole.pitch : Integer;
-
-Begin
-  check_open;
-  pitch := m_primary.pitch;
-End;
-
-Function CGAConsole.pages : Integer;
-
-Begin
-  check_open;
-  pages := 1;{m_primary.pages;}
-End;
-
-Function CGAConsole.area : TPTCArea;
-
-Begin
-  check_open;
-  area := m_primary.area;
-End;
-
-Function CGAConsole.clip : TPTCArea;
-
-Begin
-  check_open;
-  clip := m_primary.clip;
-End;
-
-Function CGAConsole.format : TPTCFormat;
-
-Begin
-  check_open;
-  format := m_primary.format;
-End;
-
-Function CGAConsole.name : String;
-
-Begin
-End;
-
-Function CGAConsole.title : String;
-
-Begin
-End;
-
-Function CGAConsole.information : String;
-
-Begin
-End;
-
-Procedure CGAConsole.internal_pre_open_setup(Const _title : String);
-
-Begin
-
-End;
-
-Procedure CGAConsole.internal_open_fullscreen_start;
-
-Var
-  f : TPTCFormat;
-
-Begin
-  CGAPrecalc;
-  f := TPTCFormat.Create(32, $FF0000, $00FF00, $0000FF);
-  m_primary := TPTCSurface.Create(320, 200, f);
-  f.Destroy;
-{  set80x50;}
-  CGA320;
-End;
-
-Procedure CGAConsole.internal_open_fullscreen(_width, _height : Integer; Const _format : TPTCFormat);
-
-Begin
-{  m_primary := TPTCSurface.Create(_width, _height, _format);}
-End;
-
-Procedure CGAConsole.internal_open_fullscreen_finish(_pages : Integer);
-
-Begin
-End;
-
-Procedure CGAConsole.internal_post_open_setup;
-
-Begin
-  If m_keyboard <> Nil Then
-    m_keyboard.Destroy;
-  m_keyboard := TDosKeyboard.Create;
-  { create win32 keyboard
-  m_keyboard = new DosKeyboard();//m_window->handle(),m_window->thread(),false);}
-
-  { temporary platform dependent information fudge }
-  {sprintf(m_information,"dos version x.xx.x\nvesa version x.xx\nvesa driver name xxxxx\ndisplay driver vendor xxxxx\ncertified driver? x\n");}
-
-  { set open flag }
-  m_open := True;
-End;
-
-Procedure CGAConsole.internal_reset;
-
-Begin
-  If m_primary <> Nil Then
-    m_primary.Destroy;
-{  m_keyboard.Destroy;}
-  m_primary := Nil;
-{  m_keyboard := Nil;}
-End;
-
-Procedure CGAConsole.internal_close;
-
-Begin
-  If m_primary <> Nil Then
-    m_primary.Destroy;
-  m_primary := Nil;
-{  If m_160x100buffer <> Nil Then
-    m_160x100buffer.Destroy;
-  m_160x100buffer := Nil;}
-  CGAText;
-{  m_keyboard.Destroy;
-  m_keyboard := Nil;}
-End;
-
-Procedure CGAConsole.check_open;
-
-Begin
-  {$IFDEF DEBUG}
-    If Not m_open Then
-      Raise TPTCError.Create('console is not open');
-  {$ENDIF}
-End;
-
-Procedure CGAConsole.check_unlocked;
-
-Begin
-  {$IFDEF DEBUG}
-    If m_locked Then
-      Raise TPTCError.Create('console is not unlocked');
-  {$ENDIF}
-End;

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

@@ -1,100 +0,0 @@
-Type
-  CGAConsole = Class(TPTCBaseConsole)
-  Private
-    { internal console management routines }
-    Procedure internal_pre_open_setup(Const _title : String);
-    Procedure internal_open_fullscreen_start;
-    Procedure internal_open_fullscreen(_width, _height : Integer; Const _format : TPTCFormat);
-    Procedure internal_open_fullscreen_finish(_pages : Integer);
-    Procedure internal_post_open_setup;
-    Procedure internal_reset;
-    Procedure internal_close;
-
-    { console debug checks }
-    Procedure check_open;
-    Procedure check_unlocked;
-
-    { data }
-    m_modes : Array[0..255] Of TPTCMode;
-    m_title : Array[0..1023] Of Char;
-    m_information : Array[0..1023] Of Char;
-
-    { flags }
-    m_open : Boolean;
-    m_locked : Boolean;
-
-    { option data }
-    m_default_width : Integer;
-    m_default_height : Integer;
-    m_default_pages : Integer;
-    m_default_format : TPTCFormat;
-
-    { objects }
-    m_copy : TPTCCopy;
-
-    { Dos objects }
-    m_keyboard : TDosKeyboard;
-    m_primary : TPTCSurface;
-{    m_160x100buffer : TPTCSurface;}
-  Protected
-    Procedure internal_ReadKey(k : TPTCKey); Override;
-    Function internal_PeekKey(k : TPTCKey) : Boolean; Override;
-  Public
-    Constructor Create;
-    Destructor Destroy; Override;
-    Procedure configure(Const _file : String); Override;
-    Function option(Const _option : String) : Boolean; Override;
-    Function modes : PPTCMode; Override;
-    Procedure open(Const _title : String; _pages : Integer); Overload; Override;
-    Procedure open(Const _title : String; Const _format : TPTCFormat;
-                   _pages : Integer); Overload; Override;
-    Procedure open(Const _title : String; _width, _height : Integer;
-                   Const _format : TPTCFormat; _pages : Integer); Overload; Override;
-    Procedure open(Const _title : String; Const _mode : TPTCMode;
-                   _pages : Integer); Overload; Override;
-    Procedure close; Override;
-    Procedure flush; Override;
-    Procedure finish; Override;
-    Procedure update; Override;
-    Procedure update(Const _area : TPTCArea); Override;
-    Procedure copy(Var surface : TPTCBaseSurface); Override;
-    Procedure copy(Var surface : TPTCBaseSurface;
-                   Const source, destination : TPTCArea); Override;
-    Function lock : Pointer; Override;
-    Procedure unlock; Override;
-    Procedure load(Const pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette); Override;
-    Procedure load(Const pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette;
-                   Const source, destination : TPTCArea); Override;
-    Procedure save(pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette); Override;
-    Procedure save(pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette;
-                   Const source, destination : TPTCArea); Override;
-    Procedure clear; Override;
-    Procedure clear(Const color : TPTCColor); Override;
-    Procedure clear(Const color : TPTCColor;
-                    Const _area : TPTCArea); Override;
-    Procedure palette(Const _palette : TPTCPalette); Override;
-    Function palette : TPTCPalette; Override;
-    Procedure clip(Const _area : TPTCArea); Override;
-    Function width : Integer; Override;
-    Function height : Integer; Override;
-    Function pitch : Integer; Override;
-    Function pages : Integer; Override;
-    Function area : TPTCArea; Override;
-    Function clip : TPTCArea; Override;
-    Function format : TPTCFormat; Override;
-    Function name : String; Override;
-    Function title : String; Override;
-    Function information : String; Override;
-  End;

packages/ptc/src/dos/fakemode/console.inc

@@ -1,806 +0,0 @@
-{$MACRO ON}
-
-{$DEFINE DEFAULT_WIDTH:=320}
-{$DEFINE DEFAULT_HEIGHT:=200}
-{$DEFINE DEFAULT_FORMAT:=TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF)}
-
-{$ASMMODE intel}
-
-Constructor VGAConsole.Create;
-
-Var
-{  I, J : Integer;
-  r, g, b, a : DWord;
-  tmpbpp : Integer;}
-  tmp : TPTCFormat;
-
-Begin
-  m_area := Nil;
-  m_clip := Nil;
-  m_keyboard := Nil;
-  m_copy := Nil;
-  m_palette := Nil;
-  m_default_format := Nil;
-  m_open := False;
-  m_locked := False;
-  m_title[0] := #0;
-  m_information[0] := #0;
-  m_default_width := DEFAULT_WIDTH;
-  m_default_height := DEFAULT_HEIGHT;
-  m_default_format := DEFAULT_FORMAT;
-
-{  InitVESA;}
-  m_primary := Nil;
-{  m_modes[0].Create;}
-
-  m_area := TPTCArea.Create;
-  m_clip := TPTCArea.Create;
-  m_copy := TPTCCopy.Create;
-  m_palette := TPTCPalette.Create;
-
-  tmp := TPTCFormat.Create(8);
-  m_modes[0] := TPTCMode.Create(320, 200, tmp);
-  tmp.Destroy;
-  tmp := TPTCFormat.Create(8, $E0, $1C, $03);
-  m_modes[1] := TPTCMode.Create(320, 200, tmp);
-  tmp.Destroy;
-  tmp := TPTCFormat.Create(16, $F800, $7E0, $1F);
-  m_modes[2] := TPTCMode.Create(320, 200, tmp);
-  tmp.Destroy;
-  m_modes[3] := TPTCMode.Create;
-  m_faketype := FAKEMODE2A;
-
-  configure('ptc.cfg');
-End;
-
-Destructor VGAConsole.Destroy;
-
-Begin
-  close;
-  internal_clear_mode_list;
-  If m_keyboard <> Nil Then
-    m_keyboard.Destroy;
-  If m_copy <> Nil Then
-    m_copy.Destroy;
-  If m_default_format <> Nil Then
-    m_default_format.Destroy;
-  If m_palette <> Nil Then
-    m_palette.Destroy;
-  If m_clip <> Nil Then
-    m_clip.Destroy;
-  If m_area <> Nil Then
-    m_area.Destroy;
-  Inherited Destroy;
-End;
-
-Procedure VGAConsole.configure(Const _file : String);
-
-Var
-  F : Text;
-  S : String;
-
-Begin
-  ASSign(F, _file);
-  Try
-    Reset(F);
-  Except
-    Exit;
-  End;
-  Try
-    While Not EoF(F) Do
-    Begin
-      Readln(F, S);
-      option(S);
-    End;
-  Finally
-    CloseFile(F);
-  End;
-End;
-
-Function VGAConsole.option(Const _option : String) : Boolean;
-
-Begin
-  {...}
-  If (System.Copy(_option, 1, 8) = 'FAKEMODE') And (Length(_option) = 10) And
-    (_option[9] >= '1') And (_option[9] <= '3') And
-    (_option[10] >= 'A') And (_option[10] <= 'C') Then
-  Begin
-    Case _option[9] Of
-      '1' : Case _option[10] Of
-        'A' : m_faketype := FAKEMODE1A;
-        'B' : m_faketype := FAKEMODE1B;
-        'C' : m_faketype := FAKEMODE1C;
-      End;
-      '2' : Case _option[10] Of
-        'A' : m_faketype := FAKEMODE2A;
-        'B' : m_faketype := FAKEMODE2B;
-        'C' : m_faketype := FAKEMODE2C;
-      End;
-      '3' : Case _option[10] Of
-        'A' : m_faketype := FAKEMODE3A;
-        'B' : m_faketype := FAKEMODE3B;
-        'C' : m_faketype := FAKEMODE3C;
-      End;
-    End;
-    option := True;
-    Exit;
-  End;
-  option := m_copy.option(_option);
-End;
-
-Procedure VGAConsole.internal_clear_mode_list;
-
-Var
-  I : Integer;
-  Done : Boolean;
-
-Begin
-  I := 0;
-  Done := False;
-  Repeat
-    Done := Not m_modes[I].valid;
-    m_modes[I].Destroy;
-    Inc(I);
-  Until Done;
-End;
-
-Function VGAConsole.modes : PPTCMode;
-
-Begin
-{  internal_clear_mode_list;}
-
-  modes := m_modes;
-End;
-
-Procedure VGAConsole.open(Const _title : String; _pages : Integer); Overload;
-
-Begin
-  open(_title, m_default_format, _pages);
-End;
-
-Procedure VGAConsole.open(Const _title : String; Const _format : TPTCFormat;
-                           _pages : Integer); Overload;
-
-Begin
-  open(_title, m_default_width, m_default_height, _format, _pages);
-End;
-
-Procedure VGAConsole.open(Const _title : String; _width, _height : Integer;
-                           Const _format : TPTCFormat; _pages : Integer); Overload;
-
-Var
-  m : TPTCMode;
-
-Begin
-  m := TPTCMode.Create(_width, _height, _format);
-  Try
-    open(_title, m, _pages);
-  Finally
-    m.Destroy;
-  End;
-End;
-
-Procedure VGAConsole.open(Const _title : String; Const _mode : TPTCMode;
-                           _pages : Integer); Overload;
-
-Var
-{  _width, _height : Integer;
-  _format : TPTCFormat;}
-  I : Integer;
-{  modefound : Integer;}
-  modetype : Integer;
-
-Begin
-  If Not _mode.valid Then
-    Raise TPTCError.Create('invalid mode');
-  If _mode.format.indexed Then
-    modetype := INDEX8
-  Else
-    If _mode.format.bits = 8 Then
-      modetype := RGB332
-    Else
-      modetype := FAKEMODE;
-  internal_pre_open_setup(_title);
-  internal_open_fullscreen_start;
-  internal_open_fullscreen(modetype);
-  internal_open_fullscreen_finish(_pages);
-  internal_post_open_setup;
-End;
-
-Procedure VGAConsole.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;
-    internal_close;
-    m_open := False;
-  End;
-End;
-
-Procedure VGAConsole.flush;
-
-Begin
-  check_open;
-  check_unlocked;
-End;
-
-Procedure VGAConsole.finish;
-
-Begin
-  check_open;
-  check_unlocked;
-End;
-
-Procedure VGAConsole.vga_load(data : Pointer); ASSembler;
-
-Asm
-  push es
-  mov ax, fs
-  mov es, ax
-  mov ecx, 64000/4
-  mov esi, [data]
-  mov edi, 0A0000h
-  cld
-  rep movsd
-  pop es
-End;
-
-Procedure VGAConsole.update;
-
-Var
-  framebuffer : PInteger;
-
-Begin
-  check_open;
-  check_unlocked;
-  Case m_CurrentMode Of
-    0, 1 : Begin
-      While (inportb($3DA) And 8) <> 0 Do;
-      While (inportb($3DA) And 8) = 0 Do;
-      vga_load(m_primary);
-    End;
-    2 : fakemode_load(m_primary, True);
-  End;
-{  WriteToVideoMemory(m_primary, 0, m_pitch * m_height);}
-End;
-
-Procedure VGAConsole.update(Const _area : TPTCArea);
-
-Begin
-  update;
-End;
-
-Procedure VGAConsole.internal_ReadKey(k : TPTCKey);
-
-Begin
-  check_open;
-  m_keyboard.internal_ReadKey(k);
-End;
-
-Function VGAConsole.internal_PeekKey(k : TPTCKey) : Boolean;
-
-Begin
-  check_open;
-  Result := m_keyboard.internal_PeekKey(k);
-End;
-
-Procedure VGAConsole.copy(Var surface : TPTCBaseSurface);
-
-Var
-  pixels : Pointer;
-
-Begin
-  check_open;
-  check_unlocked;
-  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 VGAConsole.copy(Var surface : TPTCBaseSurface;
-                           Const source, destination : TPTCArea);
-
-Var
-  pixels : Pointer;
-
-Begin
-  check_open;
-  check_unlocked;
-  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 VGAConsole.lock : Pointer;
-
-Var
-  pixels : Pointer;
-
-Begin
-  check_open;
-  If m_locked Then
-    Raise TPTCError.Create('console is already locked');
-  pixels := m_primary;
-  m_locked := True;
-  lock := pixels;
-End;
-
-Procedure VGAConsole.unlock;
-
-Begin
-  check_open;
-  If Not m_locked Then
-    Raise TPTCError.Create('console is not locked');
-  m_locked := False;
-End;
-
-Procedure VGAConsole.load(Const pixels : Pointer;
-                           _width, _height, _pitch : Integer;
-                           Const _format : TPTCFormat;
-                           Const _palette : TPTCPalette);
-Var
-  Area_ : TPTCArea;
-  console_pixels : Pointer;
-
-Begin
-  check_open;
-  check_unlocked;
-  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_.Destroy;
-    End;
-  End;
-End;
-
-Procedure VGAConsole.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;
-  check_unlocked;
-  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.Destroy;
-        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.Destroy;
-    If clipped_destination <> Nil Then
-      clipped_destination.Destroy;
-  End;
-End;
-
-Procedure VGAConsole.save(pixels : Pointer;
-                           _width, _height, _pitch : Integer;
-                           Const _format : TPTCFormat;
-                           Const _palette : TPTCPalette);
-Var
-  Area_ : TPTCArea;
-  console_pixels : Pointer;
-
-Begin
-  check_open;
-  check_unlocked;
-  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_.Destroy;
-    End;
-  End;
-End;
-
-Procedure VGAConsole.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;
-  check_unlocked;
-  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.Destroy;
-        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.Destroy;
-    If clipped_destination <> Nil Then
-      clipped_destination.Destroy;
-  End;
-End;
-
-Procedure VGAConsole.clear;
-
-Var
-  tmp : TPTCColor;
-
-Begin
-  check_open;
-  check_unlocked;
-  If format.direct Then
-    tmp := TPTCColor.Create(0, 0, 0, 0)
-  Else
-    tmp := TPTCColor.Create(0);
-  Try
-    clear(tmp);
-  Finally
-    tmp.Destroy;
-  End;
-End;
-
-Procedure VGAConsole.clear(Const color : TPTCColor);
-
-Var
-  tmp : TPTCArea;
-
-Begin
-  check_open;
-  check_unlocked;
-  tmp := TPTCArea.Create;
-  Try
-    clear(color, tmp);
-  Finally
-    tmp.Destroy;
-  End;
-End;
-
-Procedure VGAConsole.clear(Const color : TPTCColor;
-                           Const _area : TPTCArea);
-
-Begin
-  {...}
-End;
-
-Procedure VGAConsole.palette(Const _palette : TPTCPalette);
-
-Begin
-  check_open;
-  If format.indexed Then
-  Begin
-    m_palette.load(_palette.data);
-    internal_SetPalette(_palette.data);
-  End;
-End;
-
-Function VGAConsole.palette : TPTCPalette;
-
-Begin
-  check_open;
-  palette := m_palette;
-End;
-
-Procedure VGAConsole.clip(Const _area : TPTCArea);
-
-Var
-  tmp : TPTCArea;
-
-Begin
-  check_open;
-  tmp := TPTCClipper.clip(_area, m_area);
-  Try
-    m_clip.ASSign(tmp);
-  Finally
-    tmp.Destroy;
-  End;
-End;
-
-Function VGAConsole.width : Integer;
-
-Begin
-  check_open;
-  width := m_width;
-End;
-
-Function VGAConsole.height : Integer;
-
-Begin
-  check_open;
-  height := m_height;
-End;
-
-Function VGAConsole.pitch : Integer;
-
-Begin
-  check_open;
-  pitch := m_pitch;
-End;
-
-Function VGAConsole.pages : Integer;
-
-Begin
-  check_open;
-  pages := 2;{m_primary.pages;}
-End;
-
-Function VGAConsole.area : TPTCArea;
-
-Begin
-  check_open;
-  area := m_area;
-End;
-
-Function VGAConsole.clip : TPTCArea;
-
-Begin
-  check_open;
-  clip := m_clip;
-End;
-
-Function VGAConsole.format : TPTCFormat;
-
-Begin
-  check_open;
-  format := m_modes[m_CurrentMode].format;
-End;
-
-Function VGAConsole.name : String;
-
-Begin
-  name := 'VGA';
-End;
-
-Function VGAConsole.title : String;
-
-Begin
-End;
-
-Function VGAConsole.information : String;
-
-Begin
-End;
-
-Procedure VGAConsole.internal_pre_open_setup(Const _title : String);
-
-Begin
-
-End;
-
-Procedure VGAConsole.internal_open_fullscreen_start;
-
-{Var
-  f : TPTCFormat;}
-
-Begin
-{  f := TPTCFormat.Create(32, $0000FF, $00FF00, $FF0000);}
-{  m_160x100buffer := TPTCSurface.Create(160, 100, f);}
-{  f.Destroy;}
-{  set80x50;}
-End;
-
-Procedure VGAConsole.internal_open_fullscreen(ModeType : Integer);
-
-Var
-  tmp : TPTCArea;
-
-Begin
-  VGASetMode(320, 200, ModeType, m_faketype);
-  Case ModeType Of
-    INDEX8 : Begin
-      m_CurrentMode := 0;
-      m_pitch := 320;
-    End;
-    RGB332 : Begin
-      m_CurrentMode := 1;
-      m_pitch := 320;
-    End;
-    FAKEMODE : Begin
-      m_CurrentMode := 2;
-      m_pitch := 640;
-    End;
-  End;
-  m_width := 320;
-  m_height := 200;
-
-  tmp := TPTCArea.Create(0, 0, width, height);
-  Try
-    m_area.ASSign(tmp);
-    m_clip.ASSign(tmp);
-  Finally
-    tmp.Destroy;
-  End;
-End;
-
-Procedure VGAConsole.internal_open_fullscreen_finish(_pages : Integer);
-
-Begin
-  If m_primary <> Nil Then
-    FreeMem(m_primary);
-  m_primary := GetMem(m_height * m_pitch);
-End;
-
-Procedure VGAConsole.internal_post_open_setup;
-
-Begin
-  If m_keyboard <> Nil Then
-    m_keyboard.Destroy;
-  m_keyboard := TDosKeyboard.Create;
-
-  { temporary platform dependent information fudge }
-  {sprintf(m_information,"dos version x.xx.x\nvesa version x.xx\nvesa driver name xxxxx\ndisplay driver vendor xxxxx\ncertified driver? x\n");}
-
-  { set open flag }
-  m_open := True;
-End;
-
-Procedure VGAConsole.internal_reset;
-
-Begin
-  If m_primary <> Nil Then
-    FreeMem(m_primary);
-  m_primary := Nil;
-  If m_keyboard <> Nil Then
-    m_keyboard.Destroy;
-  m_keyboard := Nil;
-{  m_primary.Destroy;}
-{  m_keyboard.Destroy;}
-{  m_primary := Nil;}
-{  m_keyboard := Nil;}
-End;
-
-Procedure VGAConsole.internal_close;
-
-Begin
-  If m_primary <> Nil Then
-  Begin
-    FreeMem(m_primary);
-    m_primary := Nil;
-  End;
-  RestoreTextMode;
-End;
-
-Procedure VGAConsole.internal_SetPalette(data : Pint32);
-
-Var
-  i : Integer;
-  c : DWord;
-
-Begin
-  outportb($3C8, 0);
-  For i := 0 To 255 Do
-  Begin
-    c := (data^ Shr 2) And $003F3F3F;
-    outportb($3C9, c Shr 16);
-    outportb($3C9, c Shr 8);
-    outportb($3C9, c);
-    Inc(data);
-  End;
-End;
-
-Procedure VGAConsole.check_open;
-
-Begin
-  {$IFDEF DEBUG}
-    If Not m_open Then
-      Raise TPTCError.Create('console is not open');
-  {$ELSE}
-  {$ENDIF}
-End;
-
-Procedure VGAConsole.check_unlocked;
-
-Begin
-  {$IFDEF DEBUG}
-    If m_locked Then
-      Raise TPTCError.Create('console is not unlocked');
-  {$ELSE}
-  {$ENDIF}
-End;

packages/ptc/src/dos/fakemode/consoled.inc

@@ -1,119 +0,0 @@
-Type
-  VGAConsole = Class(TPTCBaseConsole)
-  Private
-    { internal console management routines }
-    Procedure internal_pre_open_setup(Const _title : String);
-    Procedure internal_open_fullscreen_start;
-    Procedure internal_open_fullscreen(ModeType : Integer);
-    Procedure internal_open_fullscreen_finish(_pages : Integer);
-    Procedure internal_post_open_setup;
-    Procedure internal_reset;
-    Procedure internal_close;
-    Procedure internal_clear_mode_list;
-    Procedure internal_SetPalette(data : Pint32);
-
-    Procedure vga_load(data : Pointer);
-
-    { console debug checks }
-    Procedure check_open;
-    Procedure check_unlocked;
-
-    { data }
-    m_modes : Array[0..31{255}] Of TPTCMode;
-{    m_modes : PPTCMode;}
-{    m_modes_last : Integer;
-    m_modes_n : PInteger;}
-    m_title : Array[0..1023] Of Char;
-    m_information : Array[0..1023] Of Char;
-    m_CurrentMode : Integer;
-{    m_VESACurrentMode : Integer;}
-    m_faketype : Integer;
-    m_width, m_height, m_pitch, m_pages : Integer;
-    m_primary : Pointer;
-
-    { flags }
-    m_open : Boolean;
-    m_locked : Boolean;
-
-    { option data }
-    m_default_width : Integer;
-    m_default_height : Integer;
-    m_default_pages : Integer;
-    m_default_format : TPTCFormat;
-
-    { objects }
-    m_copy : TPTCCopy;
-    m_area : TPTCArea;
-    m_clip : TPTCArea;
-    m_format : TPTCFormat;
-
-    m_clear : TPTCClear;
-    m_palette : TPTCPalette;
-
-    { Dos objects }
-    m_keyboard : TDosKeyboard;
-{    m_primary : TPTCSurface;}
-{    DosKeyboard *m_keyboard;}
-{    m_160x100buffer : TPTCSurface;}
-  Protected
-    Procedure internal_ReadKey(k : TPTCKey); Override;
-    Function internal_PeekKey(k : TPTCKey) : Boolean; Override;
-  Public
-    Constructor Create;
-    Destructor Destroy; Override;
-    Procedure configure(Const _file : String); Override;
-    Function option(Const _option : String) : Boolean; Override;
-    Function modes : PPTCMode; Override;
-    Procedure open(Const _title : String; _pages : Integer); Overload; Override;
-    Procedure open(Const _title : String; Const _format : TPTCFormat;
-                   _pages : Integer); Overload; Override;
-    Procedure open(Const _title : String; _width, _height : Integer;
-                   Const _format : TPTCFormat; _pages : Integer); Overload; Override;
-    Procedure open(Const _title : String; Const _mode : TPTCMode;
-                   _pages : Integer); Overload; Override;
-    Procedure close; Override;
-    Procedure flush; Override;
-    Procedure finish; Override;
-    Procedure update; Override;
-    Procedure update(Const _area : TPTCArea); Override;
-    Procedure copy(Var surface : TPTCBaseSurface); Override;
-    Procedure copy(Var surface : TPTCBaseSurface;
-                   Const source, destination : TPTCArea); Override;
-    Function lock : Pointer; Override;
-    Procedure unlock; Override;
-    Procedure load(Const pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette); Override;
-    Procedure load(Const pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette;
-                   Const source, destination : TPTCArea); Override;
-    Procedure save(pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette); Override;
-    Procedure save(pixels : Pointer;
-                   _width, _height, _pitch : Integer;
-                   Const _format : TPTCFormat;
-                   Const _palette : TPTCPalette;
-                   Const source, destination : TPTCArea); Override;
-    Procedure clear; Override;
-    Procedure clear(Const color : TPTCColor); Override;
-    Procedure clear(Const color : TPTCColor;
-                    Const _area : TPTCArea); Override;
-    Procedure palette(Const _palette : TPTCPalette); Override;
-    Function palette : TPTCPalette; Override;
-    Procedure clip(Const _area : TPTCArea); Override;
-    Function width : Integer; Override;
-    Function height : Integer; Override;
-    Function pitch : Integer; Override;
-    Function pages : Integer; Override;
-    Function area : TPTCArea; Override;
-    Function clip : TPTCArea; Override;
-    Function format : TPTCFormat; Override;
-    Function name : String; Override;
-    Function title : String; Override;
-    Function information : String; Override;
-  End;