CD Actual 15/CDACTUAL15.iso/cdactual/program/pascal/SCNDSIGN.ZIP/GENERAL.INC

Text File | 1987-03-29 | 9.4 KB | 355 lines

(*This is the General.inc file which will be included with the files
  generated by the ScnDsign program*)
Type
  AnyString = String[30];
  FileName = String[14];
  TotScn = Array[1..25,1..80,1..2] of byte;
Var
  AttributeSeg       : integer;
  AttributeOfs       : integer;
  ScnFile            : file of byte;
  Ch1,Ch2,ch         : char;
  Row,Col,count,max  : integer;
  ScnImage           : TotScn absolute $B000:0000;

{----------------------------------------------------------}

Procedure InitMonoSPFX;
{Find the location of the attribute byte by changing the video
 attribute, then checking for differences}
{My thanks to Dr. R. L. Wulffson of Santa Ana, Calif. for this procedure}
Const
   MaxOffset = $0900;

Var
   A         : integer;
   Found     : boolean;
   Attribute : byte;

{----------------------------------------------}

Procedure FindAttribute;

Begin
  Repeat
   LowVideo;
   Attribute := Mem[AttributeSeg:AttributeOfs];
   NormVideo;
   If Mem[AttributeSeg:AttributeOfs] <> Attribute
     then Found := True
     else AttributeOfs := Succ(AttributeOfs)
  until Found or (AttributeOfs > MaxOffset);
end;

{----------------------------------------------}

Begin {InitMonoSPFX}
   Found := false;
   AttributeSeg := DSeg;
   AttributeOfs := 0;
   FindAttribute;
   If Not Found
     Then
       Begin
         AttributeSeg := CSeg;
         AttributeOfs := 0;
         FindAttribute;
       end;
end; {InitMonoSPFX}

{-----------------------------------------------}

Procedure Reverse;

Begin
   Mem[AttributeSeg:AttributeOfs] :=  $70;
end;

{-------------------------------}

Procedure ReverseBlink;

Begin
   Mem[AttributeSeg:AttributeOfs] :=  $F0;
end;

{-------------------------------}

Procedure Blink;

Begin
   Mem[AttributeSeg:AttributeOfs] := $87;
end;

{----------------------------------}

Procedure UnBlink;

Begin
   Mem[AttributeSeg:AttributeOfs] := Mem[AttributeSeg:AttributeOfs] and $7F;
end;

{----------------------------------}

Procedure UnderLine;

Begin
   Mem[AttributeSeg:AttributeOfs] := Mem[AttributeSeg:AttributeOfs] and $88;
   Mem[AttributeSeg:AttributeOfs] := Mem[AttributeSeg:AttributeOfs] or $01;
end;

{----------------------------------}

Procedure HiInt;

Begin
   Mem[AttributeSeg:AttributeOfs] := $0F;
end;

{-----------------------------------}

Procedure LoInt;

Begin
   Mem[AttributeSeg:AttributeOfs] := Mem[AttributeSeg:AttributeOfs] and $F7;
end;

{------------------------------------}

Procedure Normal;

Begin
   Mem[AttributeSeg:AttributeOfs] :=  $07;
end;

{----------------------------------------------------------}

Procedure IncrementScnPos;
begin
  Col := Col + 1;
  if Col > 80 then
    begin
      Row := Row +1;
      Col := 1;
    end;
end;

{------------------------------------------------------------------}

Procedure ReadScnFile(ScnName:FileName;var WhereToPutScn:TotScn);
Var
   Attr,bt,ByteValue,NextChar : byte;
Begin
   Attr := 7;{normal attribute}
   Row:= 1;Col := 1;{Start writing to screen at upper
                                 left corner}

   Assign(ScnFile,ScnName);
   Reset(ScnFile);
   While not eof(ScnFile) do

    begin
      read(ScnFile,bt);
      case bt of
         $FF  :begin
                 Read(ScnFile,Attr);
               end;
         $00  :begin
                 Read(ScnFile,ByteValue);{number of times next ASC11 value
                                           is to be repeated}
                 Read(ScnFile,NextChar);
                 for count := 1 to ByteValue do
                   begin
                     WhereToPutScn[Row,Col,1] := NextChar;
                     WhereToPutScn[Row,Col,2] := Attr;
                     IncrementScnPos;
                   end;
               end
               else begin
                      WhereToPutScn[Row,Col,1] := bt;
                      WhereToPutScn[Row,Col,2] := Attr;
                      IncrementScnPos;
                    end;
      end;
    end;
   Close(ScnFile);
end;

{------------------------------------------------------------------}

Procedure String_Entry(var Str_In:AnyString; Max:Integer);

