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 >
Wrap
Pascal/Delphi Source File
|
1992-10-20
|
17KB
|
525 lines
{$IFDEF Ver60}
{$A+,B-,D-,E+,F-,I-,L-,N+,O-,R-,S-,V-,X+}
{$ELSE}
{$A+,B-,D-,E+,F-,I-,L-,N+,O-,R-,S-,V-}
{$ENDIF}
unit keyinput;
{ Author Trevor J Carlsen - released into the public domain 1991 }
{ PO Box 568 }
{ Port Hedland }
{ Western Australia 6721 }
{ Voice +61 91 73 2026 Data +61 91 73 2930 }
{ FidoNet 3:690/644 }
{ This unit is designed to permit controlled input into a pre-determined }
{ field size. It also provides some handy associated procedures and }
{ functions and constants. }
interface
uses crt;
const { These are the values returned by the function ReadWord }
F1 = $3b00; ShF1 = $5400; CtrlF1 = $5e00; AltF1 = $6800;
F2 = $3c00; ShF2 = $5500; CtrlF2 = $5f00; AltF2 = $6900;
F3 = $3d00; ShF3 = $5600; CtrlF3 = $6000; AltF3 = $6a00;
F4 = $3e00; ShF4 = $5700; CtrlF4 = $6100; AltF4 = $6b00;
F5 = $3f00; ShF5 = $5800; CtrlF5 = $6200; AltF5 = $6c00;
F6 = $4000; ShF6 = $5900; CtrlF6 = $6300; AltF6 = $6d00;
F7 = $4100; ShF7 = $5a00; CtrlF7 = $6400; AltF7 = $6e00;
F8 = $4200; ShF8 = $5b00; CtrlF8 = $6500; AltF8 = $6f00;
F9 = $4300; ShF9 = $5c00; CtrlF9 = $6600; AltF9 = $7000;
F10 = $4400; ShF10 = $5d00; CtrlF10 = $6700; AltF10 = $7100;
BackSpace = $0e08; CtrlBackSpace = $0e7f;
Tab = $0f09; Tab_left = $0f00;
Enter = $1c0d; CtrlEnter = $1c0a;
InsertKey = $5200; DeleteKey = $5300;
Home = $4700; CtrlHome = $7700;
Endkey = $4f00; CtrlEnd = $7500;
PageUp = $4900; CtrlPageUp = $8400;
PageDn = $5100; CtrlPageDown = $7600;
UpArrow = $4800; DownArrow = $5000;
LeftArrow = $4b00; CtrlLeftArrow = $7300;
RightArrow = $4d00; CtrlRightArrow= $7400;
Escape = $011b;
type
Toggles = (RightShift, LeftShift, Ctrl, Alt,
ScrollLock, NumLock, CapsLock, Insert);
shiftstatus = set of Toggles;
CursorState = (Off, On, Normal, Block);
ToggleType = Off..On;
InputType = (Numeric, AlphaNumeric);
const
ReverseColour: boolean = false;{ The input field will be the default attr }
{ in reverse }
InsertOn : boolean = false;
ExitKey : word = 0;
DecimalPts : byte = 2;
var
FieldColour : byte;
KbdStatus : shiftstatus absolute $40:$17;
ValidKeys: array[InputType] of set of char;
procedure Beep(freq,len: word);
function CursorStatus: CursorState;
procedure Cursor(Action: CursorState);
procedure NormalCursor;
procedure HiddenCursor;
procedure BlockCursor;
procedure ClearKbdBuffer;
function KeyWord: word;
function ReadStr(width : word;
prompt : string;
s : string;
_Input : InputType) : string;
function ReadInteger(p: string; min,max,I: longint): longint;
function ReadReal(p: string; min,max: longint; R: real): real;
function ReadExtended(p: string; min,max: longint; R: Extended): Extended;
procedure SetLock(TKey: Toggles; state: ToggleType);
function LeftShiftPressed: boolean;
function RightShiftPressed: boolean;
function AltPressed: boolean;
function CtrlPressed: boolean;
implementation
var
OriginalStatus : CursorState;
OldExitProc : pointer;
procedure Beep(freq,len : word);
{ Beeps the speaker for len thousandths of a second }
begin
Sound(freq);
delay(len);
NoSound;
end; { Beep }
function CursorStatus: CursorState;
{ Check the current status of the cursor and assigns it a value }
var
bottom: byte absolute $40:$60;
top : byte absolute $40:$61;
x : shortint;
begin
x := bottom - top;
if x < 0 then
CursorStatus := Off
else if x = 1 then
CursorStatus := Normal
else if x > 1 then
CursorStatus := Block
else CursorStatus := On;
end; { CursorStatus }
procedure Cursor(Action : CursorState);
{ Turn the cursor on/off or make it a block}
procedure ChangeCursor(top,bottom : byte);
begin
asm
mov ah, $01
mov ch, top
mov cl, bottom
int $10
end;
end; { ChangeCursor}
begin
case action of
On : if LastMode = Mono then
ChangeCursor($0C,$0C)
else
ChangeCursor($06,$06);
Normal : if LastMode = Mono then
ChangeCursor($0B,$0C)
else
ChangeCursor($06,$07);
Off : ChangeCursor($20,$00);
Block : if LastMode = Mono then
ChangeCursor($02,$0C)
else
ChangeCursor($02,$07);
end; { case}
end; { ChangeCursor}
procedure NormalCursor;
begin
Cursor(On);
end; { NormalCursor }
procedure HiddenCursor;
begin
Cursor(Off);
end; { HiddenCursor }
procedure BlockCursor;
begin
Cursor(Block);
end; { BlockCursor }
procedure ClearKbdBuffer;
begin
{$IFDEF Ver60}
while Keypressed do ReadKey;
{$ELSE}
while KeyPressed do while ReadKey = #0 do;
{$ENDIF}
end;
function KeyWord : word; assembler;
{ Returns a word value where the msb is the scan code of a keypress }
{ and the lsb is the asciiz value of the key. }
asm
mov ax,0
int 16h
end; { KeyWord }
function ReadStr(width : word;
prompt : string;
s : string;
_Input : InputType) : string;
{ Editing keys are - }
{ DeleteKey - DeleteKeys character at the cursor. }
{ LeftArrow - Nondestructive move cursor to the left. }
{ RightArrow - Nondestructive move cursor to the right. }
{ End - Move cursor to end of input string. }
{ Home - Move cursor to start of input string. }
{ Backspace - DeleteKeys character to the left of cursor. }
{ escape - Aborts routine which then returns the original }
{ data string. ExitKey will be equal to escape. }
{ return/enter - Leaves routine with string returned. ExitKey=0 }
{ Tab/TabLeft - Leaves routine with string returned and sets }
{ the global variable ExitKey to the key code. }
{ CursorKeys - As per Tab/TabLeft except as above }
{ Width = The width of the input field. Once input reaches the width }
{ required, no further characters are accepted. }
{ prompt= A prompt will be displayed in the current attribute. If no }
{ prompt is required pass a nul string. }
{ attr = The input field will be displayed in attr colour. }
{ s = s will be displayed in the input field and the cursor will }
{ be positioned at the end of the s string. }
{ Example: }
{ st := ReadStr(20,'Enter Name: ',st,AlphaNumeric); }
{ ( st MUST be initialised in the above example before the call. ) }
const
space = #32;
var
xpos, ypos,
stpos,OldAttr : byte;
len : byte absolute s;
finished,
JustStarted : boolean;
key : word;
ch : char absolute key;
OrigStr : string;
procedure WriteField;
{ writes spaces to an input field }
var x : byte;
begin
GotoXY(xpos,ypos);
for x := 1 to width do
write(space);
GotoXY(xpos,ypos);
end; { WriteField }
procedure DeleteChar;
begin
Delete(s,stpos,1);
s := s + space;
gotoXY(xpos,ypos);
write(s);
dec(len);
end; { DeleteChar }
procedure AddChar;
{ Checks that it is valid to insert or add a character to input str }
begin
if JustStarted then begin
len := 0;
stpos := 1;
WriteField;
end;
if InsertOn then begin
if (len < width) then begin
move(s[stpos],s[succ(stpos)],width-pred(stpos));
inc(len);
s[stpos] := ch;
inc(stpos);
end
else beep(450,15);
end else begin
if stpos <= width then begin
s[stpos] := ch;
if stpos > len then
inc(len);
inc(stpos);
end else beep(450,15);
end;
end; { AddChar }
begin
OrigStr := s;
ExitKey := 0;
finished := false;
JustStarted := true;
OldAttr := TextAttr; { Save the current attribute }
write(prompt+' '); { Write the prompt in the current attribute }
if (width + WhereX) > 79 then
writeln;
if ReverseColour then
FieldColour := (TextAttr shr 4) or ((TextAttr shl 5) shr 1);
TextAttr := Fieldcolour; { Change the attribute for input field }
xpos := WhereX; { Save the current cursor position }
ypos := WhereY;
WriteField; { Clear the input field }
stpos := 1;
repeat
GotoXY(xpos,ypos);
write(s);
GotoXY(xpos + pred(stpos),ypos);
if stpos = succ(width) then
Cursor(Off)
else if InsertOn then{ Change cursor size depending on insert mode }
Cursor(Block)
else
Cursor(Normal);
key := KeyWord;
case key of
InsertKey : InsertOn := not InsertOn;
DeleteKey : if (len > 0) and (stpos > 0) then
DeleteChar;
Enter : begin
ReadStr := s;
finished := true;
end;
BackSpace : if stpos > 1 then begin
dec(stpos);
DeleteChar;
end
else beep(450,15);
Escape : begin
finished := true;
ReadStr := OrigStr;
gotoXY(xpos,ypos); write(OrigStr);
ExitKey := Escape;
end;
LeftArrow : if stpos > 1 then dec(stpos);
RightArrow : if stpos <= len then inc(stpos);
Home : stpos := 1;
EndKey : stpos := succ(len);
Tab : begin
ExitKey := Key;
ReadStr := s;
finished := true;
end
else if byte(ch) = 0 then begin
ExitKey := Key;
ReadStr := s;
finished := true;
end
else if ch in ValidKeys[_Input] then
AddChar
else beep(450,15);
end; { case key of }
JustStarted := false;
until finished;
TextAttr := OldAttr; { Restore the old attribute }
WriteField; write(s);
end; { ReadStr }
function ReadInteger(p: string; min,max,I: longint): longint;
{ Prompts for input and converts that input to a longint. If number }
{ entered is less than min or greater than max, will beep and await }
{ re-entry of the data. }
{ Example: }
{ L := ReadInteger('Enter number between 10 and 100: ',10,100,Numb); }
var
temp : longint;
code : integer;
finished : boolean;
st : string;
col,row,
Irow,W : byte;
begin
col := WhereX; row := WhereY; Irow := row + length(p);
if min >= 0 then
ValidKeys[Numeric] := ['0'..'9']
else
ValidKeys[Numeric] := ['0'..'9','-'];
repeat
str(max,st); W := length(st) + 1;
str(min,st);
if (length(st) + 1) > W then
W := length(st) + 1;
gotoXY(col,row);
str(I, st);
st := ReadStr(W,p,st,Numeric);
val(st,temp,code);
finished := (code = 0) and (temp >= min) and (temp <= max) or
(ExitKey <> 0);
if not finished then
Beep(400,250)
else if code = 0 then
ReadInteger := temp
else begin
ReadInteger := I;
gotoXY(col,Irow);
write(I);
end;
until finished;
end; { ReadInteger }
function ReadReal(p: string; min,max: longint; R: real): real;
{ Prompts for input and converts that input to a real. If number }
{ entered is less than min or greater than max, will beep and await }
{ re-entry of the data. }
{ Example: }
{ R := ReadInteger('Enter number between 10 and 100: ',10,100,Numb); }
var
temp : real;
code : integer;
finished : boolean;
st : string;
col,row,
W : byte;
begin
col := WhereX; row := WhereY;
str(max,st); W := length(st) + DecimalPts + 2;
str(min,st);
if (length(st) + DecimalPts + 2) > W then
W := length(st) + DecimalPts + 2;
if min >= 0 then
ValidKeys[Numeric] := ['0'..'9','.']
else
ValidKeys[Numeric] := ['0'..'9','-','.'];
repeat
str(R:0:DecimalPts,st); gotoXY(col,row);
st := ReadStr(11,p,st,Numeric);
val(st,temp,code);
finished := (code = 0) and (temp >= min) and (temp <= max)
or (ExitKey <> 0);
if not finished then
Beep(400,250)
else if (code = 0) then
ReadReal := temp
else begin
gotoXY(col,row);
write(R:0:DecimalPts);
ReadReal := R;
end;
until finished;
end; { ReadReal }
function ReadExtended(p: string; min,max: longint; R: Extended): Extended;
{ Prompts for input and converts that input to a Extended. If number }
{ entered is less than min or greater than max, will beep and await }
{ re-entry of the data. }
{ Example: }
{ R := ReadInteger('Enter number between 10 and 100: ',10,100,Numb); }
var
temp : Extended;
code : integer;
finished : boolean;
st : string;
col,row,
W : byte;
begin
col := WhereX; row := WhereY;
str(max,st); W := length(st) + DecimalPts + 2;
str(min,st);
if (length(st) + DecimalPts + 2) > W then
W := length(st) + DecimalPts + 2;
if min >= 0 then
ValidKeys[Numeric] := ['0'..'9','.']
else
ValidKeys[Numeric] := ['0'..'9','-','.'];
repeat
str(R:0:DecimalPts,st); gotoXY(col,row);
st := ReadStr(W,p,st,Numeric);
val(st,temp,code);
finished := (code = 0) and (temp >= min) and (temp <= max)
or (ExitKey <> 0);
if not finished then
Beep(400,250)
else if (code = 0) then
ReadExtended := temp
else begin
gotoXY(col,row);
write(R:0:DecimalPts);
ReadExtended := R;
end;
until finished;
end; { ReadExtended }
procedure SetLock(TKey: Toggles; state: ToggleType);
{ Sets the status of the various keyboard toggle locks. On older XTs }
{ this may not cause the keyboard LED indicators to change. }
begin
case TKey of
CapsLock : if state = On then
KbdStatus := KbdStatus + [CapsLock]
else
KbdStatus := KbdStatus - [CapsLock];
NumLock : if state = On then
KbdStatus := KbdStatus + [NumLock]
else
KbdStatus := KbdStatus - [NumLock];
ScrollLock: if state = On then
KbdStatus := KbdStatus + [ScrollLock]
else
KbdStatus := KbdStatus - [ScrollLock];
end; { case }
end;
function LeftShiftPressed: boolean;
begin
LeftShiftPressed := LeftShift in KbdStatus;
end;
function RightShiftPressed: boolean;
begin
RightShiftPressed := RightShift in KbdStatus;
end;
function AltPressed: boolean;
begin
AltPressed := Alt in KbdStatus;
end;
function CtrlPressed: boolean;
begin
CtrlPressed := Ctrl in KbdStatus;
end;
procedure KbdExitProc; far;
begin
ExitProc := OldExitProc;
Cursor(OriginalStatus); { Restore the cursor to the original state }
end; { KbdExitProc }
begin
ValidKeys[AlphaNumeric] := [#0..#255];
FieldColour := TextAttr;
{ Set up an exit procedure to ensure that the cursor is restored when }
{ when the program terminates (however that may occur!) }
OldExitProc := ExitProc;
OriginalStatus := CursorStatus;
end.