home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / TCSEL002 / KEYINPUT.PAS < prev    next >
Pascal/Delphi Source File  |  1992-10-20  |  17KB  |  525 lines
  1. {$IFDEF Ver60}
  2. {$A+,B-,D-,E+,F-,I-,L-,N+,O-,R-,S-,V-,X+}
  3. {$ELSE}
  4. {$A+,B-,D-,E+,F-,I-,L-,N+,O-,R-,S-,V-}
  5. {$ENDIF}
  6.  
  7. unit keyinput;
  8.  
  9. { Author Trevor J Carlsen - released into the public domain 1991         }
  10. {        PO Box 568                                                      }
  11. {        Port Hedland                                                    }
  12. {        Western Australia 6721                                          }
  13. {        Voice +61 91 73 2026  Data +61 91 73 2930                       }
  14. {        FidoNet 3:690/644                                               }
  15.  
  16. { This unit is designed to permit controlled input into a pre-determined }
  17. { field size.  It also provides some handy associated procedures and     }
  18. { functions and constants.                                               }
  19.  
  20. interface
  21.  
  22. uses crt;
  23.  
  24. const  { These are the values returned by the function ReadWord }
  25.   F1  = $3b00; ShF1  = $5400; CtrlF1  = $5e00; AltF1  = $6800;
  26.   F2  = $3c00; ShF2  = $5500; CtrlF2  = $5f00; AltF2  = $6900;
  27.   F3  = $3d00; ShF3  = $5600; CtrlF3  = $6000; AltF3  = $6a00;
  28.   F4  = $3e00; ShF4  = $5700; CtrlF4  = $6100; AltF4  = $6b00;
  29.   F5  = $3f00; ShF5  = $5800; CtrlF5  = $6200; AltF5  = $6c00;
  30.   F6  = $4000; ShF6  = $5900; CtrlF6  = $6300; AltF6  = $6d00;
  31.   F7  = $4100; ShF7  = $5a00; CtrlF7  = $6400; AltF7  = $6e00;
  32.   F8  = $4200; ShF8  = $5b00; CtrlF8  = $6500; AltF8  = $6f00;
  33.   F9  = $4300; ShF9  = $5c00; CtrlF9  = $6600; AltF9  = $7000;
  34.   F10 = $4400; ShF10 = $5d00; CtrlF10 = $6700; AltF10 = $7100;
  35.  
  36.   BackSpace    = $0e08; CtrlBackSpace = $0e7f;
  37.   Tab          = $0f09; Tab_left      = $0f00;
  38.   Enter        = $1c0d; CtrlEnter     = $1c0a;
  39.   InsertKey    = $5200; DeleteKey     = $5300;
  40.   Home         = $4700; CtrlHome      = $7700;
  41.   Endkey       = $4f00; CtrlEnd       = $7500;
  42.   PageUp       = $4900; CtrlPageUp    = $8400;
  43.   PageDn       = $5100; CtrlPageDown  = $7600;
  44.   UpArrow      = $4800; DownArrow     = $5000;
  45.   LeftArrow    = $4b00; CtrlLeftArrow = $7300;
  46.   RightArrow   = $4d00; CtrlRightArrow= $7400;
  47.   Escape       = $011b;
  48.  
  49. type
  50.   Toggles      = (RightShift, LeftShift, Ctrl, Alt,
  51.                   ScrollLock, NumLock, CapsLock, Insert);
  52.   shiftstatus  = set of Toggles;
  53.   CursorState  = (Off, On, Normal, Block);
  54.   ToggleType   = Off..On;
  55.   InputType    = (Numeric, AlphaNumeric);
  56.  
  57. const
  58.   ReverseColour: boolean = false;{ The input field will be the default attr }
  59.                                  { in reverse                               }
  60.   InsertOn     : boolean = false;
  61.   ExitKey      : word    = 0;
  62.   DecimalPts   : byte    = 2;
  63. var
  64.   FieldColour : byte;
  65.   KbdStatus   : shiftstatus absolute $40:$17;
  66.   ValidKeys: array[InputType] of set of char;
  67.  
  68. procedure Beep(freq,len: word);
  69. function  CursorStatus: CursorState;
  70. procedure Cursor(Action: CursorState);
  71. procedure NormalCursor;
  72. procedure HiddenCursor;
  73. procedure BlockCursor;
  74. procedure ClearKbdBuffer;
  75. function KeyWord: word;
  76. function  ReadStr(width   : word;
  77.                   prompt  : string;
  78.                   s       : string;
  79.                   _Input  : InputType) : string;
  80. function  ReadInteger(p: string; min,max,I: longint): longint;
  81. function  ReadReal(p: string; min,max: longint; R: real): real;
  82. function ReadExtended(p: string; min,max: longint; R: Extended): Extended;
  83. procedure SetLock(TKey: Toggles; state: ToggleType);
  84. function  LeftShiftPressed: boolean;
  85. function  RightShiftPressed: boolean;
  86. function  AltPressed: boolean;
  87. function  CtrlPressed: boolean;
  88.  
  89. implementation
  90.  
  91. var
  92.   OriginalStatus : CursorState;
  93.   OldExitProc    : pointer;
  94.  
  95.  
  96. procedure Beep(freq,len : word);
  97.   { Beeps the speaker for len thousandths of a second }
  98.   begin
  99.     Sound(freq);
  100.     delay(len);
  101.     NoSound;
  102.   end;  { Beep }
  103.  
  104. function CursorStatus: CursorState;
  105.   { Check the current status of the cursor and assigns it a value }
  106.   var
  107.     bottom: byte absolute $40:$60;
  108.     top   : byte absolute $40:$61;
  109.     x     : shortint;
  110.   begin
  111.     x     := bottom - top;
  112.     if x < 0 then
  113.       CursorStatus := Off
  114.     else if x = 1 then
  115.       CursorStatus := Normal
  116.     else if x > 1 then
  117.       CursorStatus := Block
  118.     else CursorStatus := On;
  119.   end;  { CursorStatus }
  120.  
  121. procedure Cursor(Action : CursorState);
  122.   { Turn the cursor on/off or make it a block}
  123.  
  124.   procedure ChangeCursor(top,bottom : byte);
  125.     begin
  126.       asm
  127.         mov ah, $01
  128.         mov ch, top
  129.         mov cl, bottom
  130.         int $10
  131.       end;
  132.     end; { ChangeCursor}
  133.  
  134. begin
  135.   case action of
  136.     On     : if LastMode = Mono then
  137.                ChangeCursor($0C,$0C)
  138.              else
  139.                ChangeCursor($06,$06);
  140.     Normal : if LastMode = Mono then
  141.                ChangeCursor($0B,$0C)
  142.              else
  143.                ChangeCursor($06,$07);
  144.     Off    : ChangeCursor($20,$00);
  145.     Block  : if LastMode = Mono then
  146.                ChangeCursor($02,$0C)
  147.              else
  148.                ChangeCursor($02,$07);
  149.   end; { case}
  150. end;  { ChangeCursor}
  151.  
  152. procedure NormalCursor;
  153.   begin
  154.     Cursor(On);
  155.   end; { NormalCursor }
  156.  
  157. procedure HiddenCursor;
  158.   begin
  159.     Cursor(Off);
  160.   end; { HiddenCursor }
  161.  
  162. procedure BlockCursor;
  163.   begin
  164.     Cursor(Block);
  165.   end;  { BlockCursor }
  166.  
  167. procedure ClearKbdBuffer;
  168.   begin
  169.     {$IFDEF Ver60}
  170.     while Keypressed do ReadKey;
  171.     {$ELSE}
  172.     while KeyPressed do while ReadKey = #0 do;
  173.     {$ENDIF}
  174.   end;
  175.  
  176. function KeyWord : word; assembler;
  177.   { Returns a word value where the msb is the scan code of a keypress    }
  178.   { and the lsb is the asciiz value of the key.                          }
  179.   asm
  180.     mov  ax,0
  181.     int  16h
  182.   end;  { KeyWord }
  183.  
  184.  
  185. function  ReadStr(width   : word;
  186.                   prompt  : string;
  187.                   s       : string;
  188.                   _Input  : InputType) : string;
  189.  
  190. {   Editing keys are -                                                   }
  191. {     DeleteKey        - DeleteKeys character at the cursor.             }
  192. {     LeftArrow        - Nondestructive move cursor to the left.         }
  193. {     RightArrow       - Nondestructive move cursor to the right.        }
  194. {     End              - Move cursor to end of input string.             }
  195. {     Home             - Move cursor to start of input string.           }
  196. {     Backspace        - DeleteKeys character to the left of cursor.     }
  197. {     escape           - Aborts routine which then returns the original  }
  198. {                        data string. ExitKey will be equal to escape.   }
  199. {     return/enter     - Leaves routine with string returned. ExitKey=0  }
  200. {     Tab/TabLeft      - Leaves routine with string returned and sets    }
  201. {                        the global variable ExitKey to the key code.    }
  202. {     CursorKeys       - As per Tab/TabLeft except as above              }
  203.  
  204. {   Width = The width of the input field.  Once input reaches the width  }
  205. {           required, no further characters are accepted.                }
  206. {   prompt= A prompt will be displayed in the current attribute.  If no  }
  207. {           prompt is required pass a nul string.                        }
  208. {   attr  = The input field will be displayed in attr colour.            }
  209. {   s     = s will be displayed in the input field and the cursor will   }
  210. {           be positioned at the end of the s string.                    }
  211.  
  212. {   Example:                                                             }
  213. {      st := ReadStr(20,'Enter Name: ',st,AlphaNumeric);                 }
  214. {      ( st MUST be initialised in the above example before the call. )  }
  215.  
  216. const
  217.     space = #32;
  218. var
  219.   xpos, ypos,
  220.   stpos,OldAttr : byte;
  221.   len           : byte absolute s;
  222.   finished,
  223.   JustStarted   : boolean;
  224.   key           : word;
  225.   ch            : char absolute key;
  226.   OrigStr       : string;
  227.  
  228.   procedure WriteField;
  229.     { writes spaces to an input field }
  230.     var x : byte;
  231.     begin
  232.       GotoXY(xpos,ypos);
  233.       for x := 1 to width do
  234.         write(space);
  235.       GotoXY(xpos,ypos);
  236.     end; { WriteField }
  237.  
  238.   procedure DeleteChar;
  239.     begin
  240.       Delete(s,stpos,1);
  241.       s := s + space;
  242.       gotoXY(xpos,ypos);
  243.       write(s);
  244.       dec(len);
  245.     end;  { DeleteChar }
  246.  
  247.   procedure AddChar;
  248.     { Checks that it is valid to insert or add a character to input str }
  249.     begin
  250.       if JustStarted then begin
  251.         len   := 0;
  252.         stpos := 1;
  253.         WriteField;
  254.       end;
  255.       if InsertOn then begin
  256.         if (len < width) then begin
  257.           move(s[stpos],s[succ(stpos)],width-pred(stpos));
  258.           inc(len);
  259.           s[stpos] := ch;
  260.           inc(stpos);
  261.         end
  262.         else beep(450,15);
  263.       end else begin
  264.         if stpos <= width then begin
  265.           s[stpos] := ch;
  266.           if stpos > len then
  267.             inc(len);
  268.           inc(stpos);
  269.         end else beep(450,15);
  270.       end;
  271.     end; { AddChar }
  272.  
  273.   begin
  274.     OrigStr       := s;
  275.     ExitKey       := 0;
  276.     finished      := false;
  277.     JustStarted   := true;
  278.     OldAttr       := TextAttr;              { Save the current attribute }
  279.     write(prompt+' ');       { Write the prompt in the current attribute }
  280.     if (width + WhereX) > 79 then
  281.       writeln;
  282.     if ReverseColour then
  283.       FieldColour := (TextAttr shr 4) or ((TextAttr shl 5) shr 1);
  284.     TextAttr      := Fieldcolour; { Change the attribute for input field }
  285.     xpos          := WhereX;          { Save the current cursor position }
  286.     ypos          := WhereY;
  287.     WriteField;                                  { Clear the input field }
  288.     stpos         := 1;
  289.     repeat
  290.       GotoXY(xpos,ypos);
  291.       write(s);
  292.       GotoXY(xpos + pred(stpos),ypos);
  293.       if stpos = succ(width) then
  294.         Cursor(Off)
  295.       else if InsertOn then{ Change cursor size depending on insert mode }
  296.         Cursor(Block)
  297.       else
  298.         Cursor(Normal);
  299.       key := KeyWord;
  300.       case key of
  301.         InsertKey  : InsertOn := not InsertOn;
  302.         DeleteKey  : if (len > 0) and (stpos > 0) then
  303.                        DeleteChar;
  304.         Enter      : begin
  305.                        ReadStr  := s;
  306.                        finished := true;
  307.                      end;
  308.         BackSpace  : if stpos > 1 then begin
  309.                        dec(stpos);
  310.                        DeleteChar;
  311.                      end
  312.                      else beep(450,15);
  313.         Escape     : begin
  314.                        finished := true;
  315.                        ReadStr  := OrigStr;
  316.                        gotoXY(xpos,ypos); write(OrigStr);
  317.                        ExitKey  := Escape;
  318.                      end;
  319.         LeftArrow  : if stpos > 1 then dec(stpos);
  320.         RightArrow : if stpos <= len then inc(stpos);
  321.         Home       : stpos := 1;
  322.         EndKey     : stpos := succ(len);
  323.         Tab        : begin
  324.                        ExitKey  := Key;
  325.                        ReadStr  := s;
  326.                        finished := true;
  327.                      end
  328.         else if byte(ch) = 0 then begin
  329.           ExitKey  := Key;
  330.           ReadStr  := s;
  331.           finished := true;
  332.         end
  333.         else if ch in ValidKeys[_Input] then
  334.           AddChar
  335.         else beep(450,15);
  336.       end; { case key of }
  337.       JustStarted := false;
  338.     until finished;
  339.     TextAttr      := OldAttr;              { Restore the old attribute }
  340.     WriteField; write(s);
  341.   end; { ReadStr }
  342.  
  343. function ReadInteger(p: string; min,max,I: longint): longint;
  344.   { Prompts for input and converts that input to a longint.  If number }
  345.   { entered is less than min or greater than max, will beep and await  }
  346.   { re-entry of the data.                                              }
  347.   { Example:                                                           }
  348.   { L := ReadInteger('Enter number between 10 and 100: ',10,100,Numb); }
  349.   var
  350.     temp     : longint;
  351.     code     : integer;
  352.     finished : boolean;
  353.     st       : string;
  354.     col,row,
  355.     Irow,W   : byte;
  356.   begin
  357.     col := WhereX; row := WhereY; Irow := row + length(p);
  358.     if min >= 0 then
  359.       ValidKeys[Numeric] := ['0'..'9']
  360.     else
  361.       ValidKeys[Numeric] := ['0'..'9','-'];
  362.     repeat
  363.       str(max,st); W := length(st) + 1;
  364.       str(min,st);
  365.       if (length(st) + 1) > W then
  366.         W := length(st) + 1;
  367.       gotoXY(col,row);
  368.       str(I, st);
  369.       st := ReadStr(W,p,st,Numeric);
  370.       val(st,temp,code);
  371.       finished := (code = 0) and (temp >= min) and (temp <= max) or
  372.                   (ExitKey <> 0);
  373.       if not finished then
  374.         Beep(400,250)
  375.       else if code = 0 then
  376.         ReadInteger := temp
  377.       else begin
  378.         ReadInteger := I;
  379.         gotoXY(col,Irow);
  380.         write(I);
  381.       end;
  382.     until finished;
  383.   end;  { ReadInteger }
  384.  
  385. function ReadReal(p: string; min,max: longint; R: real): real;
  386.   { Prompts for input and converts that input to a real.  If number    }
  387.   { entered is less than min or greater than max, will beep and await  }
  388.   { re-entry of the data.                                              }
  389.   { Example:                                                           }
  390.   { R := ReadInteger('Enter number between 10 and 100: ',10,100,Numb); }
  391.  
  392.   var
  393.     temp     : real;
  394.     code     : integer;
  395.     finished : boolean;
  396.     st       : string;
  397.     col,row,
  398.     W        : byte;
  399.   begin
  400.     col := WhereX; row := WhereY;
  401.     str(max,st); W := length(st) + DecimalPts + 2;
  402.     str(min,st);
  403.     if (length(st) + DecimalPts + 2) > W then
  404.       W := length(st) + DecimalPts + 2;
  405.     if min >= 0 then
  406.       ValidKeys[Numeric] := ['0'..'9','.']
  407.     else
  408.       ValidKeys[Numeric] := ['0'..'9','-','.'];
  409.     repeat
  410.       str(R:0:DecimalPts,st); gotoXY(col,row);
  411.       st := ReadStr(11,p,st,Numeric);
  412.       val(st,temp,code);
  413.       finished := (code = 0) and (temp >= min) and (temp <= max)
  414.                   or (ExitKey <> 0);
  415.       if not finished then
  416.         Beep(400,250)
  417.       else if (code = 0) then
  418.         ReadReal := temp
  419.       else begin
  420.         gotoXY(col,row);
  421.         write(R:0:DecimalPts);
  422.         ReadReal := R;
  423.       end;
  424.     until finished;
  425.   end;  { ReadReal }
  426.  
  427. function ReadExtended(p: string; min,max: longint; R: Extended): Extended;
  428.   { Prompts for input and converts that input to a Extended. If number }
  429.   { entered is less than min or greater than max, will beep and await  }
  430.   { re-entry of the data.                                              }
  431.   { Example:                                                           }
  432.   { R := ReadInteger('Enter number between 10 and 100: ',10,100,Numb); }
  433.  
  434.   var
  435.     temp     : Extended;
  436.     code     : integer;
  437.     finished : boolean;
  438.     st       : string;
  439.     col,row,
  440.     W        : byte;
  441.   begin
  442.     col := WhereX; row := WhereY;
  443.     str(max,st); W := length(st) + DecimalPts + 2;
  444.     str(min,st);
  445.     if (length(st) + DecimalPts + 2) > W then
  446.       W := length(st) + DecimalPts + 2;
  447.     if min >= 0 then
  448.       ValidKeys[Numeric] := ['0'..'9','.']
  449.     else
  450.       ValidKeys[Numeric] := ['0'..'9','-','.'];
  451.     repeat
  452.       str(R:0:DecimalPts,st);  gotoXY(col,row);
  453.       st := ReadStr(W,p,st,Numeric);
  454.       val(st,temp,code);
  455.       finished := (code = 0) and (temp >= min) and (temp <= max)
  456.                   or (ExitKey <> 0);
  457.       if not finished then
  458.         Beep(400,250)
  459.       else if (code = 0) then
  460.         ReadExtended := temp
  461.       else begin
  462.         gotoXY(col,row);
  463.         write(R:0:DecimalPts);
  464.         ReadExtended := R;
  465.       end;
  466.     until finished;
  467.   end;  { ReadExtended }
  468.  
  469.  
  470. procedure SetLock(TKey: Toggles; state: ToggleType);
  471.   { Sets the status of the various keyboard toggle locks.  On older XTs  }
  472.   { this may not cause the keyboard LED indicators to change.            }
  473.   begin
  474.     case TKey of
  475.     CapsLock  : if state = On then
  476.                   KbdStatus := KbdStatus + [CapsLock]
  477.                 else
  478.                   KbdStatus := KbdStatus - [CapsLock];
  479.     NumLock  : if state = On then
  480.                   KbdStatus := KbdStatus + [NumLock]
  481.                 else
  482.                   KbdStatus := KbdStatus - [NumLock];
  483.     ScrollLock: if state = On then
  484.                   KbdStatus := KbdStatus + [ScrollLock]
  485.                 else
  486.                   KbdStatus := KbdStatus - [ScrollLock];
  487.     end; { case }
  488.   end;
  489.  
  490. function  LeftShiftPressed: boolean;
  491.   begin
  492.     LeftShiftPressed := LeftShift in KbdStatus;
  493.   end;
  494.  
  495. function  RightShiftPressed: boolean;
  496.   begin
  497.     RightShiftPressed := RightShift in KbdStatus;
  498.   end;
  499.  
  500. function  AltPressed: boolean;
  501.   begin
  502.     AltPressed := Alt in KbdStatus;
  503.   end;
  504.  
  505. function  CtrlPressed: boolean;
  506.   begin
  507.     CtrlPressed := Ctrl in KbdStatus;
  508.   end;
  509.  
  510. procedure KbdExitProc; far;
  511.   begin
  512.     ExitProc := OldExitProc;
  513.     Cursor(OriginalStatus);   { Restore the cursor to the original state }
  514.   end;  { KbdExitProc }
  515.  
  516. begin
  517.   ValidKeys[AlphaNumeric] := [#0..#255];
  518.   FieldColour := TextAttr;
  519.   { Set up an exit procedure to ensure that the cursor is restored when  }
  520.   { when the program terminates (however that may occur!)                }
  521.   OldExitProc    := ExitProc;
  522.   OriginalStatus := CursorStatus;
  523. end.
  524.  
  525.