Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations bkrike on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Turbo Pascal Compatibility: CRT

How To

Turbo Pascal Compatibility: CRT

by  Glenn9999  Posted    (Edited  )
One of my interests of late has been compatibility routines for Delphi. I thought I'd share what I've come up with so far, in case it might help anyone wanting to do some of the things that they knew to do in Turbo Pascal but haven't figured out the Win32 way to do it.

Here's the first one. I started from a CRT unit by Frank Zimmer, but I tested and made changes to it to try to make it act like the old Turbo Pascal CRT unit. I'm sure there probably is an error I haven't found, so by all means let me know if you do find one.

Anything that is missing from this unit that is in the TP CRT unit is not there because I couldn't figure out a good way to do it (or it's not a smart thing to do under Win32).

Hope this helps.

Code: 
unit crt;
{ Copied from freeware CRT unit by Frank Zimmer, 01.18.1997
  various fixes and edits done to the file by Glenn9999 
  helps from swisscenter version of CRT }

interface

uses windows,messages;

const
  Black           = 0;
  Blue            = 1;
  Green           = 2;
  Cyan            = 3;
  Red             = 4;
  Magenta         = 5;
  Brown           = 6;
  LightGray       = 7;
  DarkGray        = 8;
  LightBlue       = 9;
  LightGreen      = 10;
  LightCyan       = 11;
  LightRed        = 12;
  LightMagenta    = 13;
  Yellow          = 14;
  White           = 15;
  BW40 = 0;     { 40x25 B/W on Color Adapter }
  CO40 = 1;     { 40x25 Color on Color Adapter }
  BW80 = 2;     { 80x25 B/W on Color Adapter }
  CO80 = 3;     { 80x25 Color on Color Adapter }
  Mono = 7;     { 80x25 on Monochrome Adapter }
  Font8x8 = 256;{ Add-in for ROM font }
  C40 = CO40;
  C80 = CO80;
  Win32Platform: Cardinal = VER_PLATFORM_WIN32_WINDOWS; {VER_PLATFORM_WIN32_NT;}

  Function WhereX: integer;
  Function WhereY: integer;
  procedure ClrEol;
  procedure ClrScr;
  procedure InsLine;
  Procedure DelLine;
  Procedure GotoXY(const x,y:integer);
  procedure HighVideo;
  procedure LowVideo;
  procedure NormVideo;
  procedure TextBackground(const Color:word);
  procedure TextColor(const Color:word);
  procedure delay(ms: integer);
  function KeyPressed:boolean;
  function ReadKey:Char;
  Procedure Sound(SF: Smallint);
  Procedure NoSound;
  procedure ConsoleEnd;
  procedure FlushInputBuffer;
  Function Pipe:boolean;
  procedure TextMode(mode: integer);
  procedure Window(X1, Y1, X2, Y2: Byte);

var
  HConsoleInput:thandle;
  HConsoleOutput:thandle;
  HConsoleError:Thandle;
  WindMin:tcoord;
  WindMax:tcoord;
  ViewMax:tcoord;
  TextAttr : Word;
  LastMode : Word;
  OldConsoleMode: DWord;
  SoundFrequency: Integer;
  SoundDuration: integer;
  soundcalled: boolean; // flag for delay on usage for sound & nosound
  tbcolor: word; // backup text background for ribbon code

implementation
  uses sysutils;

var
  StartAttr:word;
  OldCP:integer;
  CrtPipe : Boolean;

