From ts@uwasa.fi Sat Oct 10 00:00:00 1998
Subject: FAQPAS5.TXT contents

                               Copyright (c) 1993-1998 by Timo Salmi
                                                 All rights reserved

FAQPAS5.TXT The fifth set of frequently (and not so frequently)
asked Turbo Pascal questions with Timo's answers. The items are in
no particular order.

You are free to quote brief passages from this file provided you
clearly indicate the source with a proper acknowledgment.

Comments and corrections are solicited. But if you wish to have
individual Turbo Pascal consultation, please post your questions to
a suitable Usenet newsgroup like news:comp.lang.pascal.borland. It
is much more efficient than asking me by email. I'd like to help,
but I am very pressed for time. I prefer to pick the questions I
answer from the Usenet news. Thus I can answer publicly at one go if
I happen to have an answer. Besides, newsgroups have a number of
readers who might know a better or an alternative answer. Don't be
discouraged, though, if you get a reply like this from me. I am
always glad to hear from fellow Turbo Pascal users.

....................................................................
Prof. Timo Salmi   Co-moderator of news:comp.archives.msdos.announce
Moderating at ftp:// & http://garbo.uwasa.fi/ archives 193.166.120.5
Department of Accounting and Business Finance  ; University of Vaasa
mailto:ts@uwasa.fi <http://www.uwasa.fi/~ts/>  ; FIN-65101,  Finland
Spam foiling in effect.  My email filter autoresponder will return a
required email password to users not yet in the privileges database.

--------------------------------------------------------------------
101) How do I detect if mouse hardware/driver is installed?
102) How can I read absolute sectors directly from a floppy?
103) How can I move a file to another directory in Turbo Pascal?
104) How can I get/set a disk volume label?
105) Is there a function to chop off the leading zero from 0.322?
106) How can I print a text file (and conclude sending a formfeed)?
107) How can I round 4.1256455 to two decimal places to give 4.13?
108) How can I list with paths all the files on a drive?
109) What are the formulas for ArcSin and ArcCos?
110) How can I determine how many bytes are allocated to a file?
111) How can I modify the colors of the VGA graphics palette?
112) How can I check if SMARTDRV has been installed? Which version?
113) Is there a way to make the text blink in the graphics mode?
114) How do I make writeln (15/18) give 0.83, not 8.3333333333E-01?
115) How do I get 256 colors instead of Turbo Pascal's normal 16?
116) How can I read a text character from the screen (e.g. xy 5,2)?
117) How can I clear the screen without the Crt unit?
118) How can I test if a disk is present in the drive?
119) What is the Pascal code to add a number of days to a date?
120) How can I stuff keystrokes in advance into the keyboard buffer?
121) What is the code for a fast 16-color PutPixel Routine?
122) What is the code for a fast 256-color PutPixel Routine?
123) How can I substitute a substring with another in a string?
124) Curing Crt initialization runtime error 200 on fast machines
125) How can I copy text and example codes from Turbo Pascal help?
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:41 1998
Subject: Detecting mouse

101. *****
 Q: How do I detect if mouse hardware/driver is installed?

 A: The source code is given below. For more mouse related functions
please see ftp://garbo.uwasa.fi/pc/programming/inter59c.zip for
interrupt $33 functions.
  uses Dos;
  (* Detect if mouse hardware/driver is installed; initializes driver *)
  function MOUSDRFN : boolean;
  var regs : registers;
  begin
    FillChar (regs, SizeOf(regs), 0);  { Just to make sure }
    regs.ax := $0000;                  { Interrupt function number }
    Intr ($33, regs);                  { Call interrupt $33 }
    if regs.ax = $FFFF then
      mousdrfn := true
      else mousdrfn := false;
  end;  (* mousdrfn *)
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:42 1998
Subject: Reading absolute sectors

102. *****
 Q: How can I read absolute sectors directly from a floppy?

 A: Here is the source code for reading directly from a floppy disk.
For directly reading data from hard disk, please study the
information for interrupt $13 function $02 in Ralf Brown's list of
interrupts ftp://garbo.uwasa.fi/pc/programming/inter59a.zip.
  uses Dos;
  type readBufferType = array [1..1024] of byte;
  procedure READFLPY (drive  : char;
                      side   : byte;
                      track  : byte;
                      sector : byte;
                      var rb : readBufferType;
                      var ok : boolean);
  var regs : registers;
       i : byte;
  begin
    ok := false;
    for i := 1 to 3 do begin
      FillChar (regs, SizeOf(regs), 0);  { Just to make sure }
      regs.ah := $02;                    { Function }
      regs.al := 2;                      { Number of sectors to read }
      regs.dl := ord(Upcase(drive))-ord('A');
      if (regs.dl < 0) or (regs.dl > 1) then exit;   { For floppies only }
      regs.dh := side;
      regs.ch := track;
      regs.cl := sector;
      regs.es := Seg(rb);
      regs.bx := Ofs(rb);
      Intr ($13, regs);                  { Call interrupt $13 }
      if regs.flags and FCarry = 0 then begin   { Was it ok? }
        ok := true; exit;
      end; {if}
      { reset and try again a maximum of three times }
      FillChar (regs, SizeOf(regs), 0);  { Just to make sure }
      regs.ah := $00;                    { Function }
      regs.dl := ord(Upcase(drive))-ord('A');
    end; {for i}
  end;  (* readflpy *)
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:43 1998
Subject: Moving files

103. *****
 Q: How can I move a file to another directory in Turbo Pascal?

 A: If the file and the target directory are on the same disk you
can use Turbo Pascal's rename command for the purpose. If they are
on separate disks you'll first have to copy the file as explained in
the item "How can I copy a file in a Turbo Pascal program?" and then
erase the original as explained in the item "Can you tell a beginner
how to delete files with Turbo Pascal?"
  var f : file;
  begin
    Assign (f, 'r:\faq.pas');
    {$I-} Rename (f, 'r:\cmand\faq.pas'); {$I+}
    if IOResult = 0 then
      writeln ('File moved') else writeln ('File not moved');
  end.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:44 1998
Subject: Getting/setting volume label

104. *****
 Q: How can I get/set a disk volume label?

 A1: Getting the volume label can be done in alternative ways. Below
