Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TURBOGEN.ZIP/LIBRARY2.GEN

Text File | 1988-01-27 | 21.9 KB | 589 lines

(*-----------------------------------------------------------------*)
(*         Beep  --- Make some noise                               *)
(*-----------------------------------------------------------------*)

Procedure Beep(numbertodo,pitch, duration:Integer);
Const
delaylength  = 200;
defaultnumb  = 3;
defaultpitch = 448;
defaultdur   = 250;

Var
j : Integer;

Begin
   If numbertodo < 1 Then numbertodo := defaultnumb;
   If pitch < 1 Then pitch := defaultpitch;
   If duration < 1 Then duration:=defaultdur;
   If numbertodo > 0 Then For j := 1 To numbertodo Do
   Begin
      Sound(pitch);
      Delay(duration);
      Nosound;
      Delay(delaylength)
   End
End;

(*-----------------------------------------------------------------*)
(*               Ljust --- Left Justify string (same length)       *)
(*-----------------------------------------------------------------*)

FUNCTION Ljust( S : AnyStr ) : AnyStr;

(*-----------------------------------------------------------------*)
(*                                                                 *)
(*     Purpose:    Set data field characters to left of string     *)
(*                 for getstring input utility                     *)
(*                                                                 *)
(*     Calling sequence:                                           *)
(*                                                                 *)
(*         LJust_S := Ljust( S );                                  *)
(*                                                                 *)
(*            S           --- the string to be trimmed             *)
(*                                                                 *)
(*     Calls:  None                                                *)
(*                                                                 *)
(*     Remarks:                                                    *)
(*                                                                 *)
(*        Using same string on each side of calling arg will alter *)
(*        source using different name will leave source unchanged  *)
(*-----------------------------------------------------------------*)

VAR
   I:       INTEGER;
   Trimmed: BOOLEAN;
   L:       INTEGER;

BEGIN (* Ljust *)
   Ljust := '';
   IF LENGTH( S ) > 0 THEN
      BEGIN
         I       := 0;
         L       := LENGTH( S );
         Trimmed := FALSE;
         REPEAT
            I := I + 1;
            IF ( I <= L ) THEN
               Trimmed := S[I] <> ' '
            ELSE
               Trimmed := TRUE;
         UNTIL Trimmed;
         IF ( ( L - I + 1 ) > 0 ) THEN
            Ljust := concat( Copy( S,I,L-I+1), Copy( S,1,I-1));
      END;
END   (* Ljust *);


(*-----------------------------------------------------------------*)
(*               Trim --- Drop trailing spaces from anystring var  *)
(*-----------------------------------------------------------------*)
Function Trim(var S:anystr):anystr;

begin
  I := length(s);
  while (I > 0) and (s[i] = ' ') do
    i := i-1;
    if i = 0 then trim := '' else trim := copy(s,1,i);
end;