procedure ClrEol;
var tC :tCoord;
  Len,Nw: integer;
  Cbi : TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(HConsoleOutput,cbi);
  len := cbi.dwsize.x-cbi.dwcursorposition.x;
  tc.x := cbi.dwcursorposition.x;
  tc.y := cbi.dwcursorposition.y;
  FillConsoleOutputAttribute(HConsoleOutput,textattr,len,tc,nw);
  FillConsoleOutputCharacter(HConsoleOutput,#32,len,tc,nw);
end;

procedure ClrScr;
var tc :tcoord;
  nw: integer;
  cbi : TConsoleScreenBufferInfo;
begin
  getConsoleScreenBufferInfo(HConsoleOutput,cbi);
  tc.x := 0;
  tc.y := 0;
  FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,tc,nw);
  FillConsoleOutputCharacter(HConsoleOutput,#32,cbi.dwsize.x*cbi.dwsize.y,tc,nw);
  setConsoleCursorPosition(hconsoleoutput,tc);
end;

Function WhereX: integer;
var cbi : TConsoleScreenBufferInfo;
begin
  getConsoleScreenBufferInfo(HConsoleOutput,cbi);
  result := tcoord(cbi.dwCursorPosition).x+1
end;

Function WhereY: integer;
var cbi : TConsoleScreenBufferInfo;
begin
  getConsoleScreenBufferInfo(HConsoleOutput,cbi);
  result := tcoord(cbi.dwCursorPosition).y+1
end;

Procedure GotoXY(const x,y:integer);
var coord :tcoord;
begin
  coord.x := x-1;
  coord.y := y-1;
  setConsoleCursorPosition(hconsoleoutput,coord);
end;

procedure InsLine;
var
 cbi : TConsoleScreenBufferInfo;
 ssr:tsmallrect;
 coord :tcoord;
 ci :tcharinfo;
 nw:integer;
begin
  getConsoleScreenBufferInfo(HConsoleOutput,cbi);
  coord := cbi.dwCursorPosition;
  ssr.left := 0;
  ssr.top := coord.y;
  ssr.right := cbi.srwindow.right;
  ssr.bottom := cbi.srwindow.bottom;
  ci.asciichar := #32;
  ci.attributes := cbi.wattributes;
  coord.x := 0;
  coord.y := coord.y+1;
  ScrollConsoleScreenBuffer(HconsoleOutput,ssr,nil,coord,ci);
  coord.y := coord.y-1;
  FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,coord,nw);
end;

procedure DelLine;
var
 cbi : TConsoleScreenBufferInfo;
 ssr:tsmallrect;
 coord :tcoord;
 ci :tcharinfo;
 nw:integer;
begin
  getConsoleScreenBufferInfo(HConsoleOutput,cbi);
  coord := cbi.dwCursorPosition;
  ssr.left := 0;
  ssr.top := coord.y+1;
  ssr.right := cbi.srwindow.right;
  ssr.bottom := cbi.srwindow.bottom;
  ci.asciichar := #32;
  ci.attributes := cbi.wattributes;
  coord.x := 0;
  coord.y := coord.y;
  ScrollConsoleScreenBuffer(HconsoleOutput,ssr,nil,coord,ci);
  FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,coord,nw);
end;

procedure TextBackground(const Color:word);
begin
  tbcolor := color;
  LastMode := TextAttr;
  textattr := (color shl 4) or (textattr and $f);
  SetConsoleTextAttribute(hconsoleoutput,textattr);
end;

procedure TextColor(const Color:word);
begin
  LastMode := TextAttr;
  textattr := (color and $f) or (textattr and $f0);
  SetConsoleTextAttribute(hconsoleoutput,textattr);
end;

procedure HighVideo;
begin
  LastMode := TextAttr;
  textattr := textattr or $8;
  SetConsoleTextAttribute(hconsoleoutput,textattr);
end;

procedure LowVideo;
begin
  LastMode := TextAttr;
  textattr := textattr and $f7;
  SetConsoleTextAttribute(hconsoleoutput,textattr);
end;

procedure NormVideo;
begin
  LastMode := TextAttr;
  textattr := startAttr;
  SetConsoleTextAttribute(hconsoleoutput,textattr);
end;

procedure FlushInputBuffer;
begin
  FlushConsoleInputBuffer(hconsoleinput);
end;

function keypressed:boolean;
  { handles ANY events - might need restrict it to only keyboard }
  var
    NumberOfEvents:integer;
  begin
    GetNumberOfConsoleInputEvents(hconsoleinput,NumberOfEvents);
    result := NumberOfEvents > 0;
  end;