Const
   StringSet : set of char = [#8,#13,#27,#32..#126];

Var
   Pos                                    : integer;
   Answ                                   : AnyString;

Begin

     Ch1 := ' ';
     Ch2 := ' ';
     Answ:='';
     col:=WhereX;row:=WhereY;
     Pos:=0;
     Reverse;
     Repeat
        Repeat read(kbd,Ch1) until Ch1 in StringSet;
        if Ch1=#27  then read(kbd,Ch2);
           {check to see if it is two character code}
           {if so then read the second character}
        case Ch1 of
           ^H:if pos>0 then
                   begin
                     write(^H,' ',^H);
                     delete(Answ,pos,1);
                     pos:=pos-1;
                     Str_In := Answ;
                   end;
            #32..#126:begin
                       if pos=0 then
                          begin
                            for count:=1 to max do write(chr(32));
                            for count:=1 to max do write(^H);
                          end;
                       if pos<max then
                          begin
                            pos:=pos+1;
                            write(Ch1);
                            Answ:=Answ+Ch1;
                            Str_In := Answ;
                          end
                          else write(^G);
                     end;
        end;
     until (Ch1 = ^M);
     GotoXY(col,row);
     Normal;
     For count:= 1 to Max do write(chr(32));
     GotoXY(col,row);
     Write(Str_In:Max);
end;

{-------------------------------------------------------------------------}

Procedure Integer_Entry(var Int_In:Integer;Max:Integer);

Const
   IntSet    : set of char = [#8,#13,#27,#48..#57];

Var
   Pos,code                               : integer;
   Answ                                   : AnyString;

Begin

     Ch1 := ' ';
     Ch2 := ' ';
     Answ:='';
     col:=WhereX;row:=WhereY;
     Pos:=0;
     Reverse;
     Repeat
        Repeat read(kbd,Ch1) until Ch1 in IntSet;
        if Ch1=#27  then read(kbd,Ch2);
           {check to see if it is two character code}
           {if so then read the second character}
        case Ch1 of
           ^H:if pos>0 then
                   begin
                     write(^H,' ',^H);
                     delete(Answ,pos,1);
                     pos:=pos-1;
                     Val(Answ,Int_In,code);
                   end;
            #32..#126:begin
                       if pos=0 then
                          begin
                            for count:=1 to max do write(chr(32));
                            for count:=1 to max do write(^H);
                          end;
                       if pos<max then
                          begin
                            pos:=pos+1;
                            write(Ch1);
                            Answ:=Answ+Ch1;
                            Val(Answ,Int_In,code);
                          end
                          else write(^G);
                     end;
        end;
     until (Ch1 = ^M);
     GotoXY(col,row);
     Normal;
     For count:= 1 to max do write(chr(32));
     GotoXY(col,row);
     Write(Int_In:max);
end;

{-------------------------------------------------------------------------}

Procedure Real_Entry(var Rl_In:Real;Max:Integer;NumDec:Integer);

Const
   RealSet   : set of char = [#8,#13,#27,#46,#48..#57];
Var
   Pos,code,kount                         : integer;
   Answ                                   : AnyString;

Begin

     Ch1 := ' ';
     Ch2 := ' ';
     Answ:='';
     col:=WhereX;row:=WhereY;
     Pos:=0;
     Reverse;
     Repeat
        Repeat read(kbd,Ch1) until Ch1 in RealSet;
        if Ch1=#27  then read(kbd,Ch2);
           {check to see if it is two character code}
           {if so then read the second character}
        case Ch1 of
           ^H:if pos>0 then
                   begin
                     write(^H,' ',^H);
                     delete(Answ,pos,1);
                     pos:=pos-1;
                     Val(Answ,Rl_In,code);
                   end;
            #32..#126:begin
                       if pos=0 then
                          begin
                            for kount:=1 to max do write(chr(32));
                            for kount:=1 to max do write(^H);
                          end;
                       if pos<max then
                          begin
                            pos:=pos+1;
                            write(Ch1);
                            Answ:=Answ+Ch1;
                            Val(Answ,Rl_In,code);
                          end
                          else write(^G);
                     end;
        end;
     until (Ch1 = ^M);
     GotoXY(col,row);
     Normal;
     For kount:= 1 to max do write(chr(32));
     GotoXY(col,row);
     Write(Rl_In:max:NumDec);
end;

{------------------------------------------------------------------------}

Procedure Bol_Entry(var Bol_In:boolean);
Begin
  Repeat read(kbd,ch) until UpCase(ch) in['Y','N'];
  if UpCase(ch) = 'Y' then Bol_In := true
  else Bol_In := false;
  if Bol_In = true then Write('Y') else Write('N');
end;

{-------------------------------------------------------------------------}