is one of them. However, do not use it. First read item A3!
  Uses Dos;
  (* Get a disk's volume label *)
  function GETLABFN (device : char) : string;
  var FileInfo : SearchRec;
      fsplit_dir  : DirStr;
      fsplit_name : NameStr;
      fsplit_ext  : ExtStr;
      stash       : byte;
  begin
    getlabfn := '';
    device := UpCase (device);
    if (device < 'A') or (device > 'Z') then exit;
    {}
    stash := fileMode;
    FileMode := $40;
    FindFirst (device + ':\*.*', AnyFile, FileInfo);
    while DosError = 0 do
      begin
        if ((FileInfo.Attr and VolumeId) > 0) then
          begin
            FSplit (FExpand(FileInfo.Name),
                    fsplit_dir, fsplit_name, fsplit_ext);
            Delete (fsplit_ext, 1, 1);
            getlabfn := fsplit_name + fsplit_ext;
            FileMode := stash;
            exit;
          end;
        FindNext (FileInfo);
      end; {while}
    FileMode := stash;
  end; (* getlabfn *)

 A2: In April 1998 it turned out on the Usenet news that the
GETLABFN does not work for a CD-ROM. The following solution
hopefully works for all kinds of drives.
  function GETLBFN (device : char) : string;
  var FileInfo    : SearchRec;
      fsplit_dir  : DirStr;
      fsplit_name : NameStr;
      fsplit_ext  : ExtStr;
  begin
    getlbfn := '';
    device := UpCase (device);
    if (device < 'A') or (device > 'Z') then exit;
    {}
    FindFirst (device + ':\*.*', VolumeId, FileInfo);
    if DosError = 0 then begin
      FSplit (FExpand(FileInfo.Name),
              fsplit_dir, fsplit_name, fsplit_ext);
      Delete (fsplit_ext, 1, 1);
      getlbfn := fsplit_name + fsplit_ext;
    end
  end;  (* getlbfn *)

 A3: Another option is the following code found by Jeff Patterson
(aa093@fan.nb.ca) from an unknown source.
  FUNCTION GetLabel(DriveNum : Byte; VAR V : String) : Boolean;
  CONST
    Any : String[5] = ':\*.*';
  VAR
    SR   : SearchRec;
    Mask : PathStr;
    P    : Byte;
  BEGIN
    IF DriveNum > 0 THEN
      Mask[1] := Char(DriveNum + ord('@'))
    ELSE GetDir(0, Mask);
    Move(Any[1], Mask[2], 5);
    Mask[0] := #6;
    FindFirst(Mask, VolumeID, SR);
    WHILE (SR.Attr AND VolumeID = 0) AND
          (DosError = 0) DO
      FindNext(SR);
    IF DosError = 0 THEN
      BEGIN
        FillChar(V[1], 11, ' ');
        V[0] := #11;
        P := Pos('.', SR.Name);
        IF P = 0 THEN
          Move(SR.Name[1], V[1], length(SR.Name))
        ELSE
          BEGIN
            Move(SR.Name[1], V[1], pred(P));
            Move(SR.Name[P+1], V[9], length(SR.Name)-P);
          END;
        GetLabel := TRUE;
      END
    ELSE GetLabel := FALSE;
  END;
To make this more operational you can use
  function LabelFn (drive : char) : string;
  var v : string;
  begin
    if GetLabel (ord(Upcase(drive))-ord('@'), v) then
      LabelFn := v
    else LabelFn := '';
  end;
After having this solution one can correct the first method to be
  Uses Dos;
  (* Get a disk's volume label, CD-ROM compatible *)
  function GETLABFN (device : char) : string;
  var FileInfo : SearchRec;
      fsplit_dir  : DirStr;
      fsplit_name : NameStr;
      fsplit_ext  : ExtStr;
  begin
    getlabfn := '';
    device := UpCase (device);
    if (device < 'A') or (device > 'Z') then exit;
    {}
    FindFirst (device + ':\*.*', VolumeId, FileInfo);
    While (FileInfo.Attr AND VolumeID = 0) AND (DosError = 0) do
      FindNext(FileInfo);
    if DosError = 0 then
      begin
        if ((FileInfo.Attr and VolumeId) > 0) then
          begin
            FSplit (FExpand(FileInfo.Name),
                    fsplit_dir, fsplit_name, fsplit_ext);
            Delete (fsplit_ext, 1, 1);
            getlabfn := fsplit_name + fsplit_ext;
            exit;
          end;
        FindNext (FileInfo);
      end; {while}
  end; (* getlabfn *)

 A4: As for setting a disk volume label with Turbo Pascal that is a
much more complicated task. You'll need to manipulate the File
Control Block (FCB). This alternative is not taken further in here.
If you need the procedure it is available without the source code as
  "SETLABEL Set a disk's volume label"
  in TSUNTL.TPU in ftp://garbo.uwasa.fi/pc/ts/tspa3570.zip.
An alternative is shelling to Dos to call its own LABEL.EXE program
as follows
  {$M 2048, 0, 0}   (* <-- Important. Adjust if out of memory. *)
  Uses Dos;
  begin
    SwapVectors;
    Exec (GetEnv('comspec'), '/c label A:');  (* Execution *)
    SwapVectors;
  end.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:45 1998
Subject: Omitting leading zero

105. *****
 Q: Is there a function to chop off the leading zero from 0.322?

 A: If you wish to output a real without the leading zero you can
use the following function
  function CHOPFN (x : real; dd : byte) : string;
  var s : string;
  begin
    Str (x:0:dd, s);
    if x >= 0 then
      chopfn := Copy (s,2,255)
    else
      chopfn := '-' + Copy (s,3,255);
  end;  (* chopfn *)
There are other options. What is below is more cumbersome than
CHOPFN, but it demonstrates the usage of the Move command rather
nicely.
  function CHOP2FN (x : real; dd : byte) : string;
  var s : string;
  begin
    Str (x:0:dd, s);
    if x >= 0 then begin
      Move (s[2],s[1],Length(s)-1);
      Dec(s[0]);
      chop2fn := s;
      end
    else begin
      Move (s[3],s[1],Length(s)-2);
      Dec(s[0],2);
      chop2fn := '-' + s;
    end;
  end;  (* chop2fn *)
The third, and the best option is
  function CHPJRSFN (x : real; dd : byte) : string;
  var s : string;
  begin
    Str (x:0:dd, s);
    if abs(x) < 1.0 then Delete(s, Pos('0.', s), 1);
    chpjrsfn := s;
  end;  (* chpjrsfn *)
Note that contrary to the other two (which you can easily adjust in
the same way) CHPJRSFN omits the leading zero if and only if the
number is between -1 and 1. This is taken care by the "if abs(x) <
1.0". The "Delete(s, Pos('0.', s), 1)" shortcut was suggested by Dr
John Stockton.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:46 1998
Subject: Printing a file and a formfeed

106. *****
 Q: How can I print a text file (and conclude sending a formfeed)?

 A: We can turn this beginner's question into some instructive
source code. Study carefully the many details included. For printer
handling you might also wish to see in my FAQ the separate item
number 15 "How can I test that the printer is ready?"
  Uses Printer;             { Associates lst with the LPT1 device }
  const formfeed = #12;     { The formfeed character }
  var s : string;           { A string for a single line }
      filename : string;    { A variable for the file name }
      f : text;             { Text-file variable }
      fmsave : byte;        { For storing the original filemode }
  begin
    if ParamCount > 0 then  { If there are parameters on the command line }
      filename := ParamStr(1)                     { get the first of them }
    else begin
      writeln ('Usage: ', ParamStr(0), ' [Filename]');
      halt(1);              { Sets errorlevel to 1 for batches }
    end;
    fmSave := FileMode;     { Save the current filemode }
    FileMode := $40;        { To handle also read-only and network files }
    Assign (f, filename);   { Associate file variable with file name }
    {$I-}                   { Input/Output-Checking temporarily off }
    Reset (f);              { Open the file }
    {$I+}
    if IOResult <> 0 then begin    { Check failure of opening the file }
      writeln ('Error opening ', filename);
      FileMode := fmSave;   { Restore original filemode }
      halt(2);              { Sets errorlevel to 2 for batches }
    end; {if}
    while not eof(f) do begin
      readln (f, s);        { Read a line, maximum length 255 characters }
      writeln (lst, s);     { Write the line to the printer }
    end; {while}
    Close (f);              { Close the file }
    FileMode := fmSave;     { Restore the original filemode }
    write (lst, formfeed);  { Eject the page from the printer }
  end.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:47 1998
Subject: Rounding a value

107. *****
 Q: How can I round 4.1256455 to two decimal places to give 4.13?

 A: Here is the source code. Note the two alternatives. The trivial
one of just formulating the output, and the more complicated of
actually rounding the value of a variable.
  var x, y : real;
  {}
  (* Sign function, needed to round negative values correctly *)
  function SignFn (a : real) : real;
  begin
    if a > 0.0 then signfn := 1.0
      else if a < 0.0 then signfn := -1.0
        else signfn := 0.0;
  end; (* sgnfn *)
  {}
  (* Round a real variable to d decimal places *)
  function RoundRealFn (x : real; d : byte) : real;
  var a : real;
      i : byte;
  begin
    a := 1.0;
    for i := 1 to d do a := a*10.0;
    RoundRealFn := Int (a*x + SignFn(x)*0.5) / a;
  end;  (* RoundRealFn *)
  {}
  (* Test *)
  begin
    x := 4.1256455;
    {}
    { ... The case of actually rounding a variable ...}
    y := RoundRealFn (x, 2);
    writeln (x, ' ', y);
    {}
    {... The more common case case of rounding the output only ...}
    writeln (x:0:2);
  end.

A suggestion from Wong Hoi Ko to round to two decimal places
  function Round2dpFn (x : real) : real;
  begin
    Round2dpFN := round (x * 100) / 100;
  end;
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:48 1998
Subject: Recursing directories

108. *****
 Q: How can I list with paths all the files on a drive?

 A: Here is the example source code
  {$M 16384,0,0}
  Uses Dos;
  {... the top directory ...}
  procedure FindFiles (Path, FileSpec : string);
  var FileInfo : SearchRec;
  begin
    FindFirst (Path + FileSpec, AnyFile, FileInfo);
    while DosError = 0 do begin
      if ((FileInfo.Attr and Directory) = 0) and
         ((FileInfo.Attr and VolumeId) = 0) then begin
        writeln (Path+FileInfo.Name);
      end; {if}
      FindNext (FileInfo);
    end; {while}
    {}
    {... subdirectories ...}
    FindFirst (Path + '*.*', Directory, FileInfo);
    while DosError = 0 do
      begin
        if ((FileInfo.Attr and Directory) > 0) and
            (FileInfo.Name <> '.') and
            (FileInfo.Name <> '..') then
              FindFiles (Path + FileInfo.Name + '\', FileSpec);
        FindNext (FileInfo);
      end; {while}
  end;  (* findfiles *)
  {}
  begin
    FindFiles ('C:\', '*.*');  { Note the trailing \ }
  end.
For starting below the root, use e.g. FindFiles ('C:\DOS\', '*.*');
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:49 1998
Subject: Arcsin and ArcCos

109. *****
 Q: What are the formulas for ArcSin and ArcCos?

 A: Arcsin is the inverse function of the sine. Hence y = arcsin(x)
implies x = sin(y). The values of x range from -1 and to 1. The
square root of (1-x^2) will become zero at -1 and 1 which will cause
an error if those special cases are not taken into account. Thus
define
  function ArcSin (x : real) : real;
  const halfPi = pi/2.0;
  begin
    if (x < -1.0) or (x > 1.0) then begin
      writeln ('ArcSin argument ', x, ' out of range [-1,1]');
      halt;
    end;
    if x = 1.0 then arcsin := halfPi
    else if x = -1.0 then arcsin := -halfPi
    else arcsin := ArcTan(x/Sqrt(1.0-Sqr(x)));
  end; (* arcsin *)

For ArcCos we can use
  function ArcCos (x : real) : real;
  const halfPi = pi/2.0;
  begin
    arccos := halfPi - ArcSin(x);
  end; (* arccos *)

Also see http://www.merlyn.demon.co.uk/pas-math.htm#TrigFuncs by Dr.
John Stockton.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:50 1998
Subject: File size allocation

110. *****
 Q: How can I determine how many bytes are allocated to a file?

 A: Disk space is allocated to files by clusters, not by individual
bytes. Therefore, (except when exact multiples of cluster size)
files take up more space than is shown on the MS-DOS dir command
file size. To find out the true number of bytes a file takes up
you'll find have to find out what is the cluster size for the device
where the file is located. The following function does that.
  (* Allocation of bytes per cluster for the files on a drive *)
  function CLUSIZFN (device : char) : longint;
  var regs : registers;
  begin
    FillChar (regs, SizeOf(regs), 0);  { Just a precaution }
    with regs do begin
      ax := $3600;    { Get drive allocation information }
      dx := ord (UpCase(device)) - 64;  { Default=0, A=1, B=2,.. }
      MsDos (regs);   { Call interrrupt $21 }
      if (ax = $FFFF) then           { $FFFF if drive is invalid }
         clusizfn := -1              { To indicate an error }
       else
         clusizfn := cx * ax; { bytes per sector * sectors per cluster }
    end; {with}
  end;  (* clusizfn *)

Next, the following function can be used to find out the number of
bytes a file takes up.
  (* The file's total allocated bytes. Don't apply on an open file *)
  function ALLSIZFN (filename : string) : longint;
  var SizeOfCluster : longint;
      fmSave : byte;
      fpoint : file of byte;
  begin
    filename := FExpand (filename); { Make sure the drive is first }
    SizeOfCluster := CLUSIZFN (filename[1]);
    if SizeOfCluster = -1 then
      allsizfn := -1                { In case of error }
    else
      begin
        fmSave := FileMode;  { Store the FileMode value }
        FileMode := $40;     { Also read-only and network files }
        Assign (fpoint, filename);
        {$I-} Reset (fpoint); {$I+}
        if IOResult <> 0 then
          allsizfn := -1            { In case of error }
        else begin
          allsizfn := ((FileSize(fpoint) + SizeOfCluster - 1) div
                        SizeOfCluster) * SizeOfCluster;
          Close (fpoint);
        end;
        FileMode := fmSave;  { Restore the original FileMode status }
      end;
  end;  (* allsizfn *)
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:51 1998
Subject: Modifying VGA palette

111. *****
 Q: How can I modify the colors of the VGA graphics palette?

 A: Below is a demo source code how to do it. Solving this problem
is not trivial, but it is not overly complicated either.
   The related task of selecting the RGB (Red Green Blue) color
values to your liking is, in fact, the most laborious task. The
color values for each color component for the adapter run from 0 to
255, but in Turbo Pascal only only the 6 most-significant bits of
the color byte are loaded in the palette. Thus the TP color
components run from 0 to 63 only. The correspondence between the 0
to 255 and the 0 to 63 items can be found using the formula
  ReducedColorItem := Full8bitColorItem shr 2;
The reduction to 6 significant bits means that TP will unfortunately
not be able to utilize all the color combinations your VGA adapter
should be capable of.

  uses Crt, Graph;

  type RGBRecordType = record
                         c       : byte;
                         r, g, b : byte;
                       end;

  type RGBArrayRecordType = array[0..MaxColors] of RGBRecordType;

  const
    DefaultPalette : RGBArrayRecordType = (
     (c:  0; r: 0; g: 0; b: 0),   { Black; }
     (c:  1; r: 0; g: 0; b:40),   { Blue; }
     (c:  2; r: 0; g:40; b: 0),   { Green; }
     (c:  3; r: 0; g:40; b:40),   { Cyan; }
     (c:  4; r:40; g: 7; b: 7),   { Red; }
     (c:  5; r:40; g: 0; b:40),   { Magenta; }
     (c: 20; r:40; g:30; b: 0),   { Brown; }
     (c:  7; r:49; g:49; b:49),   { LightGray; }
     (c: 56; r:26; g:26; b:26),   { DarkGray; }
     (c: 57; r: 0; g: 0; b:63),   { LightBlue; }
     (c: 58; r: 9; g:63; b: 9),   { LightGreen; }
     (c: 59; r: 0; g:63; b:63),   { LightCyan; }
     (c: 60; r:63; g:10; b:10),   { LightRed; }
     (c: 61; r:44; g: 0; b:63),   { LightMagenta; }
     (c: 62; r:63; g:63; b:18),   { Yellow; }
     (c: 63; r:63; g:63; b:63) ); { White; }

  const
    MyPalette : RGBArrayRecordType = (
     (c:  0; r: 0; g: 0; b: 0),   { Black; }
     (c:  1; r: 0; g: 0; b:32),   { Blue; }
     (c:  2; r: 0; g:32; b: 0),   { Green; }
     (c:  3; r: 0; g:48; b:48),   { Cyan; }
     (c:  4; r:32; g: 0; b: 0),   { Red; }
     (c:  5; r:32; g: 0; b:32),   { Magenta; }
     (c: 20; r:43; g:21; b: 0),   { Brown; }
     (c:  7; r:48; g:48; b:48),   { LightGray; }
     (c: 56; r:32; g:32; b:32),   { DarkGray; }
     (c: 57; r: 0; g: 0; b:63),   { LightBlue; }
     (c: 58; r: 0; g:63; b: 0),   { LightGreen; }
     (c: 59; r: 0; g:63; b:63),   { LightCyan; }
     (c: 60; r:63; g: 0; b: 0),   { LightRed; }
     (c: 61; r:63; g: 0; b:63),   { LightMagenta; }
     (c: 62; r:63; g:63; b: 0),   { Yellow; }
     (c: 63; r:63; g:63; b:63) ); { White; }

  const
    BlackPalette : RGBArrayRecordType = (
     (c:  0; r: 0; g: 0; b: 0),   { Black; }
     (c:  1; r: 0; g: 0; b: 0),   { Blue; }
     (c:  2; r: 0; g: 0; b: 0),   { Green; }
     (c:  3; r: 0; g: 0; b: 0),   { Cyan; }
     (c:  4; r: 0; g: 0; b: 0),   { Red; }
     (c:  5; r: 0; g: 0; b: 0),   { Magenta; }
     (c: 20; r: 0; g: 0; b: 0),   { Brown; }
     (c:  7; r:48; g:48; b:48),   { LightGray; }
     (c: 56; r: 0; g: 0; b: 0),   { DarkGray; }
     (c: 57; r: 0; g: 0; b: 0),   { LightBlue; }
     (c: 58; r: 0; g: 0; b: 0),   { LightGreen; }
     (c: 59; r: 0; g: 0; b: 0),   { LightCyan; }
     (c: 60; r: 0; g: 0; b: 0),   { LightRed; }
     (c: 61; r: 0; g: 0; b: 0),   { LightMagenta; }
     (c: 62; r: 0; g: 0; b: 0),   { Yellow; }
     (c: 63; r: 0; g: 0; b: 0) ); { White; }

  procedure UsePalette (palette : RGBArrayRecordType);
  var i : byte;
  begin
    for i := 0 to MaxColors do
      SetRGBPalette (palette[i].c,
                     palette[i].r, palette[i].g, palette[i].b);
  end; (* UsePalette *)

  procedure DisplayPalette (x0, y0 : integer);
  const height = 20; width = 30; separation = 10;
  var i, j, k : integer;
  begin
    k := 0;
    for j := 0 to 1 do begin
      for i := 0 to 7 do begin
        SetFillStyle (SolidFill, k);
        Bar (x0+i*(width+separation), y0+j*(height+separation),
             x0+i*(width+separation)+width, y0+j*(height+separation)+height);
        Inc(k);
      end; {for i}
    end; {for j}
  end;  (* DisplayPalette *)

  var grDriver        : integer;
      grMode          : integer;
      ErrCode         : integer;
  begin
    grDriver := VGA;
    grMode := VGAHi;
    InitGraph (grDriver, grMode, ' ');
    ErrCode := GraphResult;
    if ErrCode <> grOk then begin
      Writeln ('Graphics error:', GraphErrorMsg(ErrCode)); halt; end;
    ClearDevice;  { Clears and homes the current pointer }
    {}
    SetFillStyle (SolidFill, LightGray);
    Bar (0, 0, GetMaxX, GetMaxy);
    DisplayPalette (50, 50);
    repeat until KeyPressed;
    while KeyPressed do ReadKey;
    {}
    UsePalette (MyPalette);
    DisplayPalette (50, 150);
    repeat until KeyPressed;
    while KeyPressed do ReadKey;
    {}
    UsePalette (BlackPalette);
    DisplayPalette (50, 250);
    repeat until KeyPressed;
    while KeyPressed do ReadKey;
    {}
    UsePalette (DefaultPalette);
    DisplayPalette (50, 350);
    repeat until KeyPressed;
    {}
    RestoreCrtMode;
    CloseGraph;
  end.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:52 1998
Subject: Detecting SMARTDRV

112. *****
 Q: How can I check if SMARTDRV has been installed? Which version?

 A: Below is the source code

  Uses Dos;

  (* Has SMARTDRV been installed *)
  function SMARTFN : boolean;  { For SMARTDRV v4.00+ }
  var regs : registers;
  begin
    FillChar (regs, SizeOf(regs), 0);
    regs.ah := $4A;   { function }
    regs.al := $10;   { subfunction }
    regs.bx := $0000; { See $0003 for cache status }
    regs.cx := $EBAB;
    Intr ($2F, regs);
    smartfn := regs.ax = $BABE;   { A sense of humor ? }
  end; (* smartfn *)

  (* Get the SMARTDRV version *)
  function SMRVERFN : string;  { For SMARTDRV v4.00+ }
    function HEXFN (decimal : word) : string;
    const hexDigit : array [0..15] of char = '0123456789ABCDEF';
    begin
      hexfn := hexDigit[(decimal shr 12)]
            + hexDigit[(decimal shr 8) and $0F]
            + hexDigit[(decimal shr 4) and $0F]
            + hexDigit[(decimal and $0F)];
    end;  (* hexfn *)
  var regs : registers;
  begin
    FillChar (regs, SizeOf(regs), 0);
    regs.ah := $4A;   { function }
    regs.al := $10;   { subfunction }
    regs.bx := $0000; { See $0003 for cache status }
    regs.cx := $EBAB;
    Intr ($2F, regs);
    if regs.ax = $BABE then
      smrverfn := HEXFN(regs.bp)
    else
      smrverfn := 'Error';
  end; (* smrverfn *)
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:53 1998
Subject: Blinking in graphics mode

113. *****
 Q: Is there a way to make the text blink in the graphics mode?

 A: Unlike the argument options for TextColor in the Crt unit for
text output there is no predefined blink attribute for the Graph
unit. If you wish to have something blinking in the graphics mode,
be it text or part of an image, you'll have to build blinking with
output of alternating colors. Below is a simple demo of doing this.
  uses Crt, Graph;
  var grDriver : integer;
      grMode   : integer;
      ErrCode  : integer;
  const wait = 250;
  {}
  begin
    grDriver := Detect;
    InitGraph (grDriver, grMode, ' ');
    ErrCode := GraphResult;
    if ErrCode <> grOk then begin
      Writeln ('Graphics error:', GraphErrorMsg(ErrCode)); halt; end;
    SetColor (LightCyan);
    SetBkColor (Black);
    SetTextStyle(DefaultFont, HorizDir, 2);
    {}
    {... this is the example's key line ...}
    OutTextXY (0, 0, 'Some text');
    {}
    repeat
      SetColor (LightCyan);
      OutTextXY (0, 20, 'Press any key');
      Delay (wait);
      SetColor (Black);
      OutTextXY (0, 20, 'Press any key');
      Delay (wait);
    until KeyPressed;
    RestoreCrtMode;
    CloseGraph;
  end.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:54 1998
Subject: Formatting output

114. *****
 Q: How do I make writeln (15/18) give 0.83, not 8.3333333333E-01?

 A: This information is surprisingly hard to locate in the manuals.
You'll find it in your Turbo Pascal 7.0 Programmer's Reference on
pages 204-206. Furthermore, it is not presented in the most
instructive of manners. So let's consider some a few simple examples
starting from the question posed.

Basically the format of writeln for text output is
  writeln ( YourVariable [ : [MinimumWidth] [ : DecimalPlaces ] );
Thus, to answer the question, to obtain "  0.83" you would use e.g.
  writeln (15/18 : 6 : 2);

There are some useful tricks that can be done with the text
formatting. To make the output always left-justified set
MinimumWidth to zero. For example you might have
  var x : real;
  begin
    x := -4.0/7.0;
    writeln (x : 0 : 2);
  end.
Which gives "-0.57".

Naturally it is also possible to regulate the length of the
exponential presentation. For example, writeln (x : 10) would give
"-5.714E-01".

The OutExpr formatting can be applied to other variable types as
well, including the string type. This is convenient for
right-justifying output as in the example below.
  const ff = 20;
  begin
    writeln ('Scott Earnest' : ff);
    writeln ('Osmo Ronkanen' : ff);
    writeln ('Timo Salmi' : ff);
    writeln ('John Stockton' : ff);
  end.
This will output
       Scott Earnest
       Osmo Ronkanen
          Timo Salmi
       John Stockton

The formatting can also be applied in converting numerical values to
strings with the Str procedure. For an example see the item "How do
I format graphics output like in textmode writeln?" in this same FAQ
collection.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:55 1998
Subject: 256 colors

115. *****
 Q: How do I get 256 colors instead of Turbo Pascal's normal 16?

 A: This is only possible in the graphics mode. You'll need a
special BGI driver for the purpose. You'll find the drive and an
example of usage in
 18135 May 31 1989 ftp://garbo.uwasa.fi/pc/turbopas/vga256.zip
 vga256.zip Borland's BGI driver for VGA 256 color with Turbo Pascal demo
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:56 1998
Subject: Reading from the screen

116. *****
 Q: How can I read a text character from the screen (e.g. xy 5,2)?

 A: The code for the task is given below
  Uses Dos;
  (* Read an individual character from the screen *)
  function VDCHXYFN (column, row : byte) : char;
  var regs : registers;
      videocolumns : byte;
      videobase : word;
      offset : word;
  begin
    { Get the video base address }
    FillChar (regs, SizeOf(regs), 0);
    regs.ah := $0F;  Intr ($10, regs);
    if regs.al = 7 then videobase := $B000 else videobase := $B800;
    {}
    { Get the screen width }
    FillChar (regs, SizeOf(regs), 0);
    regs.ah := $0F;
    Intr ($10, regs);
    videocolumns := regs.ah;
    {}
    { Get the character }
    offset := (((row-1)*videocolumns)+(column-1))*2;
    vdchxyfn := chr(mem[videobase:offset]);
  end;  (* vdchxyfn *)

  begin
     writeln ('Character at 5, 2 is ascii ', Ord(VDCHXYFN(5,2)));
  end.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:57 1998
Subject: Clearing the screen

117. *****
 Q: How can I clear the screen without the Crt unit?

 A: Take a Kleenex and rub :-). Or turn off the computer.

 A2: The alternative below writes by direct screen writing a null
character to the ordinary 80 x 25 screen and drawing black on black.
  (* Clear the 80 x 25 screen without the Crt unit *)
  procedure ClrScreen;
  type ScreenType = array [0..1999] of array [0..1] of byte;
  var ColorScreen : ScreenType Absolute $B800:$0000;
  begin
    FillChar (ColorScreen, SizeOf(ColorScreen), 0);
  end;

 A3: There are also other approaches. These ones use the ROM BIOS to
set the video mode and at the same time clear the screen.
  (* Set a 25*80 text mode and clear screen, no Crt unit required *)
  procedure CLS;
  var regs : registers;
  begin
    FillChar (regs, SizeOf(regs), 0);
    regs.ah := $00;
    regs.al := $03;
    Intr ($10, regs);
  end;  (* cls *)

  (* Set a 25*40 text mode and clear screen, no Crt unit required *)
  procedure CLS40;
  var regs : registers;
  begin
    FillChar (regs, SizeOf(regs), 0);
    regs.ah := $00;
    regs.al := $01;
    Intr ($10, regs);
  end;  (* cls40 *)

A solution posting from John Stockton in news:comp.lang.pascal.borland
  "This is now revised and tested in various screen modes.  I'm not
  intending at present to do more with it, but I shall keep a
  latest-good copy at
          http://www.merlyn.demon.co.uk/programs/test_cls.pas
  With a Move, one can save the screen for later restoration.

  unit TEST_CLS { John Stockton, jrs@merlyn.demon.co.uk >= 1997/09/08 } ;
  { Note : Similar code, with Move instead of FillChar, can be used to
    save/restore a text screen.  Pre-Condition : do not use Crt unit. }
  interface
  procedure TestCls ;
  implementation

  {$IFNDEF VER70}
  const Seg0040 = $40 ; SegB000 = $B000 ; SegB800 = $B800 ;
  {$ENDIF}

  procedure WaitABit ;
  var J : longint ;
  begin for J := 1 to 3000000 do {OK for 486/dx33} end {WaitABit} ;

  function ThisMode : byte ;
  { instead of LastMode, which requires Crt }
  begin ThisMode := Mem[Seg0040:$49] end {ThisMode} ;

  function Monochrome : boolean ;
  const Mono = {Crt.Mono} 7 ;
  MonoSet = [Mono, $56, $57] { $56,$57 are mono on **MY** Tandon PC } ;
  begin Monochrome := ThisMode in MonoSet end {Monochrome} ;

  procedure TestCls ;
  var PScreen : pointer ;
    ScrSize, ScrSeg : word ; Cols : word ; Rows : byte ;
  begin
  if Monochrome then ScrSeg := SegB000 else ScrSeg := SegB800 ;
    PScreen := Ptr(ScrSeg, 0) ;   (*** Add allowance for Page Number ***)
    Cols := MemW[Seg0040:$4A] ; Rows := Succ(Mem[Seg0040:$84]) ;
    ScrSize := 2 * Cols * Rows ;
    FillChar(PScreen^, ScrSize, 0) { Could use Move here } ;
    Writeln(^M'  ScrSeg=', ScrSeg, '':5, Cols, ' * ', Rows,
      ' *2= ', ScrSize, MemW[Seg0040:$4C]:7) ;
    WaitABit end {TestCls} ;

  BEGIN ;
  END.

  If ANSI.SYS is installed, "Write(#27'[2J') ;" will do it
    (but *only* without Crt, unless 'CON' reassigned).  Consider
  redirection!

  For clear, but not copy, consider Int 10/06 with AL=0."
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:58 1998
Subject: Is a drive ready?

118. *****
 Q: How can I test if a disk is present in the drive?

 A: Below is the code
  uses Dos;
  (* Test if a drive is ready. The default drive is denoted by '0' *)
  function INDRIVFN (drive : char) : boolean;
  var regs : registers;
      dnum : word;
  begin
    drive := Upcase (drive);
    if drive = '0' then
       dnum := 0
     else
       begin
         case drive of
           'A'..'Z' : ;
           else begin indrivfn := false; exit; end;
         end;  {case}
         dnum := ord(drive) - ord('A') + 1;
       end;
    FillChar (regs, SizeOf(regs), 0);
    regs.ah := $1C;
    regs.dl := dnum;
    Intr ($21, regs);
    indrivfn := regs.al <> $FF;
  end;  (* indrivfn *)
In any source code there always are alternative ways of writing the
code. For example, as Dr John Stockton suggests, one could use
  if not (drive in ['A'..'Z'])
    then begin indrivfn := false; exit; end;
instead of the case statement in the above.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:01:59 1998
Subject: Adding to a date

119. *****
 Q: What is the Pascal code to add a number of days to a date?

 A: The code is given below, but first you need to obtain
  303573 May 2 1991 ftp://garbo.uwasa.fi/pc/turbopas/nrpas13.zip
  nrpas13.zip Numerical Recipes Pascal shareware version, 303K!
Extract caldat.pas and julday.pas from the archive. Replace all
occurrences of "integer" with "longint" in those two routines. After
that you can apply the DATEADD procedure tested below.
  uses Dos;
  {}
  (* Get a date a number of days from another date *)
  procedure DATEADD (dd, mm, yy        : word;
                     DaysToAdd         : longint;
                     var dd2, mm2, yy2 : word);
  var x, dd3, mm3, yy3 : longint;
  begin
    x := JULDAY (mm, dd, yy);
    CALDAT (x+DaysToAdd, mm3, dd3, yy3);
    dd2 := dd3; mm2 := mm3; yy2 := yy3;
  end;  (* dateadd *)
  {}
  (* A demonstration of adding a number of days to a date *)
  procedure TEST;
  var dd, mm, yy, dw : word;
      ddi, mmi, yyi  : word;
      daysToAdd      : longint;
  begin
    GetDate (yy, mm, dd, dw);
    daysToAdd := -100;
    DATEADD (dd, mm, yy, daysToAdd,   { <-- }
             ddi, mmi, yyi);          { --> }
    writeln ('Today + ', DaysToAdd, ' days: ',
             'day = ', ddi, ', month = ', mmi, ', year = ', yyi);
  end;  (* test *)
  {}
  begin
    TEST;
  end.
As so often, Dr John Stockton gave me very useful and welcome
comments on the draft of this item. Based on those tips one can add
another option for calculating the weekday. (C.f. an earlier item in
this FAQ "What is the code for the weekday of a given date?".) The
source code is given below.
  {}
  (* Weekday as a number Mon=0, Tue=1, ... *)
  function WDFN (dd, mm, yy : word) : word;
  begin
    WDFN := JULDAY(mm, dd, yy) mod 7;
  end;
  {}
  (* Weekday as a three-letter string *)
  function WDSTRFN (Day, Month, Year : Integer) : String;
  const DayStr = 'MonTueWedThuFriSatSun';
  begin
    WDSTRFN := Copy (DayStr, 3*WDFN(Day,Month,Year)+1, 3);
  end;
A further observation. We do not know for sure for which range of
dates the Numerical Recipes source code was built, so its safest
usage is modern dates. John wrote to me "JULDAY has a built-in
constant 'igreg=588829;' which I suspect is the non-Gregorian day
count for 1582/10/15 (0000/00/00 being Day 0). The code is therefore
only valid in the core area of Roman Catholicism. CALDAT has a
corresponding constant, JD for 1582/10/15."
  John also suggests a more comprehensive test routine
  {}
  procedure TEST2;
  var dd, mm, yy, yyi, ddi, mmi : word;
      DaysToAdd : longint;
  const X = '/';
  begin
    repeat
      write ('Year, Month, Day, Change (YYYY,MM,DD,Delta) ???? ');
      readln (yy, mm, dd, daysToAdd);
      if yy = 0 then exit;
      DATEADD (dd, mm, yy, daysToAdd, ddi, mmi, yyi);
      writeln (yy:8, X, mm:2, X, dd:2, ' + ', DaysToAdd, ' days -> ',
               yyi:4, X, mmi:2, X, ddi:2);
      writeln (WDFN(dd, mm, yy));
    until false;
  end; (* TEST2 *)

 A2: Robert Prins (prinsra@wcg.co.uk) kindly sent me the following
useful procedures for Julian day numbers and their inverse. Note
that the arguments of the routines are in a lightly different order
than in the Numerical Recipes solution.
  (* CJ converts a dd,mm,yyyy date into to its corresponding Julian
     Day Number. *)
  procedure cj(dd, mm, yyyy: integer; var jdn: longint);
  var yy: real;
      c : real;
  begin
    yy:= 1.0 * yyyy + (1.0 * mm - 2.85) / 12;
    if (10000 * longint(yyyy) + 100 * mm + dd) <= 15821004 then
      c:= 0.75 * 2
    else
      c:= 0.75 * trunc(yy / 100);
    jdn:= trunc(
          trunc(
          trunc(367 * yy) - 1.75 * trunc(yy) + dd) - c) + 1721115;
  end; (* cj *)
  {}
  (* JC converts a Julian Day Number to a dd,mm,yyyy date *)
  procedure jc(jdn: longint; var dd, mm, yyyy: integer);
  var n: real;
      c: real;
  begin
    n:= 1.0 * jdn - 1721119.2;
    c:= trunc(n / 36524.25);
    if jdn < 2299161 then
      n:= n + 2
    else
      n:= n + c - trunc(c / 4);
    yyyy:= trunc(n / 365.25);
    n   := n - trunc(365.25 * yyyy) - 0.3;
    mm  := trunc(n / 30.6);
    dd  := trunc(n - 30.6 * mm + 1);
    if mm > 9 then
      begin
        dec(mm, 9);
        inc(yyyy);
      end
    else
      inc(mm, 3);
  end; (* jc *)
Using Robert's procedures the addition would become
  Uses Dos;
  (* CJ and JC here *)
  {}
  (* Get a date a number of days from another date *)
  procedure DATEADD3 (dd, mm, yy        : integer;
                      DaysToAdd         : longint;
                      var dd2, mm2, yy2 : integer);
  var x : longint;
  var dd3, mm3, yy3 : integer;
  begin
    CJ (dd, mm, yy, x);
    JC (x+DaysToAdd, dd3, mm3, yy3);
    dd2 := dd3; mm2 := mm3; yy2 := yy3;
  end;  (* dateadd3 *)
  {}
  (* Another demonstration of adding a number of days to a date *)
  procedure TEST3;
  var dd, mm, yy, dw : integer;
      ddi, mmi, yyi  : integer;
      daysToAdd      : longint;
  begin
    GetDate (word(yy), word(mm), word(dd), word(dw));
    daysToAdd := -100;
    DATEADD3 (dd, mm, yy, daysToAdd,   { <-- }
             ddi, mmi, yyi);          { --> }
    writeln ('Today + ', DaysToAdd, ' days: ',
             'day = ', ddi, ', month = ', mmi, ', year = ', yyi);
  end;  (* test3 *)
  {}
  begin
    TEST3;
  end.

 A4: We can use the above information to answer also the question
"How to subtract dates?". Given the procedure CJ the code is
  (* Calculate the difference between two dates *)
  procedure DATESUBT (dd1, mm1, yy1  : integer;
                      dd2, mm2, yy2  : integer;
                      var difference : longint);
  var jdn1, jdn2 : longint;
  begin
    CJ (dd1, mm1, yy1, jdn1);
    CJ (dd2, mm2, yy2, jdn2);
    difference := jdn1 - jdn2;
  end; (* datesubt *)
A simple test:
  procedure TEST4;
  const dd1 = 21; mm1 = 5; yy1 = 1998;
        dd2 = 10; mm2 = 2; yy2 = 1998;
  var days : longint;
  begin
    DATESUBT (dd1, mm1, yy1, dd2, mm2, yy2, days);
    writeln ('day1 = ', dd1, ' month1 = ', mm1, ' year1 = ', yy1);
    writeln ('day2 = ', dd2, ' month2 = ', mm2, ' year2 = ', yy2);
    writeln ('Difference = ', days, ' days');
  end;  (* test4 *)
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:02:00 1998
Subject: Stuffing the keyboard

120. *****
 Q: How can I stuff keystrokes in advance into the keyboard buffer?

 A: This question was actually presented in a more complicated
format in news:comp.lang.pascal.borland. A user asked how he can
call another program from within a Turbo Pascal program and send
keystrokes to the program being called. This item takes on the
entire question in the demonstration code given below.

  {$M 2048, 0, 0}   (* <-- Important *)
  uses Dos;

  (* Slightly adjusted from an old message by Trevor Carlsen
     The comments with the "{-" in the routine are his *)
  function InsertKey (ch : char) : boolean;
  {-Insert a key into the keyboard buffer. Key must be passed
    with the MSB being the scan code of the key you want inserted
    and the LSB being the ascii code. For keys that return an
    extended code (cursor keys function keys etc.) the LSB must be
    zero and the MSB the scan code. Returns true if successful. }
  const
    BufferStart     = $1E;       {-Address of the keyboard buffer  }
    BufferEnd       = $3C;
  var
    head : word absolute $0040:$001A;
    tail : word absolute $0040:$001C;
    OldTail         : word;
  begin
    InsertKey       := true;
    MemW[$0040:tail]:= ord(ch);  {-Insert the keypress             }
    OldTail         := tail;     {-Keep record of tail position in }
                                 {-case the key buffer was full    }
    if tail = BufferEnd then     {-wrap around to Start of buffer  }
      tail := BufferStart
    else
      inc(tail, 2);              {-To allow for newly inserted key }
    if tail = head then begin    {-No room for inserting the key so}
      tail := OldTail;           {-restore the status quo          }
      InsertKey   := false;
    end; {-if tail = head}
  end; {-InsertKey}

  procedure TEST;
  var s : string;  (* The string to be stuffed into the buffer *)
      i : byte;
  begin
    s := 'Timo Salmi'+#13;  (* The buffer can hold only 16 characters *)
    for i := 1 to Length(s) do
      if not InsertKey(s[i]) then Break;
    write ('Calling the sufftst program from within Turbo Pascal');
    SwapVectors;
    Exec (GetEnv('comspec'), '/c stufftst');  (* Execution *)
    SwapVectors;
    if DosError <> 0 then
      writeln ('Dos error number ', DosError)
    else
      writeln ('Back in the original program. ',
               'Mission accomplished, exit code ', DosExitCode);
  end;  (* test *)

  begin
    TEST;
  end.

  (* The contents of the STUFFTST.PAS program.
     Compile it first for the demonstration.
  var st : string;
  begin
    writeln; writeln ('This is STUFFTST.EXE program running now!');
    write ('? '); readln (st);
    writeln ('Your input was = ' ,st);
  end.
  *)

There is a slightly more limited version that is much simpler to
write if you use interrupts:
  (* Store keystroke in keyboard buffer; AT/PS w enh keybd only *)
  function StuffKey (ch : char) : boolean;
  var regs : registers;
  begin
    FillChar (regs, SizeOf(regs), 0);
    regs.ah := $05;
    regs.cl := ord(ch);
    Intr ($16, regs);
    stuffkey := regs.al = 0;
  end;
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:02:01 1998
Subject: Fast 16-color PutPixel

121. *****
 Q: What is the code for a fast 16-color PutPixel Routine?

 A: This is a question that is far beyond my own capabilities. The
solution documented and stored here was found by a net friend Scott
Earnest in a posting by vxn8518@omega.uta.edu (Tigger). The material
below is edited from correspondence between Dr John Stockton and
Scott. The trivial demo structure, however, is my own. As you'll
see, the assembler version PutPix16 is blindingly fast if compared
to the ordinary PutPixel.

A warning. Don't try to run the program in a windowed dosbox. John
adds on the warning: "What precautions should be taken in program
testing?" The answer includes NOT trying anything suspect or clever
for the first time in a DOS box while other valuable processes are
still active, and also such as "turn all possible checks on until
you're sure they're not needed, then leave them on if you possibly
can" and "keep plenty of backups in independent places" and
"manually backup a program under development before and after
completing a significant change".

Scott and John exchanged about PutPix16 routine: "With so many
non-working 16 color putpixels, I was beginning to wonder if 16
color modes are still standard... but I finally found a great
source.  At ftp.cdrom.com in pub/simtelnet/msdos/graphics -- I found
the source code to FRACTINT, the great fractal imager.  Looking
through the code, I finally found some workable code... here it is
with comments and in the best form I can give... credits to Tim
Wegner! Modified a little by me [Scott]..."

It's Timo again: Great, just great!

  uses Dos, Crt, Graph;

  procedure GraphicsOn;
  var grDriver : integer;
      grMode   : integer;
      ErrCode  : integer;
  begin
    grDriver := Detect;
    InitGraph (grDriver, grMode, ' ');
    ErrCode := GraphResult;
    if ErrCode <> grOk then begin
      Writeln ('Graphics error:', GraphErrorMsg(ErrCode)); halt; end;
    ClearDevice;
  end;

  Procedure PutPix16 (x, y : word; c : byte); Assembler;
  Asm
    mov   ax, 0A000h              { ax = A000h                            }
    mov   es, ax                  { es = A000h                            }

    mov   ax, 640                 { ax = 640 (Width)                      }
    mov   bx, [y]                 { bx = y                                }
    mul   bx                      { dx:ax = y * 640                       }
    mov   cx, [x]                 { cx = x                                }
    add   ax, cx                  { dx:ax = x + y * 640 = Offset          }
    adc   dx, 00h                 { dx = dx + 1?                          }

    mov   cx, ax                  { cx = Offset (Lower Word)              }
    and   cx, 0007h               { Get bit 2 = 0000 0000 0000 0100       }
    xor   cl, 0007h               { Toggle Bit 2                          }

    mov   di, ax                  { di = Offset (Lower Word)              }
    shr   dx, 1                   { dx SHR 1                              }
    rcr   di, 1                   { di ROTATE RIGHT 1 WITH CARRY          }
    shr   dx, 1                   { dx SHR 1                              }
    rcr   di, 1                   { di ROTATE RIGHT 1 WITH CARRY          }
    shr   dx, 1                   { dx SHR 1                              }
    rcr   di, 1                   { di ROTATE RIGHT 1 WITH CARRY          }

    mov   dx, 03CEh               { dx = 03CEh = Graphics Address Port    }
    mov   ax, 0108h               { ax = 0108h = For Bit Mask Register    }
    shl   ah, cl                  { 1 SHL cl = Bits To Mask               }
    out   dx, ax                  { Send To Address Port 03CEh            }
    mov   ah, [c]                 { ah = c = Color Pattern To Set         }
    xor   al, al                  { al = 00h = Set/Reset Register         }
    out   dx, ax                  { Send To Address Port 03CEh            }
    mov   ax, 0F01h               { ah = 0Fh = 0000 1111 = 4 Planes       }
    out   dx, ax                  { Send To Address Port 03CEh            }
    or    es:[di], al             { Set The Pixel                         }
  End;

  procedure TEST;
  var x, y : word;
  begin
    GraphicsOn;
    for x := 0 to GetMaxX-1 do
      for y := 0 to GetMaxY-1 do
        PutPixel (x, y, LightRed);
    readln;
    RestoreCrtMode;
    CloseGraph;
  end;  (* test *)

  procedure TEST2;
  var x, y : word;
  begin
    GraphicsOn;
    for x := 0 to GetMaxX-1 do
      for y := 0 to GetMaxY-1 do
        PutPix16 (x, y, LightRed);
    readln;
    RestoreCrtMode;
    CloseGraph;
  end;  (* test2 *)

  begin
    TEST;
    TEST2;
  end.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:02:02 1998
Subject: Fast 256-color PutPixel

122. *****
 Q: What is the code for a fast 256-color PutPixel Routine?

 A: This is a question that is far beyond my own capabilities. The
solution documented and stored here comes from a net friend Scott
Earnest. The material below is edited from correspondence between Dr
John Stockton and Scott. The outcome seems to be instant fast, at
least on my 133MHz Pentium. A warning. Don't try to run this in a
windowed dosbox. The ppix2 routine runs a little faster of the two.

Scott and John exchanged: "Of course, one thing to keep in mind is
that in efficient graphics programming, the single pixel is usually
the most avoided creature, since much more time is used entering and
leaving the procedure than executing the code within the procedure.
For this reason, you'll find that speed-optimized code for drawing
lines, circles, boxes, etc., will use an inline putpixel or inline
code to greatly enhance efficiency."

"The only real problem [in the 256-color PutPixel routines] is
context. The above putpixel functions using Mem[] are not relevant
to the usual BGI modes." Timo's addition. That's why the video
setmode procedure is included. For more on video modes see
ftp://garbo.uwasa.fi/pc/programming/inter59a.zip.

Further comments from Timo. As a sideline note the interesting way
declare a type (TPixelProc) for the procedures to be tested.
Although not necessary, it makes a good shortcut in writing the
source code for the testing the various alternatives of a procedure.

  program testpix;

  {
   Speed comparison for two functionally equivalent putpixel routines
   in mode 13h (320x200x256c).  Speed difference will be most obvious
   if compiled and run under Turbo Profiler.

   (Compiled with range/overflow checking disabled, stack checking
   enabled, debug information included.)
  }

  {$F+} {Require FAR calls}
  uses Dos;

  {$IFNDEF VER70} const SegA000 : word = $A000; {$ENDIF}

  type TPixelProc = procedure (xpos, ypos : word; attribute : byte);

  procedure setmode (mode : word);
  var r : registers;
  begin
    fillchar (r, sizeof(r), 0);
    r.ax := mode;
    intr ($10, r);
  end;

  procedure ppix1 (xpos, ypos : word; attribute : byte);
  begin
    mem[SegA000:xpos+(ypos shl 6)+(ypos shl 8)] := attribute;
  end;

  procedure ppix2 (xpos, ypos : word; attribute : byte);
  begin
    mem[SegA000: (((ypos shl 2)+ypos) shl 6) + xpos] := attribute;
  end;

  procedure testpixel (pixelproc : TPixelProc);
  var
    x, y : word;
    c : byte;
  begin
    setmode ($13);
    for y := 0 to 199 do
      begin
        c := y;
        for x := 0 to 319 do
          begin
            pixelproc (x,y,c);
            c := succ(c) mod 256;
          end;
      end;
    readln;
    setmode ($03);
  end;

  begin
    testpixel (ppix1);
    testpixel (ppix2);
  end.

Olaf van der Spek (Spek@EuroNet.NL) sent me the following two
suggestions. PPix3 requires the directive {$G+} for 80286
instructions to be set on. These two procedures are just further
alternatives.
  PROCEDURE PPix3(X,Y:Word;C:Byte);
  ASSEMBLER;
  ASM
          MOV  BX,$A000
          MOV  ES,BX
          IMUL BX,Y,320
          ADD  BX,X
          MOV  AL,C
          MOV  ES:[BX],AL
  END;
  {}
  PROCEDURE PPix4(X,Y:Word;C:Byte);
  BEGIN
          Mem[$A000:X+320*Y]:=C;
  END;
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:02:03 1998
Subject: Substituting a substring

123. *****

 Q: How can I substitute a substring with another in a string?

 A: The answer is given below in the format of a test program for
the task.
  (* Substitute a substring with another in a string,
     substitute the first occurrence only *)
  function SUBST1FN (BaseStr, WhatStr, WithStr : string) : string;
  var p : byte;
  begin
    p := Pos (WhatStr, BaseStr);
    if p > 0 then
      subst1fn := Copy(BaseStr, 1, p-1) + WithStr
                + Copy(BaseStr, p+Length(WhatStr), 255)
      else subst1fn := BaseStr;
  end;  (* subst1fn *)

  (* Substitute all occurrences of a substring with another *)
  function SUBSTFN (BaseStr, WhatStr, WithStr : string) : string;
  var p, k : byte;
  begin
    p := Pos(WhatStr, BaseStr);
    k := Length(WhatStr);
    while p > 0 do begin
      BaseStr := Copy(BaseStr, 1, p-1) + WithStr
               + Copy(BaseStr, p+k, 255);
      p := Pos(WhatStr, BaseStr);
    end; {while}
    substfn := BaseStr;
  end;  (* substfn *)

  {Roger E. Donais (rdonais@southeast.net) gave me useful help in this
  item including the following comment on SUBSTFN: "This is a little
  trickier than it first seems.  Consider what happens if the old
  string is contained within the new string.  Or if the join between
  the new string and main string cause a matching pattern. Since this
  is functionally identical to the change function in my UTIL Unit,
  I've included it here.  I commented the old TP 3.0 code (string
  length was inefficient in TP 3.0) and upgraded the 'Change' routine
  for the efficiencies we now know --"}

  FUNCTION Change(const OldTxt,NewTxt: String; MainStr: String): String;
  { ============================================================ }
  VAR i,j: Integer;
  BEGIN{Change}
      i := 0;
      j := Pos(OldTxt,Copy(MainStr,Succ(i),255));
      While j <> 0 Do Begin
         {- Delete(MainStr,i + j,Ord(OldTxt[0]));       -}
         {- Insert(NewTxt,MainStr,i + j);               -}
         {- i := Pred(i + j + Ord(NewTxt[0]));          -}
         {- j := Pos(OldTxt,Copy(MainStr,Succ(i),255)); -}
         MainStr := Copy(MainStr, 1, Pred(i+j))
                  + NewTxt
                  + Copy(MainStr, i+j+Length(OldTxt), 255);
         i := Pred(i + j + Length(NewTxt));
         j := Pos(OldTxt,Copy(MainStr,Succ(i),255));
      End;
      Change := MainStr;
  END{Change};

  (* Upcase a string *)
  function UPSTRFN (s : string) : string;
  var i : byte;
  begin
    for i := 1 to Length(s) do s[i] := UpCase(s[i]);
    upstrfn := s;
  end;  (* upstrfn *)

  (* Substitute a substring with another in a string,
     substitute the first occurrence only. Case insensitive *)
  function SUBSC1FN (BaseStr, WhatStr, WithStr : string) : string;
  var p : byte;
  begin
    p := Pos (UPSTRFN (WhatStr), UPSTRFN (BaseStr));
    if p > 0 then
      subsc1fn := Copy(BaseStr, 1, p-1) + WithStr
                + Copy(BaseStr, p+Length(WhatStr), 255)
    else subsc1fn := BaseStr;
  end;  (* subsc1fn *)

  function SUBSCFN (BaseStr, WhatStr, WithStr : string) : string;
  var p, k : byte;
      BaseStrUp, WhatStrUp : string;
  begin
    BaseStrUp := UPSTRFN (BaseStr);
    WhatStrUp := UPSTRFN (WhatStr);
    p := Pos (WhatStrUp, BaseStrUp);
    k := Length(WhatStr);
    while p > 0 do begin
      BaseStr := Copy(BaseStr, 1, p-1) + WithStr
               + Copy(BaseStr, p+k, 255);
      p := Pos (WhatStrUp, UPSTRFN (BaseStr));
    end; {while}
    subscfn := BaseStr;
  end;  (* subscfn *)

  procedure TEST;
  var s : string;
  begin
    s := 'G:\WWW\~TS\GIFS2\GIFS2.HTM';
    writeln (SUBST1FN (s, 'G:\', 'file:///g|/'));
    writeln (SUBST1FN (s, 'g:\', 'file:///g|/'));
    writeln (SUBSTFN  (s, '\', '/'));
    writeln (Change   ('\', '/', s));
    writeln (SUBSC1FN (s, 'g:\', 'file:///g|/'));
    writeln (SUBSCFN  (s, 'g', 'x'));
  end;  (* test *)

  begin
    TEST;
  end.
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:02:04 1998
Subject: Crt.delay problem on a fast PC

124. *****

 Q: Curing Crt initialization runtime error 200 on fast machines

 A: I was not familiar with this problem myself since I have run
only sub-200MHz PCs, but I'll store here what I learned from the
excellent discussion on the subject in news:comp.lang.pascal.borland
by programmers much more knowledgeable than I. First of all the Crt
initialization crash only concerns TP and BP bersions 7.00 and 7.01.
Quoting Osmo Ronkanen: "The earlier versions had a bug that caused
only delays to be too slow from machines 386-33 or so on. This was
fixed in version 7.0 and the fix caused a new bug i.e. the division
by zero error on machines that were 55 times faster than the ones on
which the old bug appeared."
   First some references. Please be aware that I can't guarantee
that the URL addresses below will stay current.

 Prevent the "Divide by 0" error, Roger Donais. You'll need
 ftp://users.southeast.net/private/rdonais/rdelay.zip
 ftp://users.southeast.net/private/rdonais/util.zip

 NewDelay, Fix for bug in Crt unit's Delay procedure, by F.Heckenbach
 http://fjf.gnu.de/programs.html#NewDelay

 Problems with the Crt.Delay procedure, by Dr John Stockton
 http://www.merlyn.demon.co.uk/pas-time.htm#Delay

 Fix for "Runtime Error 200" bug of Borland Pascal 7 on fast PCs,
 by Klaus Hartnegg
 http://www.brain.uni-freiburg.de/~klaus/pascal/runerr200/

Roger's solution is also available as (or whichever version numbers
are current when you read this):
 4903 Jan 20 1997 ftp://garbo.uwasa.fi/pc/turbopas/rdelay10.zip
 rdelay10.zip Prevent the divide-by-0 Crt error on fast machines, R.Donais
 :
 56849 Jun 21 1997 ftp://garbo.uwasa.fi/pc/turbopas/rutil10.zip
 rutil10.zip Turbo Pascal utilities by R.Donais, (needed by rdelay)

Then there also is
 ftp://garbo.uwasa.fi/pc/turbspec/bp7patch.zip
 CRT Delay patch for TURBO.TPL 48,432 10-27-92 7:00a
and probably later versions in circulation.

The bug is in the Crt routine's initialization code. For example
Osmo Ronkanen writes "In the initialization code TP runs the delay
loop for one clock cycle. Then the result is divided by 55
(milliseconds in the cycle) to get loop size for one millisecond
delay. Now if that becomes greater than 65535 then the divide
overflow interrupt is called and that causes the runtime error to be
signaled." Dr John Stockton wrote "... initialize contains the
dreaded MOV 55 ; DIV CX"

   A trivial solution to the problem is not to use the Crt unit at
all and to use the 'Wait' procedure from the item "If Delay
procedure does not work properly, how do I fix it?" instead of the
Crt.Delay.
   Frank Heckenbach wrote about the 'Wait' procedure. "Besides the
fact that it doesn't prevent the runtime error 200 [if uses Crt is
included], as Osmo explained, this version's accuracy is only 1/18.2
seconds in contrast to 1 ms of the original Delay which should be
stuck to in replacements, IMHO."
   Frank continued: "I'd also like to draw your attention to another
problem that the above version as well as the original Delay code
suffer from, namely busy waiting, this means executing some code
during the most time of the delay. Whereas this doesn't matter on a
single tasking DOS, it will significantly reduce the CPU time
available to other processes when run under multi tasking OS's. (And
such environments should really be taken into account these days.)"

Osmo Ronkanen posted the following solution for TP 7.0 which is
brief enough to be included in here. Osmo wrote about its previous
version: "[This runtime fix] does not disable delay. Delay works
just as it does before on machines that are slower than those that
cause problem. On faster machines it also works but as the counter
is set to 65535 instead of its true value of that would be something
higher the delays get slower and slower. So on machines that are
twice as fast as the ones that just cause the error the delays are
half as log as they should be." (Timo's addition. If the resolution
of 'Wait' procedure is sufficient for the programmer's purposes,
then it is better to use FDelay+Wait than FDelay+Delay.)

  Unit Fdelay;              { Place this before CRT. Real mode only }
  interface
  const dfix:word=1;        { call delay() dfix times }

  implementation
  uses dos;

  procedure oldints; assembler; { "variables" in the code segment }
            asm dd 0,0 end;
  Procedure error;
  begin
    runerror(200);
  End;

  Procedure Int0; assembler;
            asm
            cmp cx,55       { If CX<>55 we are at some other point }
            je @ok
            sti
            call error
  @ok:
            shr dx,1        { divide dx:ax by 2 }
            rcr ax,1
            shl Dfix,1      { multiply Dfix by 2 }
            iret            { return to the DIV (286+) }
            end;

  { Int21h handler removes the int0 handler (as well as itself) from
    the memory when CtrlBreak vector is set by CRT right after
    calculating the delay counter. Note DS does NOT point to the data
    segment when this is called }

  Procedure Int21h; assembler;
            asm
            cmp ax,$251B
            jne @old               { Not setint 1Bh? }
            push es; push si; push di
            mov si,offset oldints
            xor di,di
            mov es,di
            cld
            segcs; movsw
            segcs; movsw           { restore int 0 }
            mov di,$21*4
            segcs; movsw           { restore int 21h }
            segcs; movsw
            pop di; pop si; pop es
  @old:     db $2e,$ff,$2e         { jmp far indirect cs:[oldints+4] }
            dw offset oldints+4
            end;

  type tr=record int0,int21:pointer; End;
       pr=^tr;

  begin
    GetIntVec(0,pr(@oldints)^.int0);
    GetIntVec($21,pr(@oldints)^.int21);
    SetIntVec(0,@int0);
    SetIntVec($21,@int21h);
  end.

Roger Donais emailed me the following version based on Osmo's codes.
It is for TP 4.0-7.0. Just put
  uses FDelay, Crt;
at the top of your program. Nothing else is needed. Not even a call
at the beginning of the main program. This is a nice end result of
the concerted efforts of the news:comp.lang.pascal.borland newsgroup.
Please note, however, that the code below does not have all the
safeguards that the code above does according to its author.
  UNIT FDelay;
  { Purpose is to intercept 1st divide by zero error and if it appears
    it could be from CRT to allow it to pass thereby allowing TP 7.0
    (real mode) to use CRT (w/o delay) on systems with fast processors.
    This solution will not work w/ multiple divide by 0 errors and may
    leave the system unstable if an error occurs during TP exit process.
    }

  INTERFACE
  USES DOS;

  IMPLEMENTATION

  VAR Old0  : Pointer;
      TPExit: Pointer;

  PROCEDURE Int0 (Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP
                  : Word); interrupt;
  BEGIN
      SetIntVec(0, Old0);
      If CX = 55 Then Begin
         AX := 65535;
         DX := 54;
      End; { Else error recurs w/ original int0 handler }
  END;

  PROCEDURE OnExit; FAR;
  BEGIN
      ExitProc := TPExit;
      SetIntVec(0, Old0);
  END;

  BEGIN
      GetIntVec(0, Old0);
      SetIntVec(0, @Int0);
      TPExit := ExitProc;
      ExitProc := @OnExit;
  END.

If you wish to solve the problem by not using the Crt unit at all,
below is a list of all the Crt unit procedures and functions and the
replacements that yours truly (Timo) has released or that can be
found in the FAQ.
  Crt            Replacement                  Where
  ---            -----------                  -----
  AssignCrt      ..                           ..
  ClrEol         ..                           ..
  ClrScr         ClrScreen,CLS,CLS40          FAQ #117
  Delay          Wait                         FAQ #67
  DelLine        ..                           ..
  GotoXY         GOATXY                       TSUNTG in tspa*.zip
  HighVideo      ..                           ..
  InsLine        ..                           ..
  KeyPressed     KEYPREFN                     TSUNTM in tspa*.zip
  LowVideo       ..                           ..
  NormVideo      ..                           ..
  NoSound        ..                           ..
  ReadKey        READKEFN,RDENKEFN            TSUNTM in tspa*.zip
  Sound          AUDIO                        TSUNTD in tspa*.zip
  TextBackground ..
  TextColor      ..
  TextMode       ..
  WhereX         WHEREXFN                     TSUNTG in tspa*.zip
  WhereY         WHEREYFN                     TSUNTG in tspa*.zip
  Window         ..

 Q2: If the delay() statement isn't called, does the code compile
bad anyway?

 A2: Had you first carefully read the first part of this FAQ item
#124 "Curing Crt initialization runtime error 200 on fast machines"
you would have noted "The bug is in the [TP7] Crt routine's
initialization code". It is NOT calling delay() that causes the
error. It is the "Uses Crt". Thus you can't avoid the problem by
just not using delay() if you insert the Crt unit into a TP 7.0
program on a fast PC. The error is a Crt initialization error, not a
delay() error. The (further) problem with delay() is that it can be
inaccurate. That aspect is covered in the item #67 "If Delay
procedure does not work properly, how do I fix it?".

 A3: A terminology comment from Paul Schlyter: "BTW it's not really
a "divide by 0", but rather a division overflow, where the 32-bit
numerator divided by the 16-bit denominator makes the quotient
overflow 16 bits.  However, the same hardware interrupt is generated
for division overflow as for division by zero."
--------------------------------------------------------------------

From ts@uwasa.fi Sat Oct 10 00:02:05 1998
Subject: Copying from TP help

125. *****

 Q: How can I copy text and example codes from Turbo Pascal help?

 A: Sometimes it is useful to be able to copy material from the
Turbo Pascal help. The following keys are of relevance
  F1           Help on help
  Ctrl+F1      Context sensitive help (particularly useful!)
  Alt+F1       Back to the previous topic
  Shift+F1     Turbo Help Index
  Esc          Close help
  Shift+Arrow  Paint text (works also inside help)
  Ctrl+Ins     Copy the painted text to the TP clipboard
  Shift+Ins    Paste from the TP clipboard to the current position
So invoke the part of the help you need, paint, copy the text to the
clipboard and paste it where you want it.
   For an alternative method see Turbo Pascal version 7.0 User's
Guide item "Copying code examples" on page 36.
   An edited note from John Stockton: When running in a Windows DOS
box, remember the editing available by way of Alt-Space E - rather
useful.

--------------------------------------------------------------------

