home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB3.ZIP / INPUT2.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-07-04  |  10.0 KB  |  317 lines
  1. { * Input.Dem ram                    }
  2. { * by Don Ramsey                    }
  3. { * March-April 1984 *               }
  4.  
  5. program Input;
  6.  
  7. type
  8.   Astring   =   string[255];
  9.   ShortString = string[5];
  10.  
  11. var
  12.   R,C,L,Counter   : integer;
  13.   Ch              : Char;
  14.   Answer,Template : Astring;
  15.   Continue,Exit,
  16.    Inserton       : Boolean;
  17.  
  18.  
  19. procedure Msg(S: Astring; R1,C1: integer);
  20.   begin
  21.      gotoXY(C1,R1);  write(S);
  22.   end;
  23.  
  24. procedure InvVideo( S: Astring);
  25.   begin
  26.     textBackground(15);textcolor(0); write(S);
  27.     textBackground( 0);textcolor(7);
  28.   end;
  29.  
  30. procedure KeySet(S1,S2,S3 : Char);
  31.  var J : integer;
  32.  begin
  33.   if S3='I' then J:=128 else J:=0;
  34.   Case S1 of
  35.     'C': begin if S2='N' then  MemW[0000:1047]:= 96+J
  36.                else            MemW[0000:1047]:= 64+J;
  37.          end;
  38.     ' ': begin if S2='N' then  MemW[0000:1047]:= 32+J
  39.                else            MemW[0000:1047]:=  0+J;
  40.          end;
  41.   end; { Case }
  42.  end;
  43.  
  44. procedure Say_Cap_Num;
  45.  var  Value  : integer;
  46.  begin
  47.      Value := Mem[0000:1047];      { test for caps, numbers, & cursor cntrl }
  48.      gotoXY(65,25);
  49.      Case Value of
  50.        0   : begin write('               '); end;
  51.        32  : begin write('     '); InvVideo('NUM');
  52.                    write('       '); InsertOn:= false; end;
  53.        64  : begin InvVideo('CAPS'); write('           ');
  54.                    InsertOn:= false; end;
  55.        96  : begin InvVideo('CAPS'); write(' '); InvVideo('NUM');
  56.                    write('       '); InsertOn:=false; end;
  57.        128 : begin write('         ');InvVideo('Insert');InsertOn:=true; end;
  58.        160 : begin write('     '); InvVideo('NUM');write(' ');
  59.                    InvVideo('Insert'); InsertOn:=true; end;
  60.        192 : begin InvVideo('CAPS'); write('     ');
  61.                    InvVideo('Insert'); InsertOn:=true; end;
  62.        224 : begin InvVideo('CAPS'); write(' ');InvVideo('NUM'); write(' ');
  63.                    InvVideo('Insert'); InsertOn:= true; end;
  64.      end; { Case }
  65.   end;
  66.  
  67. procedure KeyIn(var Ch: Char);
  68. begin
  69.   read(kbd,Ch);
  70.   begin {see if IBM specific key pressed}
  71.     case Ch of
  72.       'H': Ch:=^E    ;  { up-arrow  }
  73.       'P': Ch:=^X    ;  { dn-arrow  }
  74.       'M': Ch:=^D    ;  { rt-arrow  }
  75.       'K': Ch:=^S    ;  { left-arr  }
  76.       'S': Ch:=#127  ;  { Del       }
  77.       'R': Ch:=^V    ;  { insert    }
  78.       'G': Ch:=^G    ;  { Home      }
  79.       'O': Ch:=^O    ;  { End       }
  80.       'I': Ch:=^R    ;  { Pg-Up     }
  81.       'Q': Ch:=#00   ;  { Pg-Dn     }
  82.     end;   {Case Ch}
  83.   end;   {IBM check}
  84. end;  {KeyIn}
  85.  
  86. procedure Input(Typ: Char          ;    { Type of input        }
  87.                 Default: AString   ;    { Default string       }
  88.                 Row,Col: integer   ;    { Where start line     }
  89.                 Mlen: integer      ;    { Max length           }
  90.                 UpperCase:Boolean) ;    { True if auto Upcase  }
  91. var
  92.   X,X1,J: integer;
  93.   InsertOn: boolean;
  94.   OkChars,Temp: set of Char;
  95.  
  96. {-------------------------- local procedures ---------------------------}
  97.   procedure GotoX;
  98.    begin
  99.      GotoXY(X+Col-1,Row);
  100.    end;
  101.  
  102.   procedure Ck_Cap_Num;
  103.    var Value,temp : integer;
  104.    begin
  105.     Value := Mem[0000:1047];      { test for caps, numbers, & cursor cntrl }
  106.     temp := value; Say_Cap_Num; gotoX;
  107.       repeat
  108.         Value := Mem[0000:1047];
  109.         if temp<>value then
  110.           begin temp:=Value; Say_Cap_Num; GotoX; end;
  111.       until mem[0000:1050]<>Mem[0000:1052];
  112.    end;
  113.  
  114.   procedure PosX;
  115.     begin
  116.       while copy(template,X,1)<>#176 do X:=X+1;
  117.       GotoX;
  118.     end;
  119.  
  120.   procedure Del_Ans;
  121.     begin
  122.       Answer:=''; X:=1; GotoX; write(template); PosX;
  123.     end;
  124. {------------------------ end local procedures ------------------------}
  125.  
  126. begin
  127.   Highvideo;
  128.   if Typ='A'then  OKChars:=[' '..'}']
  129.   else OKChars:=['0'..'9','+','-','.'];
  130.   Temp := OKChars;
  131.   Case Typ of
  132.     'A','N': begin  fillchar(template,255,#176);
  133.                     template := copy(template,1,Mlen);
  134.                     if Default = '' then Del_Ans;
  135.              end;
  136.     'F':      begin  Mlen := 0; Del_Ans;
  137.                      for J:=1 to length(template) do
  138.                        if template[J] = #176 then Mlen := Mlen+1;
  139.               end;
  140.     '$':      begin  Fillchar(template,255,#176);
  141.                      template:=copy(template,1,Mlen);
  142.                      X:=0;GotoX;write('$');
  143.                      if Default = '' then Del_Ans;
  144.               end;
  145.   end;
  146.  
  147.   if Typ = 'A' then if uppercase then KeySet('C',' ','I')
  148.                     else KeySet(' ',' ','I')
  149.   else KeySet(' ','N','I');
  150.   if Default<>'' then begin X:=1;GotoX;write(Default); end;
  151.   if Length(Answer)=1 then X:=2;
  152.   GotoX;
  153.   Answer := '';
  154.   repeat
  155.     Ck_Cap_Num; read(kbd,Ch);
  156.     if keypressed then KeyIn(Ch);
  157.     if (Answer= '') and (Ch <> #13) and (Ch<>^V) then Del_Ans;
  158.     case Ch of
  159.        ^[: begin Del_Ans end;     { ESC pressed   }
  160.  
  161.        ^D: begin { Move cursor right : rt-arr }
  162.              X:=X+1;
  163.              if (X>length(Answer)+1) or (X>Mlen) then X:=X-1;
  164.              GotoX;
  165.            end;
  166.  
  167.        ^S: begin { Move cursor left : left-arr }
  168.              if Typ='F' then Del_Ans
  169.              else begin
  170.                X:=X-1;
  171.                if X<1 then X:=1;
  172.                GotoX;
  173.              end;
  174.            end;
  175.        ^O: begin { Move cursor to end of line }
  176.               X:=Length(Answer)+1; if X>Mlen then X:=Mlen;
  177.               GotoX;
  178.            end;
  179.        ^G: begin { Move cursor to beginning of line }
  180.              X:=1;
  181.              GotoX;
  182.            end;
  183.        ^H: begin { Delete left char: BS }
  184.              if Typ='F' then Del_Ans
  185.              else
  186.                begin
  187.                  X:=X-1;
  188.                  if (Length(Answer)>0) and (X>0)  then
  189.                    begin
  190.                      Delete(Answer,X,1); GotoX;
  191.                      Write(copy(Answer,X,(Length(Answer)-X+1)),#176);
  192.                      GotoX;
  193.                      if X<1 then X:=1;
  194.                    end
  195.                  else X:=1;
  196.              end; { Typ <> 'F' }
  197.            end;
  198.        #127: begin { Delete }
  199.                Delete(Answer,X,1);
  200.                Write(copy(Answer,X,Length(Answer)-X+1),#176); GotoX;
  201.              end;
  202.  
  203.     else
  204.     begin   { non-IBM char }
  205.         if Ch in OkChars  then
  206.          begin
  207.           if InsertOn then begin
  208.            if length(Answer) < Mlen then  { OK to insert }
  209.            begin
  210.              insert(Ch,Answer,X);
  211.                Case Typ of
  212.                 'A','N','$' : write(copy(Answer,X,Length(Answer)-X+1));
  213.                 'F'         : Write(Ch);
  214.                end; {Case}
  215.            end;        { OK to insert }
  216.           end else     { end InsertOn }
  217.           begin
  218.              write(Ch);
  219.              if X>length(Answer) then Answer:=Answer+Ch
  220.              else Answer[X]:=Ch;
  221.           end;
  222.           if Length(Answer)+1<=Mlen then
  223.             begin
  224.               X:=X+1;
  225.               if (X > Length(Answer)) and (template[X]<>#176) then PosX;
  226.             end;
  227.          end { OkChars }
  228.         else OkChars:=[];  { Line too Long }
  229.         GotoX;
  230.         if Length(Answer)+1<=Mlen then
  231.            OkChars:= Temp                   { Line ok again }
  232.         else if (Ch<>^M) and (Typ<>'F') then
  233.            write(chr(7));                   { beep for last char. alert }
  234.     end;
  235.    end;
  236.   until CH=^M; Lowvideo; GotoX; write(Ch);
  237.  If Answer = '' then Answer:= default;
  238. { else Answer:=copy(answer,1,pos(^M,Answer)-1);}
  239.  if Typ <> 'F' then
  240.    begin
  241.      X:=length(Answer)+1; GotoX;
  242.      fillchar(Template,255,' ');
  243.      Template:=copy(template,1,Mlen-length(Answer));
  244.      write(Template);
  245.    end;
  246.  writeln(' ');
  247. end;          { end Input Procedure }
  248.  
  249. {procedure Input_Handler(IpCode: ShortString);}
  250.   { requires procedures Say_Prompt, Do_Validation, Get_Default }
  251.   {          global variables Do_last_entry: boolean, Escape: boolean,
  252.                Filvar: array of [1.25] of string[80] }
  253. { var Typ                  : Char;
  254.      Default              : Astring;
  255.      R,C,Mlen,I,Code,Count,
  256.      First_var,Last_var,
  257.      Filvar               : integer;
  258.      Def,Pmt,Vall         : string[2];
  259.  
  260.   procedure Get_Var;
  261.     begin
  262.       val(copy(P[count],1,2),C,Code); val(copy(P[count],3,2),R,Code);
  263.       Typ := copy(P[count],5,1); val(copy(P[count],6,3),Mlen,Code);
  264.       val(copy(P[count],9,2),Filvar,Code); Def:= copy(P[count],12,2);
  265.       Pmt:= copy(P[count],14,2); val(copy(P[count],16,2),Valid,Code);
  266.     end;
  267.  
  268.  begin
  269.    val(copy(IpCode,2,2),First_Var,Code);
  270.    val(copy(Ipcode,4,2),Last_var,Code);
  271.    IpType := copy(IpCode,1,1);
  272.    Case IpType of
  273.      'N' : for I:= 1 to 25 do Filvar[I] := '';
  274.      'C' :
  275.    end; { Case }
  276.    {count := First_var;
  277.    repeat
  278.      Get_Var;
  279.      if Filvar[count] = '' then Get_Default(Def)
  280.      else Default := Filvar[count];
  281.      Say_Prompt(Pmt);
  282.      Input(Typ,Default,R,C,Mlen,True); Filvar[count] := Answer;
  283.      Do_validation(vall);
  284.      if Do_last_entry then
  285.       begin
  286.         count:=count-1; Do_last_entry:=false;
  287.       end else count:=count+1;
  288.      if count < First_var then begin Escape:=true; Exit:=true; end
  289.      else if (count>Last_var) or (P[count]='') then Exit:=true;
  290.    until Exit = true;
  291.    Exit:=false;
  292.  end;}
  293.  
  294.  
  295. procedure InputDemo;
  296. begin
  297.  repeat
  298.    clrscr; LowVideo;
  299.    write('   Alphanumeric Input Routine');
  300.     Input('A','This is Default',1,40,20,true);writeln('Returned  : ',Answer);
  301.    Msg('Numeric Input Routine',5,3);
  302.      Input('N','',5,40,7,true);  ; writeln('Returned : ',Answer);
  303.    Msg('Formatted Input Routine',9,3);  template:='(░░░) ░░░-░░░░';
  304.      Input('F','',9,40,0,true);  ;  writeln('Returned : ',answer);
  305.    Msg('Formatted Input Routine',13,3);  template:='░░/░░/░░';
  306.      Input('F','',13,40,0,true);  ;  writeln('Returned : ',answer);
  307.    Msg('Dollar Input Routine',17,3);
  308.      Input('$','',17,40,7,true); writeln('Returned : ',answer); writeln(' ');
  309.    write('Press <E> to exit or Any Key to repeat Demo');
  310.    Read(kbd,Ch); Ch:=upcase(Ch);
  311.  until Ch='E';
  312. end;
  313.  
  314.  
  315. begin
  316.   ClrScr; Continue := true; Exit:=false;
  317.   InputDemo;
  318. end.