(*-----------------------------------------------------------------*)
(*                                                                 *)
(*    copyright (C) 1984 by Neil J. Rubenking                      *)
(*                                                                 *)
(* The purchaser of these procedures and functions may include     *)
(* them in COMPILED programs freely, but may not sell or give away *)
(* the source text.                                                *)
(*                                                                 *)
(* This function uses the keyboard BIOS interrupt $16 (decimal 22).*)
(* If "action" is 'W', the function WAITS until a key is pressed   *)
(* and then returns it.  If action is 'N' there is NO WAIT, and a  *)
(* character is returned only if there is one in the buffer.       *)
(* (This is more-or-less equivalent to using TURBO's boolean       *)
(* "keypressed" function and "read(Kbd)". If the key pressed has   *)
(* an "extended" scan code (e.g., function keys, arrow keys) the   *)
(* ASCIIcode will be 0.                                            *)
(*                                                                 *)
(* This function does NOT recognize characters generated by        *)
(* pressing the ALT key and typing in numbers.                     *)
(*                                                                 *)
(* NOTE that any program that INCLUDEs this file MUST also include *)
(* the type declarations contained in Globtype.gen                 *)
(*                                                                 *)
(*-----------------------------------------------------------------*)
(*                                                                 *)
(*  Modifications of 7/87 to allow real time function key event    *)
(*  processing. (Bob Logan)                                        *)
(*                                                                 *)
(*-----------------------------------------------------------------*)

function KeyBoard(action : char):integer;

var
  registers : regpack;
  temp      : integer;
begin
  with registers do
    begin
      case UpCase(action) of
        'W': AX := 0 ;
        'N': AX := 1 shl 8;
      end;
    intr($16,registers);
    if action = 'N' then
      if flags and 64 = 64 then  {zero flag set means no character}
        temp := 0
      else temp := KeyBoard('W')
    else temp := AX;
    KeyBoard := temp;
  end;
end;

(*-----------------------------------------------------------------*)
(*  READS AND RETURNS A STRING NAMING THE KEY PRESSED              *)
(*-----------------------------------------------------------------*)

type
  KeyType = string[12];

Const
  funcount  = 47;
  funkeys             : Array[1..funcount] of KeyType =
                ('F1','F2','F3','F4','F5','F6','F7','F8','F9','F10',
                 'Ctrl-F1','Ctrl-F2','Ctrl-F3','Ctrl-F4','Ctrl-F5',
                 'Ctrl-F6','Ctrl-F7','Ctrl-F8','Ctrl-F9','Ctrl-F10',
                 'Shift-F1','Shift-F2','Shift-F3','Shift-F4','Shift-F5',
                 'Shift-F6','Shift-F7','Shift-F8','Shift-F9','Shift-F10',
                 'Alt-F1','Alt-F2','Alt-F3','Alt-F4','Alt-F5',
                 'Alt-F6','Alt-F7','Alt-F8','Alt-F9','Alt-F10','End',
                 'Up','Home','Ctrl-Home','Crtl-PrtSc','Esc','Return'
                );

var
  KeyValue            : integer;
  ASCIIcode, ScanCode : byte;
  Result              : KeyType;


Function Is_funkey : Boolean;
 Var i : integer;
begin
  Is_Funkey := False;
  For i := 1 to funcount do
   if result = funkeys[I] then
   Is_Funkey := True;
end;


function Read_Keyboard(wait_flag:char): KeyType;
var
  TempRead : KeyType;
  P        : integer; {error pos on val call in function handler }

function SpecialKey(Code:byte):KeyType;
const
  Row0 : KeyType = '1234567890-=';
  Row1 : KeyType = 'QWERTYUIOP';
  Row2 : KeyType = 'ASDFGHJKL';
  Row3 : KeyType = 'ZXCVBNM';
var
  temp : KeyType;
begin
case code of
       14: temp := 'BackSpace';
       15: temp := 'Back Tab';
   16..25: temp := 'Alt-' + Row1[code-15];
   30..38: temp := 'Alt-' + Row2[code-29];
   44..50: temp := 'Alt-' + Row3[code-43];
 120..131: temp := 'Alt-' + Row0[code-119];
   59..67: temp := 'F' + chr(code - 10);
       68: temp := 'F10';
   84..92: temp := 'Shift F' + chr(code-35);
       93: temp := 'Shift F10';
  94..102: temp := 'Ctrl-F' + chr(code-45);
      103: temp := 'Ctrl-F10';
 104..112: temp := 'Alt-F' + chr(code-55);
      113: temp := 'Alt-F10';
       71: temp := 'Home';
       72: temp := 'Up';
       73: temp := 'PgUp';
       75: temp := 'Left';
       77: temp := 'Right';
       79: temp := 'End';
       80: temp := 'Down';
       81: temp := 'PgDn';
       82: temp := 'Ins';
       83: temp := 'Del';
      114: temp := 'Ctrl-PrtSc';
      115: temp := 'Ctrl-Left';
      116: temp := 'Ctrl-Right';
      117: temp := 'Ctrl-End';
      118: temp := 'Ctrl-PgDn';
      119: temp := 'Ctrl-Home';
      132: temp := 'Ctrl-PgUp';
 else
   temp := 'Ctrl-Break';
 end;  {case}
SpecialKey := temp;
end;

function SpecChr(code:byte):KeyType;

begin
  case code of
     0..26 : SpecChr := 'Ctrl-' + chr(code + 64);
        27 : SpecChr := 'Esc';
   28..255 : SpecChr := chr(code);
  end;
end;

begin
    KeyValue  := KeyBoard(Wait_Flag);
    ScanCode  := KeyValue shr 8;
    ASCIICode := (KeyValue shl 8) shr 8;
       {The special keys that have no ASCII character generate }
       {a zero in place of the code.  However, there are three }
       {non-printable characters that DO have an ASCII code.   }
       {Their scan codes are 14, 15, and 28.  We provide for   }
       {them below.                                            }

    if (not (ScanCode in [14,15,28])) and (ASCIICode <> 0)  then
      TempRead := SpecChr(ASCIICode)
    else
      begin
if ASCIICode <> 0 then
  begin
    case ScanCode of
      14: TempRead := 'BackSpace';
      15: TempRead := 'Tab';
      28: TempRead := 'Return';
    end;  {case}
  end  {second if}
      else
    TempRead := SpecialKey(ScanCode);
      end;  {the upper else}
   Read_Keyboard := TempRead;
end;

Procedure Show_Error( Error_Number:integer);
  { this is still a good idea it just has gotten out of hand }


(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*     Procedure: Show_Error                                                *)
(*                                                                          *)
(*     Purpose:    Display user generated error conditions during           *)
(*                 data entry                                               *)
(*                                                                          *)
(*     Calling sequence:                                                    *)
(*                                                                          *)
(*        Show_Error ( Error_Number : Integer );                            *)
(*                                                                          *)
(*                                                                          *)
(*     Calls:  Beep                                                         *)
(*             Save_Screen                                                  *)
(*             Draw_menu_Frame                                              *)
(*             Restore_Screen                                               *)
(*                                                                          *)
(*     Remarks:                                                             *)
(*             Error list:                                                  *)
(*                         1 : Past end of field length                     *)
(*                         2 : Non_Numeric character during numeric entry   *)
(*                         3 : Past beginning of field on left              *)
(*                         4                                                *)
(*                         5                                                *)
(*                         6                                                *)
(*                         7                                                *)
(*                         8                                                *)
(*                         9                                                *)
(*                                                                          *)
(*     As you have already noted justd add to the list below for your       *)
(*     application dependent errors and call here                           *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

VAR
       title    : String[30];
       msg      : string[78];
       I        : BYTE;
       J        : BYTE;
       save_C25 : PACKED ARRAY[1..80] OF CHAR;
       save_A25 : PACKED ARRAY[1..80] OF INTEGER;
       cx,cy    : integer;

BEGIN {Show_Error}

Case error_number of
  20 : title := 'Status Report';
  12 : title := 'Attention';
ELSE
       title := 'Data Entry Error ';
END;

case error_number of
  1: msg:= 'Attempt to move past end of field ';
  2: msg:= 'Bad Key Stroke Numeric data only';
  3: msg:= 'Attempt to move past start of field';
  5: msg:= 'Zero is not acceptable';
 15: msg:= 'Unable to figure cost per ton...Please enter...';
 20: msg:= 'Selected Process is complete....';
ELSE
  msg:='Unknown data entry error';
END {case};
   cx := WhereX;
   cy := WhereY;
   msg := Title +'-->'+msg+' Press <Esc>';
                            (* Line 25, Column 1 *)
   Turbo_window(1,1,80,25);
   GotoXY(1,25); ClrEol; GotoXy(Trunc((80-Length(Msg))/2),25);
   textColor(White+Blink);
   Write(msg);
   Reset_Global_Colors;
   beep(1,600,150);
   repeat until Read_Keyboard('W') = 'Esc';
                            (* Restore previous text *)
   gotoXY(1,25);
   clrEol;
   Turbo_window(Upper_Left_Column, Upper_Left_Row, Lower_Right_Column, Lower_right_Row);
   gotoXY(Cx,Cy);
END {Get_Error};


function Ioerror :byte;

Var
  Code:byte;
  Msg :string[40];

begin
  Code := ioresult;
  if Code = 0 then
    begin
       IoError := Code;
       exit;
    end;

  case Code of
    $01 : Msg := 'File not found.';
    $02 : Msg := 'File not open for reading.';
    $03 : Msg := 'File not open for writing.';
    $04 : Msg := 'File not reset or rewriten.';
    $10 : Msg := 'Illegal numeric format in data.';
    $20 : Msg := 'illegal operation for a logical device.';
    $21 : Msg := 'Illegal operation in direct mode. ';
    $22 : Msg := 'Illegal to assign to standard file';
    $90 : Msg := 'unmatched record lengths.';
    $91 : Msg := 'End of file encountered.';
    $99 : Msg := 'Unexpected End of file encountered.';
    $F0 : Msg := 'Disk Full.';
    $F1 : Msg := 'Directory Full.';
    $F2 : Msg := 'File Size overrun(65535 records)';
    $F3 : Msg := 'To many files open.';
    $F4 : Msg := 'File no longer in directory....';
  else
     Msg := '** unknown I/O error encountered **'
  end;
  (*  modify to use windows like above *)
  writeln('** I/O error encountered. **');
  writeln('** error code = ',COde);
  writeln('** ', Msg);
  IoError := Code
end;

(*-----------------------------------------------------------------*)
(*                                                                 *)
(*  GetString   : all purpose data entry utility                   *)
(*                                                                 *)
(*  This utility is used to interface with the user. It allows     *)
(*  event trapping during entry of all data type for pascal.       *)
(*  Cursor movement is controled (within the current data item)    *)
(*  Screen highlighting is controled by colors passed to utility.  *)
(*  Forcing the operator to signal entry complete is controled by  *)
(*  the confirm flag. set true to force user to press RETURN or    *)
(*  TAB to exit current field otherwise field is exited when n     *)
(*  allowable charcters are entered. User may press RETURN or TAB  *)
(*  at any time before n chars are input.  The current field       *)
(*  contents are displayed and if RETURN or TAB ar pressed first   *)
(*  the current contents are left untouched.                       *)
(*                                                                 *)
(*  Cursor control keys are:                                       *)
(*           Left one character  : Left Arrrow,Backspace,Del       *)
(*                                 (non-destructive)               *)
(*           Right one character : Right Arrow                     *)
(*           Clear field (from current cursor location to end      *)
(*                        of field )  : Ctrl-End                   *)
(*                                                                 *)
(*-----------------------------------------------------------------*)
(*  This utility was adabted from COMPLETE TURBO PASCAL  by        *)
(*                                Jeff Duntemann                   *)
(*                                                                 *)
(*    CALLS:  After modification by Bob Logan the utility makes    *)
(*            the folowing calls:                                  *)
(*                                                                 *)
(*              Ljust        - Left justify a string               *)
(*              Read_Keyboard- FancyKey-Public Domain utility by   *)
(*                             Neil J. Rubenfing which returns the *)
(*                             name of keypressed                  *)
(*              Show_Error   - Displays error condition (Windows)  *)
(*                                                                 *)
(*  Note : You must have delcared a string type of str80 which is  *)
(*         string[80].                                             *)
(*                                                                 *)
(*-----------------------------------------------------------------*)
(*  7/87  function key support (see read_keyboard) modifications-- *)
(*   pressing any function key has same effect on field contents   *)
(*   as pressing TAB.  Calling proc then tests for functions as it *)
(*   sees fit.   If function key created exit from field then same *)
(*   field should be reentered after processing function key.      *)
(*-----------------------------------------------------------------*)

Procedure getstring(
x,y            : Integer ;  (* x y screen cords *)
Var  xstring   : str80   ;  (* default string   *)
maxlen         : Integer ;  (* number of keystrokes to allow *)
capslock       : Boolean ;  (* force to uppercase YN *)
numeric        : Boolean ;  (* string or numeric result *)
get_real       : Boolean ;  (* if numeric real or integer result *)
Var rvalue     : Real    ;  (* real value *)
Var ivalue     : Integer ;  (* integer value *)
Var error      : Integer ;  (* string to numeric error location *)
active_color   : Integer ;  (* input string color *)
inactive_color : Integer ;  (* color for field after input *)
dec            : Integer ;  (* number of decimals for real values *)
confirm        : Boolean    (* force return - or count chars for done *)
);

Var
i           : Integer;
ch          : Char;
fill        : Char;
clearit     : str80;
worker      : str80;
printables  : Set Of Char;
lowercase   : Set Of Char;
numerics    : Set Of Char;
cr,do_ins   : Boolean;

Begin
   printables := [' '..'}'];
   lowercase  := ['a'..'z'];
   do_ins := false;
   If get_real Then numerics := ['-','.','0'..'9','E','e']
   Else numerics := ['-','0'..'9'];
   fill   := '_';
   cr     := False;

   For i := 1 To maxlen Do clearit[i] := fill;

   clearit[0] := Chr(maxlen);
   If Length(xstring) > maxlen Then xstring[0] := Chr(maxlen);
   If numeric Then
   If get_real Then
   Str(rvalue:maxlen:dec,xstring)
   Else
   Str(ivalue:maxlen,xstring);
   xstring:=ljust(xstring);

   Textcolor(active_color);
   Gotoxy(x,y); Write(clearit);
   Gotoxy(x,y); Write(xstring);
   Gotoxy(x,y);
   worker := '';

   Repeat
      ch:=Chr(0);
      result := read_keyboard('W');
      If Length(result) = 1 Then
      ch:= result[1];
      i:= wherex;
      If ch In printables Then
      If Length(worker) >= maxlen Then
      show_error(1)
      Else
      If numeric And (Not (ch In numerics)) Then
      show_error(2)
      Else
      Begin
         If ch In lowercase Then
         If capslock Then
         ch := Chr(Ord(ch)-32);
         if not do_ins then delete(worker,wherex-x+1,1);
         insert(ch,worker,wherex-x+1);
         Gotoxy(x,y);Write(worker);
         gotoxy(i+1,y);
         If (Length(worker) = maxlen) And (Not confirm) Then cr := True;
      End
      Else { CHAR NOT IN PRINTABLES}

      If (result = 'Left') or (result = 'Backspace')then
      begin
       If Wherex = x then
        result := 'Up'
       else
        GotoXY(wherex-1,y);
      end;

      If Result = 'Ins' then  do_ins := (not do_ins);

      If (result = 'Del') and (Length(worker) > 0) Then
      Begin
         Delete(worker,i-x+1,1) ;
         Gotoxy(x,y); Write(clearit);
         Gotoxy(x,y);
         Write(worker);
         Gotoxy(i,y);
      End;

{                  Now check for tab or special function key and }
{                  force carriage return if so                   }

      If (is_funkey) or (result = 'Tab') or (result = 'Down')  Then
      Begin
        if    worker = '' then worker := xstring;
        cr := True;
      End;

      If result = 'Ctrl-End' Then
      Begin         { CTRL-END - BLANK OUT THE FIELD }
         {           from current cursor position to }
         {           end of field                    }
         if i > x then worker[0] := chr(i-x) else worker[0] := chr(0);
         xstring := worker;
         Gotoxy(x,y); Write(clearit);
         Gotoxy(x,y); Write(worker); Gotoxy(i,y);
      End;

      If result = 'Right' Then
      If (Length(worker)>=maxlen) Then
      begin
        if    worker = '' then worker := xstring;
        if Not Confirm then cr := true;
      End Else
      Begin
         i:= Length(worker)+1;
         worker := Concat(worker,xstring[i]);
         Gotoxy(Wherex+1,y)
      End;
   Until cr;

   Textcolor(inactive_color);
   Gotoxy(x,y); Write(clearit);
   Gotoxy(x,y); Write(worker);
   If cr Then
   Begin
      xstring := ljust(worker);
      If numeric Then
      Case get_real Of
         True  : Val(worker,rvalue,error);
         False : Val(worker,ivalue,error)
      End {CASE}
   End
   Else
   Begin
      rvalue := 0.0;
      ivalue := 0
   End;
End; {GETSTRING}