function ReadKey: Char;
 { rewritten to support as DOS did
   Zimmer did not handle keycodes properly for DOS CRT.  His version:
   1) Returned multiple key events, for keypress and release.
   2) Did not handle function keys adequately (eg "F1" or "Delete")
   3) Did not lock out keys that DOS did (eg "CTRL" or "SHIFT")
 }
var
  NumRead: Integer;
  InputRec: TInputRecord;
  ExtendedCode: Char;
  outputchar: char;
  eligible_key: boolean;
begin
  eligible_key := false; { to not return ALL keys }
  repeat
    while ReadConsoleInput(HConsoleInput, InputRec, 1, NumRead) do
       if (InputRec.EventType = KEY_EVENT) then break;
    outputchar := InputRec.KeyEvent.AsciiChar;
    ReadConsoleInput(HConsoleInput, InputRec, 1, NumRead);
    ExtendedCode := #0;
    if outputchar = #0 then
      case InputRec.Keyevent.wVirtualKeyCode of
        $21: ExtendedCode := #73; { PageUp}
        $22: ExtendedCode := #81; { PageDown}
        $23: ExtendedCode := #79; { End}
        $24: ExtendedCode := #71; { Home }
        $25: ExtendedCode := #75; { left arrow }
        $26: ExtendedCode := #72; { Up arrow}
        $27: ExtendedCode := #77; { right arrow }
        $28: ExtendedCode := #80; { down arrow }
        $2D: ExtendedCode := #82; { insert }
        $2E: ExtendedCode := #83; { delete }
        $70: ExtendedCode := #59; { F1 }
        $71: ExtendedCode := #60; { F2 }
        $72: ExtendedCode := #61; { F3 }
        $73: ExtendedCode := #62; { F4 }
        $74: ExtendedCode := #63; { F5 }
        $75: ExtendedCode := #64; { F6 }
        $76: ExtendedCode := #65; { F7 }
        $77: ExtendedCode := #66; { F8 }
        $78: ExtendedCode := #67; { F9 }
        $79: ExtendedCode := #68; { F10 }
        $7A: ExtendedCode := #133; { F11 }
        $7B: ExtendedCode := #134; { F12 }
      end
    else
      eligible_key := true;
    if ExtendedCode <> #0 then
      begin
        InputRec.EventType := KEY_EVENT;
        InputRec.KeyEvent.AsciiChar := ExtendedCode;
        WriteConsoleInput(HConsoleInput, InputRec, 1, NumRead);
        WriteConsoleInput(HConsoleInput, InputRec, 1, NumRead);
        eligible_key := true;
      end
  until eligible_key;
  Result := outputchar;
end;

procedure dossound(Hz: Word);
  { from R. Velthuis code }
  begin
   asm
     MOV     AL,$B6
     OUT     $43,AL
     MOV     AX,$3540
     MOV     DX,$0012
     MOV     CX,Hz
     DIV     CX
     OUT     $42,AL
     MOV     AL,AH
     OUT     $42,AL
     MOV     AL,3
     OUT     $61,AL
    end;
  end;

procedure dossoundend;
  { from R. Velthuis code }
  begin
  asm
    MOV     AL,0
    OUT     $61,AL
  end;
  end;

Procedure Sound(SF: Smallint);
  { rewritten to be compatible with DOS sound/delay/nosound call  }
  begin
    if Win32Platform = VER_PLATFORM_WIN32_NT then
      begin
       // store frequency for later
        soundfrequency := SF;
        soundcalled := true;
      end
    else
      DosSound(SF);
  end;

procedure delay(ms: integer);
  { rewritten to support sound call }
  begin
    if soundcalled then
      windows.beep(SoundFrequency, ms)
    else
      windows.sleep(ms);
  end;

Procedure NoSound;
  begin
    if Win32Platform = VER_PLATFORM_WIN32_NT then
      soundcalled := false
    else
      dossoundend;
  end;

procedure ConsoleEnd;
begin
  if isconsole and not crtpipe then
  begin
    if wherex > 1 then writeln;
    textcolor(green);
    setfocus(GetCurrentProcess);
    normvideo;
    FlushInputBuffer;
    ReadKey;
    FlushInputBuffer;
  end;
