Пример приложения печатающий текст в стиле терминала из фильма Matrix "Матрица"

Спустя 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.