home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SAFELY.ZIP / SAFELY.PAS
Encoding:
Pascal/Delphi Source File  |  1987-02-07  |  10.3 KB  |  341 lines
  1. {$V-}
  2. program Test_Get_Data;
  3. type
  4.   string255 = string[255];
  5. var
  6.   filename : string[66];
  7.   NumStrin : string[20];
  8.   AlphaStr : string[60];
  9.   ExistStr : string[50];
  10.   GoingUp  : boolean;
  11.   (* ================================================================ *)
  12.  
  13.   type
  14.     charset = set of char;
  15.     regpack = record
  16.                 ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  17.               end;
  18.     Screen  = array[1..25] of array[1..80] of integer;
  19.     ScrPt   = ^screen;
  20.  
  21.   const
  22.     CR  = #13;
  23.     BS  = #8;
  24.     ESC = #27;
  25.     space  = #32;
  26.     Ctrl_BS  = #127;
  27.     numbers : charset = ['0'..'9'];
  28.     alpha : charset = ['A'..'Z','a'..'z'];
  29.     special : charset = [CR, BS, Esc, Space, Ctrl_BS];
  30.     fname : charset = ['^'..'~', '@'..'Z', '0'..':', '!', '#'..')', '\'];
  31.     BlueBlak : byte = $09;
  32.     WhitBlak : byte = $70;
  33.     BlakWhit : byte = $0F;
  34.     Atention : byte = $8F;
  35.   var
  36.     display : ScrPt;
  37.     regs    : regpack;
  38.     VidMode, NumCols : byte;
  39.     VidOffset, GlobVar : integer;
  40.     SaveFace, JustOne, Again : boolean;
  41.  
  42.   PROCEDURE CheckColor;
  43.     BEGIN
  44.       WITH regs DO
  45.         BEGIN
  46.           AX := 15 SHL 8;
  47.           Intr($10, regs);
  48.           vidmode := AX AND $00FF;
  49.         END;
  50.       IF vidmode = 7 THEN
  51.         BEGIN
  52.           Display := Ptr($B000, $0000);
  53.         END
  54.       ELSE
  55.         BEGIN
  56.           Display := Ptr($B800, $0000);
  57.         END;
  58.     END;
  59.  
  60.  
  61.  
  62.  
  63.   PROCEDURE MakeCurrent(XAtt : Byte);
  64.   BEGIN
  65.     TextColor((Xatt AND $F)+16*(XAtt SHR 7));
  66.     TextBackground((XAtt AND $70) SHR 4);
  67.   END;
  68.  
  69.   FUNCTION rep(CH : Char; NM : Byte) : string255;
  70.       {----------------------------------------------------------------}
  71.       { Output is a string of NM repetitions of character CH.  We do   }
  72.       { it with FillChar for speed, but we must check that we don't    }
  73.       { accidentally "spill out" of the variable's allocated space.    }
  74.       {----------------------------------------------------------------}
  75.     VAR
  76.       temp : string255;
  77.     BEGIN
  78.       IF NM > SizeOf(temp)-1 THEN NM := SizeOf(temp)-1;
  79.       FillChar(temp[1], NM, CH);
  80.       temp[0] := Chr(NM);
  81.       rep := temp;
  82.     END;
  83.  
  84.   procedure beep;
  85.   begin
  86.     write(#7); {replace}
  87.   end;
  88.  
  89.   PROCEDURE PutanAtt(Co, Ro, Att : Byte);
  90.       (* =============================================================== *)
  91.       (*  PURPOSE: Puts a character and attribute (coded as an integer)  *)
  92.       (*  at the POSition CO(lumn) RO(w) -- high byte is attribute, low  *)
  93.       (*  is character.  The INLINE code is used to prevent "snow"       *)
  94.       (*  created by reading and writing directly to the screen memory   *)
  95.       (*  in color mode.  Technically we are waiting for the Horizontal  *)
  96.       (*  Retrace.}                                                      *)
  97.       (* =============================================================== *)
  98.  
  99.     BEGIN
  100.       IF vidMode = 7 THEN
  101.         display^[ Ro][Co] := (display^[Ro][Co] AND $FF) OR (Att SHL 8)
  102.       ELSE
  103.         BEGIN
  104.           VidOffset := (ro-1)*160+(co-1)*2+1;
  105.           GlobVar := Att;
  106. {.F-}
  107.           INLINE(
  108.             $A1/GlobVar/       { MOV AX,GlobVar  } { Put the char/att in AX &}
  109.                                                    {  offset in BX BEFORE    }
  110.             $8B/$1E/VidOffset/ { MOV BX,VidOffset} {  messing with DS.       }
  111.             $1E/               { PUSH DS         } { Save the "real" DS.     }
  112.             $50/               { PUSH AX         } { Save the char/att       }
  113.             $B8/$B800/         { MOV AX,0B800h   } { Set the DS to B800 (the }
  114.             $8E/$D8/           { MOV DS,AX       } {   color vid memory      }
  115.             $BA/$DA/$03/       { MOV DX,03DA     } { Set DX to ColorVid port }
  116.      { XX001:}
  117.             $EC/               { IN      AL,DX   } { Loop 'til the port goes }
  118.             $A8/$01/           { TEST    AL,01   } {  to zero.               }
  119.             $75/$FB/           { JNZ XX001       }
  120.             $FA/               { CLI             } { NO INTERRUPTS NOW!      }
  121.      { XX002:}
  122.             $EC/               { IN      AL,DX   } { Loop 'til the port goes }
  123.             $A8/$01/           { TEST    AL,01   } {  high again.            }
  124.             $74/$FB/           { JZ  XX002       }
  125.             $58/               { POP AX          } { Get back the char/att & }
  126.             $88/$07/           { MOV [BX], AL    } {  poke it into memory at }
  127.                                                    {  offset BX              }
  128.             $1F/               { POP DS          } { Get back the "real" DS  }
  129.             $FB);              { STI             } { Re-enable interrupts    }
  130.         END;
  131. {.F+}
  132.     END;                      { procedure PutAnAtt(C,R,A:byte}
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.   PROCEDURE GetSafely(VAR getWhat : string255; X, Y, L : Byte; range : charset;
  140.                       ATT1,ATT2 : Byte; VAR Back : Boolean);
  141.     VAR
  142.       CH, DH : Char;
  143.     BEGIN
  144.       MakeCurrent(Att1);
  145.       Back := False;
  146.       GoToXY(X, Y);
  147.       Write(rep(' ', L));
  148.       GoToXY(X, Y);
  149.       Write(GetWhat);
  150.       REPEAT
  151.         REPEAT
  152.           REPEAT UNTIL KeyPressed;
  153.           DH := #0;
  154.           Read(Kbd, CH);
  155.           IF (ch = #27) AND KeyPressed THEN
  156.             Read(Kbd, DH);
  157.         UNTIL (CH IN (range+special)) OR (DH = 'H');
  158.         IF DH <> #0 THEN
  159.           BEGIN
  160.             CASE DH OF
  161.               'H' : BEGIN
  162.                       Back := True;
  163.                       CH := #13;
  164.                     END;
  165.               'P' : CH := #13;
  166.               ';' : ;  { Give 'em some help? }
  167.             END;
  168.           END
  169.         ELSE
  170.           BEGIN
  171.             CASE CH OF
  172.               #8 : IF Length(GetWhat) > 0 THEN
  173.                      BEGIN
  174.                        GoToXY(WhereX-1, Y);
  175.                        Write(' ');
  176.                        GoToXY(WhereX-1, Y);
  177.                        GetWhat[0] := Pred(GetWhat[0]);
  178.                      END;
  179.               #13 :;
  180.               #27 : BEGIN
  181.                       ClrScr;
  182.                       WriteLn('Program aborted by user');
  183.                       halt;
  184.                     END;
  185.               #127 : BEGIN
  186.                       GoToXY(X, Y);
  187.                       Write(rep(' ', Length(GetWhat)));
  188.                       GoToXY(X, Y);
  189.                       GetWhat := '';
  190.                     END;
  191.             ELSE
  192.               IF Length(GetWhat) < L THEN
  193.                 BEGIN
  194.                   GetWhat := GetWhat+CH;
  195.                   Write(CH);
  196.                 END
  197.               ELSE beep;
  198.             END;
  199.           END;
  200.       UNTIL (CH = #13);
  201.       while GetWhat[length(GetWhat)] = ' ' DO
  202.         IF GetWhat[0] > #0 THEN
  203.           GetWhat[0] := pred(GetWhat[0]);
  204.       MakeCurrent(Att2);
  205.       GoToXY(X, Y);
  206.       Write(rep(' ', L));
  207.       GoToXY(X, Y);
  208.       Write(GetWhat);
  209.     END;
  210.  
  211.  
  212.  
  213.  
  214.  
  215.   PROCEDURE Show_Pick(Y, X1, X2, AT, BK : Byte; cherce : Boolean);
  216.     BEGIN
  217.       IF Cherce THEN
  218.         BEGIN
  219.           PutAnAtt(X1, Y, AT);
  220.           PutAnAtt(X2, Y, BK);
  221.         END
  222.       ELSE
  223.         BEGIN
  224.           PutAnAtt(X2, Y, AT);
  225.           PutAnAtt(X1, Y, BK);
  226.         END;
  227.     END;
  228.  
  229.  
  230.   PROCEDURE Get_Pick(Y, X1, X2, AT, BK : Byte; VAR cherce, Back : Boolean);
  231.     VAR
  232.       CH, DH : Char;
  233.     BEGIN
  234.       Back := False;
  235.       GoToXY(X1, Y);
  236.       Show_Pick(Y, X1, X2, atention, BK, cherce);
  237.  
  238.       REPEAT
  239.         REPEAT UNTIL KeyPressed;
  240.         DH := #0;
  241.         Read(Kbd, CH);
  242.         IF (CH = #27) THEN
  243.           BEGIN
  244.             if KeyPressed THEN
  245.               BEGIN
  246.                 Read(Kbd, DH);
  247.                 CASE DH OF
  248.                   ';' : ; {Give 'em some help?}
  249.                   'H' : BEGIN
  250.                           Back := True;
  251.                           CH := #13;
  252.                         END;
  253.                   'K' : cherce := True;
  254.                   'M' : cherce := False;
  255.                   'P' : CH := #13;
  256.                 END;
  257.               END
  258.             ELSE
  259.               BEGIN
  260.                 ClrScr;
  261.                 WriteLn('Program aborted by user');
  262.                 halt;
  263.               END;
  264.           END
  265.         ELSE
  266.           IF CH = #9 THEN cherce := NOT cherce;
  267.         Show_Pick(Y, X1, X2, Atention, BK, cherce);
  268.       UNTIL CH = #13;
  269.       SHow_Pick(Y, X1, X2, AT, BK, cherce);
  270.     END;
  271.   (* ================================================================ *)
  272.  
  273.   procedure Get_Data;
  274.   label
  275.     1,2,3,4,5,6 ;
  276.   begin
  277. 1:  GetSafely(filename,11,5,66,fname,BlueBlak,WhitBlak,goingUp);
  278.     IF goingUp THEN goto 1;
  279. 2:  GetSafely(NumStrin,11,6,20,numbers,BlueBlak,WhitBlak,goingUp);
  280.     IF goingUp THEN goto 1;
  281. 3:  GetSafely(AlphaStr,13,7,60,alpha,BlueBlak,WhitBlak,goingUp);
  282.     IF goingUp THEN goto 2;
  283. 4:  GetSafely(ExistStr,18,8,50,alpha+numbers+['!',','],BlueBlak,WhitBlak,goingUp);
  284.     IF goingUp THEN goto 3;
  285. 5:  Get_Pick(10,23,25,BlueBlak,WhitBlak,SaveFace,goingUp);
  286.     IF goingUp THEN goto 4;
  287. 6:  Get_Pick(11,23,28,BlueBlak,WhitBlak,JustOne,goingUp);
  288.     IF goingUp THEN goto 5;
  289.   end;
  290.  
  291.   procedure Show_Data;
  292.   begin
  293.     GotoXY(11,5); write(filename);
  294.     GotoXY(11,6); write(numStrin);
  295.     GotoXY(13,7); write(AlphaStr);
  296.     GotoXY(18,8); Write(ExistStr);
  297.     Show_Pick(10,23,25,BlueBlak,WhitBlak,SaveFace);
  298.     Show_Pick(11,23,28,BlueBlak,WhitBlak,JustOne);
  299.   end;
  300.  
  301.   procedure Initialize;
  302.   begin
  303.     filename := '';
  304.     NumStrin := '';
  305.     AlphaStr := '';
  306.     ExistStr := 'Three Cheers! 1, 2, 3!!!';
  307.     SaveFace := false;
  308.     JustOne := true;
  309.     Again   := true;
  310.   end;
  311.  
  312.  
  313. begin
  314.   Initialize;
  315.   CheckColor;
  316.   MakeCurrent(WhitBlak);
  317.   While again DO
  318.     begin
  319.       ClrScr;
  320.       WriteLn('     DATA ENTRY DEMO ');
  321.       GotoXY(1,5);
  322.       Write('FILENAME: ');
  323.       GotoXY(1,6);
  324.       Write('A NUMBER: ');
  325.       GotoXY(1,7);
  326.       write('ALPHA ONLY: ');
  327.       GotoXY(1,8);
  328.       Write('EXISTING STRING: ');
  329.       GotoXY(11,10);
  330.       Write('SAVE FACE? <Y/N> ');
  331.       GotoXY(11,11);
  332.       write('HOW MANY?  <1 or 2> ');
  333.       Show_Data;
  334.       Get_Data;
  335.       GotoXY(30,15);
  336.       Write('AGAIN? (Y/N)');
  337.       Show_Pick(15,38,40,BlueBlak,WhitBlak,again);
  338.       Get_Pick(15,38,40,BlueBlak,WhitBlak,again,goingUp);
  339.     end;
  340.  
  341. end.