end;

function Pipe:boolean;
begin
  result := crtpipe;
end;

function CRTOutput(var F: TTextRec): integer;
  { output function for CRT, writes BufPos bytes and resets the buffer position
    done to be able to format output
    1) To not "ribbon" textbackground - textbackground(black) before #13#10 }
  const
    crlf: array[1..2] of char = #13#10;
  var
    numtowrite, numwritten: integer;
    res: integer;

  begin
    if (F.Buffer[F.BufPos-2] = #13) and (F.Buffer[F.BufPos-1] = #10) then
      // handle CR/LF combination, this is writeln
      begin
        if F.BufPos-2 < 0 then
          numtowrite := 0
        else
          Numtowrite := F.BufPos-2;
        if WriteConsole(F.Handle, F.BufPtr, NumToWrite, NumWritten, nil) then
          Res := 0
        else
          Res := 8;
        // write CR/LF here.
        LastMode := TextAttr;
        textattr := (Black shl 4) or (textattr and $f);
        SetConsoleTextAttribute(hconsoleoutput,textattr);
        NumToWrite := 2;
        WriteConsole(F.Handle, @crlf, numtowrite, numwritten, nil);
        TextBackground(tbcolor); // restore background color
      end
    else
      begin
        if WriteConsole(F.Handle, F.BufPtr, F.BufPos, NumWritten, nil) then
          Res := 0
        else
          Res := 8;
      end;
    F.BufPos := 0;
    Result := res;
  end;

procedure init;
var
  cbi : TConsoleScreenBufferInfo;
  tc : tcoord;
  OsVersion: TOsVersionInfo;
  lpmode: integer;
begin
  SetActiveWindow(0);
  GetConsoleMode(HConsoleInput, lpMode);
  if (lpMode and ENABLE_MOUSE_INPUT) = ENABLE_MOUSE_INPUT then
    SetConsoleMode(HConsoleInput, lpMode xor ENABLE_MOUSE_INPUT);
  reset(input);
  rewrite(output);
  { TFDD redirection }
  TTextRec(Output).InOutFunc := @CRTOutput;
  TTextRec(Output).FlushFunc := @CRTOutput;
  HConsoleInput := TTextRec(Input).Handle;
  HConsoleOutput := TTextRec(Output).Handle;
  HConsoleError := GetStdHandle(STD_Error_HANDLE);
  if getConsoleScreenBufferInfo(HConsoleOutput,cbi) then
    begin
      TextAttr := cbi.wAttributes;
      StartAttr := cbi.wAttributes;
      lastmode  := cbi.wAttributes;
      tc.x := cbi.srwindow.left+1;
      tc.y := cbi.srwindow.top+1;
      windmin := tc;
      ViewMax := cbi.dwsize;
      tc.x := cbi.srwindow.right+1;
      tc.y := cbi.srwindow.bottom+1;
      windmax := tc;
      crtpipe := false;
    end
  else
    crtpipe := true;
  SoundFrequency := 1000;
  SoundDuration := -1;
  oldCp := GetConsoleoutputCP;
  SetConsoleoutputCP(1252);
  { get platform for sound calls }
  OsVersion.dwOsVersionInfoSize := sizeof(OsVersion);
  if GetVersionEx(OsVersion) then
     Win32Platform := OsVersion.dwPlatformID;
end;

procedure TextMode(mode: integer);
  { yet to be written, this command clears the textbuffer and homes the cursor in default color
    in the DOS version, so I will do that here }
  begin
    textbackground(black);
    textcolor(LightGray);
    clrscr;
    GotoXy(1,1);
  end;

procedure Window(X1, Y1, X2, Y2: Byte);
  begin
  End;

initialization
  init;
finalization
  SetConsoleoutputCP(oldcp);
end.
Register to add this FAQ to your archive
Register to rate this FAQ  : BAD 1 2 3 4 5 6 7 8 9 10 GOOD
Please Note: 1 is Bad, 10 is Good :-)

Part and Inventory Search

Back
Top