Power-Programmierung/CD1.mdf/pascal/library/dos/mailpro/getforu.pas

Pascal/Delphi Source File | 1988-08-23 | 11.8 KB | 456 lines

unit GetForU;

interface
uses Crt, BeeU, GetKeU, FastWr, MergeStU, LPaU, SetAttU, StriU;
type SetType = set of char;
function GetForm( X,
                  Y,
                  Lngth:             integer;
                  Form,
                  Default:           string;
                  var Control:       integer;
                  var AllowInput:    boolean;
                  Attr:              byte;
                  Allowable:         SetType):        string;

implementation

function GetForm;
var ReturnControl,
    RepeatLoop,
    EndStart,
    FunctionChar:           boolean;
    NewAttr:            byte;
    TempArr:              array [1..256] of char;
    OCh,
    Point,
    Temp,
    I,
    J,
    LastChar:              integer;
    FG,
    BG:                byte;
    Show,
    Ch:                char;

  procedure ClearBuf;
  begin
  Beep(1);
  while KeyPressed do GetKey(Ch,FunctionChar);
  end;


  procedure Lower(var X: integer);
  var Continue:       boolean;
  begin
  Continue := true;
  dec(X);
  while Continue do
    begin
    if X < 1 then
       begin
       X := 0;   (* just to make sure it's not too low *)
       Continue := false;
       end
      else
       begin
       if Form[X] <> ' ' then
          dec(X)
         else
          Continue := false;
       end;
    end;
  end;


  procedure Raise(var X: integer);
  var Continue:       boolean;
  begin
  Continue := true;
  inc(X);
  while Continue do
    begin
    if X > Lngth then
       begin
       X := Lngth;   (* just to make sure it's not too high *)
       Continue := false;
       end
      else
       begin
       if Form[X] <> ' ' then
          inc(X)
         else
          Continue := false;
       end;
    end;
  end;

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

  procedure Get_Form;
  var I:    integer;

    procedure DeleteChar;
    var J,
        I:      integer;
    begin
    if (Point > LastChar) or (LastChar < 1) then  (* Point > LastChar ??? *)
       ClearBuf
      else
       begin        (* Point <= LastChar  or  LastChar < 1 *)
       if LastChar > Point then
          begin
          I := Point;
          Raise(I);
          J := I;
          Raise(J);
          while I < LastChar do
              begin
              TempArr[I] := TempArr[J];
              TempArr[J] := ' ';
              FastWrite( TempArr[I], Y, X + I - 1, NewAttr);
              FastWrite( TempArr[J], Y, X + J - 1, NewAttr);
              Raise(I);
              Raise(J);
              end;
          TempArr[LastChar] := ' ';
          FastWrite( TempArr[LastChar], Y, X + LastChar - 1, NewAttr);
          Lower(LastChar);
          end
         else
          begin
          ClearBuf;
          end;
       end;
    end;


    procedure InsertChar;
    var J,
        NextJ:              integer;
    begin
    if Point < Lngth then
       begin
       Raise(Point);
       for J := LastChar downto Point do
           begin
           NextJ := J;
           Raise(NextJ);
           TempArr[NextJ] := TempArr[J];
           FastWrite( TempArr[NextJ], Y, X + J, NewAttr);
                 (* rem X+(J+1)-1  =  X+J *)
           end;
       TempArr[Point] := ' ';
       FastWrite( TempArr[Point], Y, X + Point - 1, NewAttr);
       Lower(Point);
       Raise(LastChar);
       end
      else
       begin
       ClearBuf;
       end;
    end;


    procedure BackSpace;
    var J,
        I:               integer;
    begin
    if (Point < 1) then
       ClearBuf
      else
       begin
       Lower(Point);
       DeleteChar;
       end;
    end;


    procedure ChopOff;
    var J:    integer;
    begin
    for J := Point + 1 to LastChar do
        begin
        if Form[J] = ' ' then TempArr[J] := ' ';
        FastWrite( TempArr[J], Y, X + J - 1, NewAttr);
        end;
    LastChar := Point;
    end;


    procedure AddChar;
    var Chop:              boolean;
    begin
    if (Point < Lngth) and (Ch in Allowable) then
       begin
       if Point = 0 then Chop := true else Chop := false;
       Raise(Point);
       TempArr[Point] := Ch;
       FastWrite( TempArr[Point], Y, X + Point - 1, NewAttr);
       if Point > LastChar then LastChar := Point;
       if Chop then ChopOff;
       end
      else
       ClearBuf;
    end;


  begin
  while RepeatLoop do
      begin
      if (Point < Lngth) then
         begin
         Temp := Point;
         Raise(Temp);
         Show := TempArr[Temp];
         if Show = ' ' then Show := '_';
         FastWrite( Show, Y, Temp+X-1, (Attr or $0080));
         end;
      Ch := ReturnKey(FunctionChar);
      OCh := ord(Ch);
      if (Point < Lngth) then
         begin
         Temp := Point;
         Raise(Temp);
         Show := TempArr[Temp];
         FastWrite( Show, Y, Temp+X-1, NewAttr);
         end;
      if FunctionChar then
         begin
         case OCh of
           59..68: begin
               if ReturnControl then
                  begin
                  Control := -OCh;
                  RepeatLoop := false;
                  end
                 else
                  ClearBuf;
               end;
           73,81: begin
               if ReturnControl then
                  begin
                  Control := -OCh;
                  RepeatLoop := false;
                  end
                 else
                  ClearBuf;
               end;
           71: begin                                       (* home *)
               Point := 0;
               end;
           72: begin
               Control := -300;
               RepeatLoop := false;
               end;
           75: begin
               J := Point;
               Lower(J);
               if J < 0 then ClearBuf else Point := J;
               end;
           77: begin
               J := Point;
               Raise(J);
               if J >= LastChar then ClearBuf else Point := J;  (* = ??? *)
               end;
           79: begin
               while Point < LastChar do Raise(Point);
               end;
           80: begin
               Control := 300;
               RepeatLoop := false;
               end;
           82: begin                                 (* insert *)
               InsertChar;
               end;
           83: begin                                 (* delete *)
               DeleteChar;
               end;
           117:begin
               ChopOff;
               end;
           30: begin       (* the following Allowable for alt-letter combo's *)
               Control := 300 + 1;
               RepeatLoop := false;
               end;
           48: begin
               Control := 300 + 2;
               RepeatLoop := false;
               end;
           46: begin
               Control := 300 + 3;
               RepeatLoop := false;
               end;
           32: begin
               Control := 300 + 4;
               RepeatLoop := false;
               end;
           18: begin
               Control := 300 + 5;
               RepeatLoop := false;
               end;
           33: begin
               Control := 300 + 6;
               RepeatLoop := false;
               end;
           34: begin
               Control := 300 + 7;
               RepeatLoop := false;
               end;
           35: begin
               Control := 300 + 8;
               RepeatLoop := false;
               end;
           23: begin
               Control := 300 + 9;
               RepeatLoop := false;
               end;
           36: begin
               Control := 300 + 10;
               RepeatLoop := false;
               end;
           37: begin
               Control := 300 + 11;
               RepeatLoop := false;
               end;
           38: begin
               Control := 300 + 12;
               RepeatLoop := false;
               end;
           50: begin
               Control := 300 + 13;
               RepeatLoop := false;
               end;
           49: begin
               Control := 300 + 14;
               RepeatLoop := false;
               end;
           24: begin
               Control := 300 + 15;
               RepeatLoop := false;
               end;
           25: begin
               Control := 300 + 16;
               RepeatLoop := false;
               end;
           16: begin
               Control := 300 + 17;
               RepeatLoop := false;
               end;
           19: begin
               Control := 300 + 18;
               RepeatLoop := false;
               end;
           31: begin
               Control := 300 + 19;
               RepeatLoop := false;
               end;
           20: begin
               Control := 300 + 20;
               RepeatLoop := false;
               end;
           22: begin
               Control := 300 + 21;
               RepeatLoop := false;
               end;
           47: begin
               Control := 300 + 22;
               RepeatLoop := false;
               end;
           17: begin
               Control := 300 + 23;
               RepeatLoop := false;
               end;
           45: begin
               Control := 300 + 24;
               RepeatLoop := false;
               end;
           21: begin
               Control := 300 + 25;
               RepeatLoop := false;
               end;
           44: begin
               Control := 300 + 26;
               RepeatLoop := false;
               end;
           end;  (* case *)
         end
        else
         begin
         case OCh of
           32..126:
               begin
               AddChar;
               end;
           8:  begin                      (* back space *)
               BackSpace;
               end;
           13: begin
               if LastChar > 0 then
                  begin
                  Default := '';
                  for I := LastChar+1 to Lngth+1 do TempArr[I] := ' ';
                  for I := 1 to Lngth do
                      begin
                      if TempArr[I] = ' ' then
                         if Form[I] <> ' ' then
                            TempArr[I] := Form[I];
                      Default := Default + TempArr[I];
                      end;
                  (*   lpad ???  Default := strip(Default); *)
                  end;
               RepeatLoop := false;
               end;
           27: begin
               RepeatLoop := false;
               Control := -27;
               end;
           end;    (* case *)
         end;      (* if FunctionChar then .. else .. *)
      end;
  end;


begin
if Lngth < 0 then
   begin
   EndStart := true;
   Lngth := - Lngth;
   end
  else
   EndStart := false;
I := ord(Form[0]);
if I <> Lngth then Lngth := I;
Point := 0;
Form := Form + '  ';
fillchar(TempArr,256,' ');
Default := MergeStr(Form,Default,Lngth);
for I := 1 to Lngth do TempArr[I] := Default[I];
LastChar := Lngth;
while (TempArr[LastChar] = ' ') and (LastChar > 1) do dec(LastChar);
if (TempArr[1] = ' ') and (LastChar = 1) then dec(LastChar);
if EndStart then Point := LastChar;
Raise(LastChar);
gotoxy(X,Y);
if AllowInput and (Control > -2) then
    begin
    BG := Attr and $0007;
    FG := (Attr and $0070) div 16;
    NewAttr := SetAttr(false, false, FG, BG);
    if Control > -1 then ReturnControl := true else ReturnControl := false;
    FastWrite( LPad(Default, Lngth), Y, X, NewAttr);
    RepeatLoop := true;
    Get_Form;
    FastWrite( lpad(Default, Lngth), Y, X, Attr);
    Default := LPad(Default, Lngth);
    end
   else
    begin
    (*  if (not AllowInput) and (Control <> -27) then  *)
    FastWrite( LPad(Default, Lngth), Y, X, Attr);
    end;
GetForm := Strip(Default);
end;

end.