{$D-}

Unit Misc;

{***************************************************************************}

{* SORTED BY TYPE:

{*   DATA [FILE, NUMERICAL, TEXT];

{*   I/O  [CRT, FILE, ERROR, USER];

{*   SORT [TEXT, NUMERICAL]

{*   SEARCH

{*   PROGRAM.

{*

{* SplitFileName      DATA      FILE

{* DiceRoll           DATA      NUM    int

{* HexToDec           DATA      Num    LongInt     Hex to Decimal

{* Factorial          DATA      NUM

{* Hex                DATA      Num    String

{* JulianTime         DATA      NUM

{* Quad               DATA      NUM    byte; identifies the quadrant 1 to 4

{* Stats              DATA      NUM

{* TimeDiff           DATA      NUM

{* TimeInSecs         DATA      NUM    time from MS-DOS

{* TimeSecs           DATA      NUM    longint

{* TimeSecSplit       DATA      NUM

{* DateTimeStr        DATA      TEXT   string

{* DropLeadBlanks     DATA      TEXT

{* GetQuote           DATA      TEXT

{* IntStr             DATA      TEXT

{* MultiChar          DATA      TEXT

{* ParseInt           DATA      TEXT

{* PosChars           DATA      TEXT

{* PosString          DATA      TEXT

{* StrByte            DATA      TEXT

{* StrInt             DATA      TEXT

{* StrIntLen          DATA      TEXT

{* StrIntSig          DATA      TEXT    string; with + or - sign

{* StrIntZer          DATA      TEXT    STRING

{* StrPhone           Data      TEXT    string

{* StrReal            DATA      TEXT

{* StrSized           DATA      TEXT

{* StrSizedLead       data      text    string

{* StrStripNonNum     data      text    string

{* StrWrdZer          DATA      TEXT

{* UpCaseFirstLetters DATA      TEXT    string

{* UpCaseStr          DATA      TEXT

{* ValChar            DATA      TEXT

{* ValInt             DATA      TEXT

{* ValReal            DATA      TEXT

{* IOCumOK            I/O       ERROR   ANDs IOResult with previous

{* IOError            I/O       ERROR

{* IOGood             I/O       ERROR

{* SortSIT            SORT      TEXT

{* DoSubProg          PROGRAM

{*

{***************************************************************************}

Interface

{***************************************************************************}

{***************************************************************************}

const

  MathUnitConstant = 100;



type

  MathUnitRealArrayType = array[1..MathUnitConstant] of real;

  MathUnitStringArrayType = array[1..MathUnitConstant] of string;



Function  CharByte(InByte: byte): char;

Function  DecToHex(Dec: longint): string;

Function  DiceRoll(Mul, Die, Bas: integer): integer;

Procedure DoSubProg(SubProg: string);

function  Factorial(InInt: integer; InFactorial: integer): boolean;

Function  HexToDec(Hex: string): longint;

Procedure IOCumOK(var PrevAndNewStatus: boolean);

Function  IOError: byte;

Function  IOGood: boolean;

Function  LongIntStr(InStr: string): longint;

Procedure ParseInt(InStr:string; var Position: integer; var IntOut: integer);

Function  Quad(X, Y: longint): byte;

procedure SortSIT(var TextArray: MathUnitStringArrayType;

            LineCount, Position, Width: integer);

procedure Stats(NumArray: MathUnitRealArrayType; Count: integer;

            var Mean, Median, StanDev, MinValue, MaxValue: real);

function  ValChar(CharVal: char): integer;

function  ValInt(StrVal: string): integer;

function  ValReal(StrVal: string): real;

function  WildCardFormat(FormatStr: string; InStr: string): boolean;



Implementation

{***************************************************************************}

{***************************************************************************}

uses

  Data,

  Dos,

  Glob,

  IOPorts,

  Keyb;



Function  CharByte(InByte: byte): char;

{***************************************************************************}

var

  Temp: char;

begin

  Temp := char(InByte);

  CharByte := Temp;

end;



Function DecToHex(Dec: longint): string;

{***************************************************************************}

var

  H: array[1..4] of integer;

  HH: array[1..4] of string[1];

  alpha: integer;

begin

  if Dec > (16*16*16*16) then

    begin

      writeln('Overflow in Function Hex!');

      halt;

    end;

  H[4] := (Dec Mod (16*16*16*16)) div (16*16*16);

  H[3] := (Dec Mod (16*16*16)) div (16*16);

  H[2] := (Dec Mod (16*16)) div 16;

  H[1] := Dec Mod 16;

  for alpha := 1 to 4 do

    case H[alpha] of

      10:  HH[alpha] := 'A';

      11:  HH[alpha] := 'B';

      12:  HH[alpha] := 'C';

      13:  HH[alpha] := 'D';

      14:  HH[alpha] := 'E';

      15:  HH[alpha] := 'F';

      else

        str(H[alpha],HH[alpha]);

    end; {case}

  DecToHex := HH[4] + HH[3] + HH[2] + HH[1];

end;



Function  DiceRoll(Mul, Die, Bas: integer): integer;

{***************************************************************************}

var

  alpha,

  subtotal: integer;

begin

  randomize;

  subtotal := 0;

  for alpha := 1 to Mul do

    subtotal := subtotal + random(Die) +1;

  DiceRoll := subtotal + Bas;

end;



Procedure DoSubProg(SubProg: string);

{***************************************************************************}

begin

  SwapVectors;

  Exec(SubProg,'');

  SwapVectors;

  if DosError <> 0 then

    begin

      writeln('DosError = ',DosError,'!');

      writeln('Press ENTER to continue...');

      readln;

    end;

end;



function Factorial(InInt: integer; InFactorial: integer): boolean;

{***************************************************************************}

var

  TempReal1,

  TempReal2: real;

  TempFactorial: boolean;

begin

  TempReal1 := InInt/InFactorial;

  TempReal2 := int(InInt/InFactorial);

  if TempReal1 = TempReal2 then

    TempFactorial := true

  else

    TempFactorial := false;

  Factorial := TempFactorial;

end;



Function HexToDec(Hex: string): longint;

{***************************************************************************}

var

  NewHex: array[1..255] of char;

  HexStr: string;

  TempDec: longint;

  alpha, bravo: integer;

  Place: longint;

  dumint: integer;

  added:  longint;

  TempAdded: longint;

begin

  HexStr := '';

  for alpha := 1 to length(Hex) do

    begin

      if not (Hex[alpha] in ['0'..'9','A'..'F','a'..'f']) then

        NewHex[alpha] := #0

      else

        NewHex[alpha] := Hex[alpha];

      if NewHex[alpha] <> #0 then

        HexStr := HexStr + NewHex[alpha];

    end;

  TempDec := 0;

  for alpha := length(HexStr) downto 1 do

    begin

      Place := 1;

      for bravo := (length(HexStr) - alpha +1) downto 2 do

        Place := Place * $10;

      case HexStr[alpha] of

        'A','a':  TempDec := TempDec + 10*Place;

        'B','b':  TempDec := TempDec + 11*Place;

        'C','c':  TempDec := TempDec + 12*Place;

        'D','d':  TempDec := TempDec + 13*Place;

        'E','e':  TempDec := TempDec + 14*Place;

        'F','f':  TempDec := TempDec + 15*Place;

        else

          begin

            val(HexStr[alpha], Added, DumInt);

            TempAdded := Added*Place;

            TempDec := TempDec + TempAdded;

          end;

      end; {case}

    end;

  HexToDec := TempDec;

end;



Procedure IOCumOK(var PrevAndNewStatus: boolean);

{***************************************************************************}

begin

  if IOResult <> 0 then

    PrevAndNewStatus := false;

end;



function IOError: byte;

{***************************************************************************}

var

   Code : byte;

   Msg  : string[50];

begin

   Code := ioresult;

   if Code = 0 then

      begin

        IOError := Code;

        exit

      end;

   case Code of

        2: Msg := 'no such filename in directory';

        3: Msg := 'no such directory path';

        4: Msg := 'too many files opened simultaneously';

        5: Msg := 'file access denied for intended operation';

        6: Msg := 'unrecognized file handle';

       12: Msg := 'attempted file access with wrong filemode';

       15: Msg := 'invalid drive number used in getdir';

       16: Msg := 'directory cannot be removed by rmdir';

       17: Msg := 'drives specified by rename cannot differ';

      100: Msg := 'attempted read past end of file';

      101: Msg := 'disk data area is full';

      102: Msg := 'cannot attempt I/O without assigning file';

      103: Msg := 'file not prepared with reset or rewrite';

      104: Msg := 'file not prepared to be read from';

      105: Msg := 'file not prepared to be written to';

      106: Msg := 'illegal numeric format in data';

      150: Msg := 'attempt to read write-protected disk';

      151: Msg := 'unit is unknown';

      152: Msg := 'disk drive is not ready';

      153: Msg := 'command is unknown';

      154: Msg := 'error in cyclical redundancy check';

      155: Msg := 'invalid drive request structure length';

      156: Msg := 'seek error on disk';

      157: Msg := 'media type is unknown';

      158: Msg := 'disk sector not found';

      159: Msg := 'printer is out of paper';

      160: Msg := 'write fault on I/O device';

      161: Msg := 'read fault on I/O device';

      162: Msg := 'general hardware failure'

   else

           Msg := 'unknown I/O error type'

   end;

   ErrSayL('** I/O error encountered.');

   ErrSayL('** error code = '+ Data.StrInt(Code));

   ErrSayL('** '+ Msg);

   IOError := Code

end;



Function IOGood: boolean;

{***************************************************************************}

var

  TestIO: integer;

begin

  TestIO := IOResult;

  if TestIO <> 0 then

    begin

      IOGood := false;

      writeln('Input/Output Error #',TestIO,'!');

      Keyb.Wait;

    end

  else

    IOGood := true;

end;



Function  LongIntStr(InStr: string): longint;

{***************************************************************************}

var

  IntVal: longint;

begin

  val(InStr, IntVal, DumInt);

  LongIntStr := IntVal;

end;



Procedure ParseInt(InStr:string; var Position: integer; var IntOut: integer);

{***************************************************************************}

{*  Changes Position to one after the last int value char.

{*  If not integer is found, changes Position to one > string length.

{*  Only gets the first int value it sees.

{*  Ignores leading space characters and non-numerical characters.

{*  Stops on first non-numerical character.

{*  Returns value of zero if no integer found.

{*  Gets absolute value of negative numbers (does not recognize "-").

{***************************************************************************}

var

  NumStr: string;

  LenInStr: integer;

  alpha: integer;

  NewPosition: integer;

begin

  NumStr := '';

  ;

  LenInStr := length(InStr);

  for alpha := Position to LenInStr do

    begin

      NewPosition := alpha + 1;

      if InStr[alpha] in ['0'..'9'] then

        NumStr := NumStr + InStr[alpha]

      else

        if NumStr <> '' then

          begin

            NewPosition := alpha;

            alpha := LenInStr;

          end;

    end;

  if NumStr <> '' then

    IntOut := ValInt(NumStr)

  else

    IntOut := 0;

  Position := NewPosition;

end;



Function Quad(X, Y: longint): byte;

{***************************************************************************}

begin

  if X < 0 then

    begin

      if Y < 0 then

        Quad := 3

      else

        Quad := 4;

    end

  else

    begin

      if Y < 0 then

        Quad := 2

      else

        Quad := 1;

    end;

end;



procedure Skip;

{***************************************************************************}

begin

  write(#7);

  writeln('An unwritten area of code has been skipped.');

end;



procedure SortSIT(var TextArray: MathUnitStringArrayType;

  LineCount, Position, Width: integer);

{***************************************************************************}

{* page 240 Turbo Pascal Programmer's Toolkit

{***************************************************************************}

var

  J,

  K: integer;

  ThisLine: string;

begin

  if LineCount <=1 then

    exit;

  for J := 2 to LineCount do

    begin

      ThisLine := TextArray[J];

      K := J - 1;

      while (Copy(ThisLine, Position, Width) <

        Copy(TextArray[K], Position, Width)) and (K > 0) do

          begin

            TextArray[K + 1] := TextArray[K];

            K := K - 1;

          end;

      TextArray[K + 1] := ThisLine;

    end;

end;



procedure Stats(NumArray: MathUnitRealArrayType; Count: integer;

  var Mean, Median, StanDev, MinValue, MaxValue: real);

{***************************************************************************}

{* Page 404 of Turbo Pascal Programmer's Toolkit by Rugg & Feldman

{* Limited by MathUnitConstant

{***************************************************************************}

var

  J,

  K,

  Mid: integer;

  Temp: real;

  ValueSum,

  SquareSum: real;

begin

  Mean := 0;

  Median := 0;

  StanDev := 0;

  MinValue := 0;

  MaxValue := 0;

  ;

  if Count < 1 then

    exit;

  for J := 2 to Count do

    begin

      Temp := NumArray[J];

      K := J- 1;

      while (Temp < NumArray[K]) and (K > 0) do

        begin

          NumArray[K+1] := NumArray[K];

          dec(K);

        end;

      NumArray[K+1] := Temp;

    end;

  ValueSum := 0.0;

  SquareSum := 0.0;

  for J := 1 to Count do

    begin

      ValueSum := ValueSum + NumArray[J];

      SquareSum := SquareSum + sqr(NumArray[J]);

    end;

  MinValue := NumArray[1];

  MaxValue := NumArray[Count];

  if odd(Count) then

    Median := NumArray[(Count+1) div 2]

  else

    begin

      Mid := Count div 2;

      Median := (NumArray[Mid] + NumArray[Mid+1])/2.0;

    end;

  Mean := ValueSum / Count;

  if Count = 1 then

    StanDev := 0.0

  else

    StanDev := sqrt((SquareSum - Count * Mean * Mean) / (Count - 1));

end;



function  ValChar(CharVal: char): integer;

{***************************************************************************}

var

  TempValue: integer;

begin

  Val(CharVal, TempValue, DumInt);

  ValChar := TempValue;

end;



function ValInt(StrVal: string): integer;

{***************************************************************************}

var

  TempValue: integer;

begin

  Val(StrVal, TempValue, DumInt);

  ValInt := TempValue;

end;



function ValReal(StrVal: string): real;

{***************************************************************************}

var

  TempValue: real;

begin

  Val(StrVal, TempValue, DumInt);

  ValReal := TempValue;

end;



function WildCardFormat(FormatStr: string; InStr: string): boolean;

{***************************************************************************}

var

  Position,

  bravo: integer;

  TempWildCardFormat: boolean;

  LeadStr,

  ExtStr: string;

  LenFormatStr,

  LenInStr: integer;

begin

  FormatStr := UpCaseStr(FormatStr);

  InStr := UpCaseStr(InStr);

  LenFormatStr := length(FormatStr);

  Position := 1;

  LeadStr := '';

  while (FormatStr[Position] <> '*') and (Position <= LenFormatStr)

    and (FormatStr[Position] <> '.') do

      begin

        LeadStr := LeadStr + FormatStr[Position];

        Inc(Position);

      end;

  ExtStr := '';

  repeat

    Inc(Position);

  until (FormatStr[Position] = '.') or (Position >= LenFormatStr);

  Inc(Position);

  while (FormatStr[Position] <> '*') and (Position <= LenFormatStr) do

    begin

      ExtStr := ExtStr + FormatStr[Position];

      Inc(Position);

    end;

  TempWildCardFormat := true;

  for Position := 1 to length(LeadStr) do

    begin

      if InStr[Position] <> LeadStr[Position] then

        TempWildCardFormat := false;

    end;

  LenInStr := length(InStr);

  Position := 0;

  repeat

    Inc(Position);

    if Position = 10 then

      TempWildCardFormat := false;

  until (InStr[Position] = '.') or (Position >= LenInStr);

  for bravo := 1 to length(ExtStr) do

    begin

      if InStr[Position+bravo] <> ExtStr[bravo] then

        TempWildCardFormat := false;

    end;

  WildCardFormat := TempWildCardFormat;

end;



{***************************************************************************}

{***************************************************************************}

{***************************************************************************}

begin

end.