Спустя 12 лет довел до ума пример
приложения, который печатает текст в
стиле терминала из фильма Матрица с
DelphiX на OpenGL.
Оригинальный пример, на основе которого
сделан мой пример, взят с сайта
Delphi-Graphics.
Мой код базируется на Delphi,
OpenGL, WinAPI. Код моего примера оставляю
без комментарий, т. к. написание проводилось
без детального разбора работы алгоритма
оригинального приложения и осуществлялся
банальный подбор функций OpenGL и их
параметров. На рисунке 1 представлена
работа моего примера в Windows
10.
Рисунок 1. Пример приложения вывода текста в стиле терминала из фильма "Матрица"
program matrix;
uses
Windows,
Messages,
OpenGL;
var
h_Rc: HGLRC;
h_Dc: HDC;
h_Wnd: HWND;
base: GLuint;
keys: array [0..255] of BOOL;
text: array[0..4] of String = ('Wake up, Neo.',
'The Matrix has you.',
'Follow the White Rabbit.',
'Disconnecting...',
'');
Active: bool = true;
FullScreen:bool = true;
f,z: boolean;
a,b: byte;
sx: integer;
cur: byte;
all: string;
procedure ReSizeGLScene(Width: GLsizei; Height: GLsizei);
begin
if (Height=0) then
Height:=1;
glViewport(0, 0, Width, Height);
glMatrixMode(GL_PROJECTION);
glLoadIdentity();
glOrtho(0, Width, Height, 0, 1, -1);
glMatrixMode(GL_MODELVIEW);
glLoadIdentity;
end;
procedure BuildFont;
var
font: HFONT;
oldfont: HFONT;
begin
base := glGenLists(96);
font := CreateFont( -30,
0,
0,
0,
FW_BOLD,
0,
0,
0,
ANSI_CHARSET,
OUT_TT_PRECIS,
CLIP_DEFAULT_PRECIS,
ANTIALIASED_QUALITY,
FF_DONTCARE or DEFAULT_PITCH,
'Courier New');
oldfont := SelectObject(h_DC, font);
wglUseFontBitmaps(h_DC, 32, 96, base);
SelectObject(h_DC, oldfont);
DeleteObject(font);
end;
procedure KillFont;
begin
glDeleteLists(base, 96);
end;
procedure glPrint(const Fmt: String);
begin
if Fmt = '' then
Exit;
glPushAttrib(GL_LIST_BIT);
glListBase(base - 32);
glCallLists(Length(Fmt), GL_UNSIGNED_BYTE, Pointer(Fmt));
glPopAttrib();
end;
function IntToStr(Num: Integer) : String;
begin
Str(Num, Result);
end;
function InitGL:bool;
begin
glClearColor(0.0, 0.0, 0.0, 0.0);
glMatrixMode(GL_PROJECTION);
glLoadIdentity();
glOrtho(0, 640, 480, 0, 0, 1);
glDisable(GL_DEPTH_TEST);
glMatrixMode(GL_MODELVIEW);
glLoadIdentity();
BuildFont();
a:=0;
b:=0;
sx:=0;
cur:=0;
Result:=true;
end;
procedure addchar;
begin
if length(all)=length(text[cur]) then
begin
inc(cur);
sx:=0;
z:=false;
all:='';
Exit;
end;
if cur<=5 then
begin
all := all + text[cur][length(all)+1];
end
else
begin
exit;
end;
end;
function DrawGLScene():bool;
var
i: integer;
kk2:integer;
kk: integer;
begin
glClear(GL_COLOR_BUFFER_BIT);
glEnable(GL_ALPHA_TEST);
glEnable(GL_BLEND);
glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
glLoadIdentity();
if not z then
inc(sx);
if sx=200 then
z:=true;
if z then
begin
inc(B);
if b=20 then addchar;
if b>20 then b:=0;
end;
if not f then
inc(a,5)
else dec(a,5);
if (a>=255)or(a=0) then f:=not f;
glColor3f(0.196078, 0.8, 0.196078);
for i := 0 to cur - 1 do
begin
glRasterPos2f(0.0, 20.0 + i*30);
glPrint(text[i]);
end;
if i=5 then
begin
i:=0;
cur:=0;
a:=0;
b:=0;
sx:=0;
z:=false;
f:=False;
all:='';
glClearColor(0, 0, 0, 0);
glClear(GL_COLOR_BUFFER_BIT);
end;
kk := 18*length(all);
kk2 := cur*30;
glRasterPos2f(0.0, 20.0 + cur*30);
glPrint(all);
glColor4f(0.196078, 0.8, 0.196078, a / 255); // Colour LimeGreen
glRectf(0.0+kk, 0.0+kk2, 23.0+kk, 23.0+kk2);
glDisable(GL_BLEND);
glDisable(GL_ALPHA_TEST);
Result := true;
end;
function WndProc(hWnd: HWND;
message: UINT;
wParam: WPARAM;
lParam: LPARAM):
LRESULT; stdcall;
begin
if message=WM_SYSCOMMAND then
begin
case wParam of
SC_SCREENSAVE,SC_MONITORPOWER:
begin
result:=0;
exit;
end;
end;
end;
case message of
WM_ACTIVATE:
begin
if (Hiword(wParam)=0) then
active:=true
else
active:=false;
Result:=0;
end;
WM_CLOSE:
Begin
PostQuitMessage(0);
result:=0
end;
WM_KEYDOWN:
begin
keys[wParam] := TRUE;
result:=0;
end;
WM_KEYUP:
begin
keys[wParam] := FALSE;
result:=0;
end;
WM_SIZe:
begin
ReSizeGLScene(LOWORD(lParam),HIWORD(lParam));
result:=0;
end
else
begin
Result := DefWindowProc(hWnd, message, wParam, lParam);
end;
end;
end;
procedure KillGLWindow;
begin
if FullScreen then
begin
ChangeDisplaySettings(devmode(nil^),0);
showcursor(true);
end;
if h_rc<> 0 then
begin
if (not wglMakeCurrent(h_Dc,0)) then
MessageBox(0,'Release of DC and RC failed.',' Shutdown Error',MB_OK or MB_ICONERROR);
if (not wglDeleteContext(h_Rc)) then
begin
MessageBox(0,'Release of Rendering Context failed.',' Shutdown Error',MB_OK or MB_ICONERROR);
h_Rc:=0;
end;
end;
if (h_Dc=1) and (releaseDC(h_Wnd,h_Dc)<>0) then
begin
MessageBox(0,'Release of Device Context failed.',' Shutdown Error',MB_OK or MB_ICONERROR);
h_Dc:=0;
end;
if (h_Wnd<>0) and (not destroywindow(h_Wnd))then
begin
MessageBox(0,'Could not release hWnd.',' Shutdown Error',MB_OK or MB_ICONERROR);
h_Wnd:=0;
end;
if (not UnregisterClass('OpenGL',hInstance)) then
begin
MessageBox(0,'Could Not Unregister Class.','SHUTDOWN ERROR',MB_OK or MB_ICONINFORMATION);
end;
end;
function CreateGlWindow(title:Pchar; width,height,bits:integer;FullScreenflag:bool):boolean stdcall;
var
Pixelformat: GLuint;
wc:TWndclass;
dwExStyle:dword;
dwStyle:dword;
pfd: pixelformatdescriptor;
dmScreenSettings: Devmode;
h_Instance:hinst;
WindowRect: TRect;
begin
WindowRect.Left := 0;
WindowRect.Top := 0;
WindowRect.Right := width;
WindowRect.Bottom := height;
h_instance:=GetModuleHandle(nil);
FullScreen:=FullScreenflag;
with wc do
begin
style:=CS_HREDRAW or CS_VREDRAW or CS_OWNDC;
lpfnWndProc:=@WndProc;
cbClsExtra:=0;
cbWndExtra:=0;
hInstance:=h_Instance;
hIcon:=LoadIcon(0,IDI_WINLOGO);
hCursor:=LoadCursor(0,IDC_ARROW);
hbrBackground:=0;
lpszMenuName:=nil;
lpszClassName:='OpenGl';
end;
if RegisterClass(wc)=0 then
begin
MessageBox(0,'Failed To Register The Window Class.','Error',MB_OK or MB_ICONERROR);
Result:=false;
exit;
end;
if FullScreen then
begin
ZeroMemory( @dmScreenSettings, sizeof(dmScreenSettings) );
with dmScreensettings do
begin
dmSize := sizeof(dmScreenSettings);
dmPelsWidth := width;
dmPelsHeight := height;
dmBitsPerPel := bits;
dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
end;
if (ChangeDisplaySettings(dmScreenSettings, CDS_FULLSCREEN))<>DISP_CHANGE_SUCCESSFUL THEN
Begin
if MessageBox(0,'This FullScreen Mode Is Not Supported. Use Windowed Mode Instead?'
,'Matrix',MB_YESNO or MB_ICONEXCLAMATION)= IDYES then
FullScreen:=false
else
begin
MessageBox(0,'Program Will Now Close.','Error',MB_OK or MB_ICONERROR);
Result:=false;
exit;
end;
end;
end;
if FullScreen then
begin
dwExStyle:=WS_EX_APPWINDOW;
dwStyle:=WS_POPUP or WS_CLIPSIBLINGS or WS_CLIPCHILDREN;
Showcursor(false);
end
else
begin
dwExStyle:=WS_EX_APPWINDOW or WS_EX_WINDOWEDGE;
dwStyle:=WS_OVERLAPPEDWINDOW or WS_CLIPSIBLINGS or WS_CLIPCHILDREN;
end;
AdjustWindowRectEx(WindowRect,dwStyle,false,dwExStyle);
H_wnd:=CreateWindowEx(dwExStyle,
'OpenGl',
Title,
dwStyle,
0,0,
WindowRect.Right-WindowRect.Left,
WindowRect.Bottom-WindowRect.Top,
0,
0,
hinstance,
nil);
if h_Wnd=0 then
begin
KillGlWindow();
MessageBox(0,'Window creation error.','Error',MB_OK or MB_ICONEXCLAMATION);
Result:=false;
exit;
end;
with pfd do
begin
nSize:= SizeOf( PIXELFORMATDESCRIPTOR );
nVersion:= 1;
dwFlags:= PFD_DRAW_TO_WINDOW
or PFD_SUPPORT_OPENGL
or PFD_DOUBLEBUFFER;
iPixelType:= PFD_TYPE_RGBA;
cColorBits:= bits;
cRedBits:= 0;
cRedShift:= 0;
cGreenBits:= 0;
cBlueBits:= 0;
cBlueShift:= 0;
cAlphaBits:= 0;
cAlphaShift:= 0;
cAccumBits:= 0;
cAccumRedBits:= 0;
cAccumGreenBits:= 0;
cAccumBlueBits:= 0;
cAccumAlphaBits:= 0;
cDepthBits:= 16;
cStencilBits:= 0;
cAuxBuffers:= 0;
iLayerType:= PFD_MAIN_PLANE;
bReserved:= 0;
dwLayerMask:= 0;
dwVisibleMask:= 0;
dwDamageMask:= 0;
end;
h_Dc := GetDC(h_Wnd);
if h_Dc=0 then
begin
KillGLWindow();
MessageBox(0,'Cant''t create a GL device context.','Error',MB_OK or MB_ICONEXCLAMATION);
Result:=false;
exit;
end;
PixelFormat := ChoosePixelFormat(h_Dc, @pfd);
if (PixelFormat=0) then
begin
KillGLWindow();
MessageBox(0,'Cant''t Find A Suitable PixelFormat.','Error',MB_OK or MB_ICONEXCLAMATION);
Result:=false;
exit;
end;
if (not SetPixelFormat(h_Dc,PixelFormat,@pfd)) then
begin
KillGLWindow();
MessageBox(0,'Cant''t set PixelFormat.','Error',MB_OK or MB_ICONEXCLAMATION);
Result:=false;
exit;
end;
h_Rc := wglCreateContext(h_Dc);
if (h_Rc=0) then
begin
KillGLWindow();
MessageBox(0,'Cant''t create a GL rendering context.','Error',MB_OK or MB_ICONEXCLAMATION);
Result:=false;
exit;
end;
if (not wglMakeCurrent(h_Dc, h_Rc)) then
begin
KillGLWindow();
MessageBox(0,'Cant''t activate the GL rendering context.','Error',MB_OK or MB_ICONEXCLAMATION);
Result:=false;
exit;
end;
ShowWindow(h_Wnd,SW_SHOW);
SetForegroundWindow(h_Wnd);
SetFOcus(h_Wnd);
ReSizeGLScene(width,height);
if (not InitGl()) then
begin
KillGLWindow();
MessageBox(0,'initialization failed.','Error',MB_OK or MB_ICONEXCLAMATION);
Result:=false;
exit;
end;
Result:=true;
end;
function WinMain(hInstance: HINST;
hPrevInstance: HINST;
lpCmdLine: PChar;
nCmdShow: integer):
integer; stdcall;
var
msg: TMsg;
done: Bool;
begin
done:=false;
if MessageBox(0,'Would You Like To Run In FullScreen Mode?','Start FullScreen', MB_YESNO or MB_ICONQUESTION)=IDNO then
FullScreen:=false
else
FullScreen:=true;
if not CreateGLWindow('Matrix',640,480,16,FullScreen) then
begin
Result := 0;
exit;
end;
while not done do
begin
if (PeekMessage(msg, 0, 0, 0, PM_REMOVE)) then
begin
if msg.message=WM_QUIT then
done:=true
else
begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
end
else
begin
if (Active and (not DrawGLScene()) or keys[VK_ESCAPE]) then
begin
done:=true;
end;
if (keys[VK_F1]) then
begin
Keys[VK_F1] := false;
KillGLWindow();
FullScreen := not FullScreen;
if not CreateGLWindow('Matrix',640,480,16,fullscreen) then Result := 0;
end;
SwapBuffers(h_Dc);
end;
end;
KillFont();
killGLwindow();
result:=msg.wParam;
end;
begin
WinMain( hInstance, hPrevInst, CmdLine, CmdShow );
end.
