INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

How To

Turbo Pascal Compatibility: CRT by Glenn9999
Posted: 19 Nov 08

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.

Back to Embarcadero: Delphi FAQ Index
Back to Embarcadero: Delphi Forum

My Archive

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close