Category : Pascal Source Code
Archive   : LIBPAS.ZIP
Filename : LIBRARY.PAS

 
Output of file : LIBRARY.PAS contained in archive : LIBPAS.ZIP
unit NewLib2;
interface
uses crt,dos;

const
MaxFiles = 30;
MaxChoices = 8;

type
STRING79 = string[79];
TOGGLE_REC = record
NUM_CHOICES: integer;
STRINGS : array [0..8] of STRING79;
LOCATIONS : array [0..8] of integer;
end;
RESPONSE_TYPE = (NO_RESPONSE, ARROW, KEYBOARD, RETURN);
MOVEMENT = (NONE, LEFT, RIGHT, UP, DOWN);
FnameType = string[12];
FileListType = array[1..MaxFiles] of FnameType;
ScrMenuRec = record
Selection : array[1..MaxChoices] of STRING79;
Descripts : array[1..MaxChoices,1..3] of STRING79;
end;
ScrMenuType = object
NumChoices : integer;
Last : integer;
Line, Col : integer;
MenuData : ScrMenuRec;
procedure Setup(MData: ScrMenuRec);
function GetChoice : integer;
end;


procedure Set_Video (ATTRIBUTE: integer);
procedure Put_String (OUT_STRING: STRING79; LINE, COL, ATTRIB: integer);
procedure Put_Text (OUT_STRING: STRING79; LINE, COL: integer);
procedure Put_Colored_Text (OUT_STRING: STRING79;
LINE, COL, TXTCLR, BKGCLR: integer);
procedure Put_Centered_String (OUT_STRING: STRING79; LINE, ATTRIB: integer);
procedure Put_Centered_Text (OUT_STRING: STRING79; LINE: integer);
procedure Put_Error (OUT_STRING: STRING79; LINE, COL: integer);
procedure End_Erase (LINE, COL: integer);
procedure Put_Prompt (OUT_STRING: STRING79; LINE, COL: integer);
procedure Get_Response (var RESPONSE : RESPONSE_TYPE;
var DIRECTION : MOVEMENT;
var KEY_RESPONSE: char);
procedure Get_String (var IN_STRING: STRING79;
LINE, COL, ATTRIB, STR_LENGTH: integer);
procedure Get_Integer (var NUMBER: integer;
LINE, COL, ATTRIB, NUM_LENGTH: integer);
procedure Get_Prompted_String (var IN_STRING: STRING79;
INATTR, STR_LENGTH: integer;
STRDESC: STRING79;
DESCLINE, DESCCOL: integer;
PROMPT: STRING79;
PRLINE, PRCOL: integer);
procedure Put_1col_Toggle (TOGGLE: TOGGLE_REC; COL, CHOICE: integer);
procedure Get_1col_Toggle ( TOGGLE: TOGGLE_REC;
COL: integer;
var CHOICE: integer;
PROMPT: STRING79;
PRLINE, PRCOL: integer);
procedure Box_Text (TopX, TopY, BotX, BotY, BoxColor: integer);
procedure Solid_Box (TopX, TopY, BotX, BotY, BoxColor: integer);
procedure swap_fnames(var A,B: FnameType);
procedure FileSort(var fname: FileListType; NumFiles: integer);
function Get_Files_Toggle (choices: FileListType;
NumChoices,NumRows,row,col:integer): FnameType;
function Get_File_Menu(mask: string;NumRows,Row,Col: integer): FnameType;


{-------------------------------------------------------------------------}
implementation

procedure Set_Video (ATTRIBUTE: integer);
{
NOTES:
The attribute code, based on bits, is as follows:
0 - normal video 1 - reverse video
2 - bold video 3 - reverse and bold
4 - blinking video 5 - reverse and blinking
6 - bold and blinking 7 - reverse, bold, and blinking
}

var
BLINKING,
BOLD: integer;

begin
BLINKING := (ATTRIBUTE AND 4)*4;
if (ATTRIBUTE AND 1) = 1 then
begin
BOLD := (ATTRIBUTE AND 2)*7;
Textcolor (1 + BLINKING + BOLD);
TextBackground (3);
end
else
begin
BOLD := (ATTRIBUTE AND 2)*5 DIV 2;
Textcolor (7 + BLINKING + BOLD);
TextBackground (0);
end;
end;

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

procedure Put_String (OUT_STRING: STRING79;
LINE, COL, ATTRIB: integer);

begin
Set_Video (ATTRIB);
GotoXY (COL, LINE);
write (OUT_STRING);
Set_Video (0);
end;

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

procedure Put_Text (OUT_STRING: STRING79;
LINE, COL: integer);

begin
GotoXY (COL, LINE);
write (OUT_STRING);
end;

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

procedure Put_Colored_Text (OUT_STRING: STRING79;
LINE, COL, TXTCLR, BKGCLR: integer);

begin
GotoXY (COL, LINE);
TextColor (TXTCLR);
TextBackground (BKGCLR);
write (OUT_STRING);
end;

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

procedure Put_Centered_String (OUT_STRING: STRING79;
LINE, ATTRIB: integer);

begin
Put_String (OUT_STRING, LINE, 40-Length(OUT_STRING) div 2, ATTRIB);
end;

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

procedure Put_Centered_Text (OUT_STRING: STRING79;
LINE: integer);

begin
Put_Text (OUT_STRING, LINE, 40-Length(OUT_STRING) div 2);
end;

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

procedure Put_Error (OUT_STRING: STRING79;
LINE, COL: integer);

var
ANY_CHAR : char;

begin
repeat
Put_String (OUT_STRING, LINE, COL, 6);
until keypressed = true;
end;

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

procedure End_Erase (LINE, COL: integer);

begin
GotoXY (COL, LINE);
ClrEol;
end;

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

procedure Put_Prompt (OUT_STRING: STRING79;
LINE, COL: integer);

begin
GotoXY (COL, LINE);
ClrEol;
Put_String (OUT_STRING, LINE, COL, 3);
end;

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


procedure Get_Response (var RESPONSE : RESPONSE_TYPE;
var DIRECTION : MOVEMENT;
var KEY_RESPONSE: char);

const
BELL = 7;
CARRIAGE_RETURN = 13;
ESCAPE = 27;
RIGHT_ARROW = 77;
LEFT_ARROW = 75;
DOWN_ARROW = 80;
UP_ARROW = 72;

var
IN_CHAR: char;

begin
RESPONSE := NO_RESPONSE;
DIRECTION := NONE;
KEY_RESPONSE := ' ';
repeat
IN_CHAR := ReadKey;
if IN_CHAR = #0 then
begin
RESPONSE := ARROW;
IN_CHAR := ReadKey;
if Ord(IN_CHAR) = LEFT_ARROW then
DIRECTION := LEFT
else if Ord(IN_CHAR) = RIGHT_ARROW then
DIRECTION := RIGHT
else if Ord(IN_CHAR) = DOWN_ARROW then
DIRECTION := DOWN
else if Ord(IN_CHAR) = UP_ARROW then
DIRECTION := UP
else
begin
RESPONSE := NO_RESPONSE;
write (Chr(BELL));
end
end
else if Ord(IN_CHAR) = CARRIAGE_RETURN then
RESPONSE := RETURN
else
begin
RESPONSE := KEYBOARD;
KEY_RESPONSE := UpCase (IN_CHAR);
end;
until RESPONSE <> NO_RESPONSE;
end;

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

procedure Get_String (var IN_STRING: STRING79;
LINE, COL, ATTRIB, STR_LENGTH: integer);

var
OLDSTR : STRING79;
IN_CHAR: char;
I : integer;

const
BELL = 7;
BACK_SPACE = 8;
CARRIAGE_RETURN = 13;
ESCAPE = 27;
RIGHT_ARROW = 77;

begin
OLDSTR := IN_STRING;
Put_String (IN_STRING, LINE, COL, ATTRIB);
for I := Length(IN_STRING) to STR_LENGTH-1 do
Put_String (' ', LINE, COL + I, ATTRIB);
GotoXY (COL, LINE);
IN_CHAR := ReadKey;
if Ord(IN_CHAR) <> CARRIAGE_RETURN then
IN_STRING := '';
while Ord(IN_CHAR) <> CARRIAGE_RETURN do
begin
if Ord(IN_CHAR) = BACK_SPACE then
begin
if Length(IN_STRING) > 0 then
begin
IN_STRING[0] := Chr(Length(IN_STRING)-1);
write (Chr(BACK_SPACE));
write (' ');
write (Chr(BACK_SPACE));
end;
end { if BACK_SPACE }
else if IN_CHAR = #0 then
begin
IN_CHAR := ReadKey;
if Ord(IN_CHAR) = RIGHT_ARROW then
begin
if Length(OLDSTR) > Length(IN_STRING) then
begin
IN_STRING[0] := Chr(Length(IN_STRING) + 1);
IN_CHAR := OLDSTR[Ord(IN_STRING[0])];
IN_STRING[Ord(IN_STRING[0])] := IN_CHAR;
write (IN_CHAR);
end
end { RIGHT_ARROW }
else
write (Chr(BELL));
end { IN_CHAR = #0 }
else if Length (IN_STRING) < STR_LENGTH then
begin
IN_STRING[0] := Chr(Length(IN_STRING) + 1);
IN_STRING[Ord(IN_STRING[0])] := IN_CHAR;
TextColor (15);
TextBackGround (11);
write (IN_CHAR);
end
else
write (Chr(BELL));
IN_CHAR := ReadKey;
end;
Put_String (IN_STRING, LINE, COL, ATTRIB);
for I := Length(IN_STRING) to STR_LENGTH - 1 do
Put_String (' ', LINE, COL+I, ATTRIB);
end;

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

procedure Get_Integer (var NUMBER: integer;
LINE, COL, ATTRIB, NUM_LENGTH: integer);

const
BELL = 7;

var
VALCODE : integer;
ORIGINAL_STR,
TEMP_STR : STRING79;
TEMP_INT : integer;

begin
Str (NUMBER:NUM_LENGTH, ORIGINAL_STR);
repeat
TEMP_STR := ORIGINAL_STR;
Get_String (TEMP_STR, LINE, COL, ATTRIB, NUM_LENGTH);
while TEMP_STR[1] = ' ' do
TEMP_STR := Copy (TEMP_STR, 2, Length (TEMP_STR));
Val (TEMP_STR, TEMP_INT, VALCODE);
if (VALCODE <> 0) then
write (Chr(BELL));
until VALCODE = 0;
NUMBER := TEMP_INT;
Str (NUMBER:NUM_LENGTH, TEMP_STR);
Put_String (TEMP_STR, LINE, COL, ATTRIB);
end;

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

procedure Get_Prompted_String (var IN_STRING: STRING79;
INATTR, STR_LENGTH: integer;
STRDESC: STRING79;
DESCLINE, DESCCOL: integer;
PROMPT: STRING79;
PRLINE, PRCOL: integer);

begin
Put_String (STRDESC, DESCLINE, DESCCOL, 2);
Put_Prompt (PROMPT, PRLINE, PRCOL);
Get_String (IN_STRING, DESCLINE, DESCCOL + Length(STRDESC),
INATTR, STR_LENGTH);
Put_String (STRDESC, DESCLINE, DESCCOL, 0);
end;

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

procedure Put_1col_Toggle (TOGGLE: TOGGLE_REC;
COL, CHOICE: integer);

var
I: integer;

begin
with TOGGLE do
begin
Put_String (STRINGS[0], LOCATIONS[0], COL, 0);
for I := 1 to NUM_CHOICES do
Put_String (STRINGS[I], LOCATIONS[I], COL, 0);
if (CHOICE <1) or (CHOICE > NUM_CHOICES) then
CHOICE := 1;
Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);
end;
end;

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

procedure Get_1col_Toggle ( TOGGLE: TOGGLE_REC;
COL: integer;
var CHOICE: integer;
PROMPT: STRING79;
PRLINE, PRCOL: integer);

var
RESP : RESPONSE_TYPE;
DIR : MOVEMENT;
KEYCH: char;

begin
Put_Colored_Text (PROMPT, PRLINE, PRCOL, 15, 0);
with TOGGLE do
begin
Put_String (STRINGS[0], LOCATIONS[0], COL, 2);
if (CHOICE < 1) or (CHOICE > NUM_CHOICES) then
CHOICE := 1;
Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);
RESP := NO_RESPONSE;
while RESP <> RETURN do
begin
Get_Response (RESP, DIR, KEYCH);
case RESP of
ARROW:
if DIR = UP then
begin
Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 0);
if CHOICE = 1 then
CHOICE := NUM_CHOICES
else
CHOICE := CHOICE - 1;
Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);
end
else if DIR = DOWN then
begin
Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 0);
if CHOICE = NUM_CHOICES then
CHOICE := 1
else
CHOICE := CHOICE + 1;
Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);
end
else
write (Chr(7));
KEYBOARD: write (Chr(7));
RETURN: ;
end;
end; {while}
Put_String (STRINGS[0], LOCATIONS[0], COL, 0);
end;
end;

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

procedure Box_Text (TopX, TopY, BotX, BotY, BoxColor: integer);

var
i : integer;
width : integer;
height: integer;

begin
TextBackGround (BoxColor);
height := BotY - TopY;
width := BotX - TopX;
GotoXY (TopX, TopY);
for i := 1 to width do
write (' ');
for i := TopY to (TopY+height) do
begin
GotoXY (TopX, i);
write (' ');
GotoXY (BotX-1, i);
write (' ');
end;
GotoXY (TopX, BotY);
for i := 1 to width do
write (' ');
end;

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

procedure Solid_Box (TopX, TopY, BotX, BotY, BoxColor: integer);

var
i : integer;
j : integer;
width : integer;

begin
TextBackGround (BoxColor);
GotoXY (TopX, TopY);
width := BotX - TopX;
for i := TopY to BotY do
begin
for j := 1 to width do
write (' ');
GotoXY (TopX, i);
end;
end;

procedure swap_fnames(var A,B: FnameType);
var
Temp : FnameType;
begin
Temp := A;
A := B;
B := Temp;
end;

procedure FileSort(var fname: FileListType;NumFiles: integer);
var
i,j : integer;
begin
for j := NumFiles downto 2 do
for i := 1 to j-1 do
if fname[i]>fname[j] then
swap_fnames(fname[i],fname[j]);
end;

function Get_Files_Toggle (choices:FileListType;
NumChoices,NumRows,row,col:integer): FnameType;
var
i,r : integer;
Resp : Response_Type;
dir : movement;
keych : char;

procedure Put_Files_Toggle (choices: FileListType; First,NumRows,row,col: integer);
var
i : integer;
begin
for i := 0 to NumRows-1 do
Put_string (choices[First+i],row+i,col,0);
end;

procedure Padnames;
var
i,p : integer;
begin
for i := 1 to MaxFiles do
begin
p := 12-length(choices[i]);
while p>0 do
begin
choices[i] := choices[i]+' ';
p := p-1;
end;
end;
end;

begin
Padnames;
i := 1;
r := 1;
if NumChoices < NumRows then
NumRows := NumChoices;
Put_Files_Toggle (choices,1,NumRows,row,col);
Get_Files_Toggle := choices[i];
Put_string(choices[i],row,col,1);
resp := No_Response;
while resp <> Return do
begin
Get_response (resp,dir,keych);
case resp of
ARROW: if dir=UP then
begin
Put_string(choices[i],row+r-1,col,0);
if i=1 then
begin
i := NumChoices;
r := NumRows;
Put_Files_Toggle(choices,i+1-NumRows,NumRows,row,col);
end
else if r=1 then
begin
i := i-1;
Put_Files_Toggle(choices,i,NumRows,row,col);
end
else
begin
i := i-1;
r := r-1;
end;
Put_string(choices[i],row+r-1,col,1);
end
else if dir=DOWN then
begin
Put_string(choices[i],row+r-1,col,0);
if i=NumChoices then
begin
i := 1;
r := 1;
Put_Files_Toggle(choices,i,NumRows,row,col);
end
else if r=NumRows then
begin
i := i+1;
Put_Files_Toggle(choices,i+1-NumRows,NumRows,row,col);
end
else
begin
i := i+1;
r := r+1;
end;
Put_string(choices[i],row+r-1,col,1);
end
else
write (chr(7));
KEYBOARD: write (chr(7));
end; { case }
end;
Get_Files_toggle := choices[i];
end;

function Get_File_Menu(mask: string;NumRows,Row,Col: integer): FnameType;
var
i : integer;
NumFiles : integer;
FileList : FileListType;
dirinfo : SearchRec;
begin
i := 1;
FindFirst(mask,Archive,dirinfo);
while (DosError=0) AND (i begin
FileList[i] := dirinfo.name;
FindNext(dirinfo);
i := i+1;
end;
NumFiles := i-1;
FileSort(FileList,NumFiles);
Get_File_Menu := Get_Files_Toggle(FileList,NumFiles,NumRows,Row,Col);
end;

procedure ScrMenuType.Setup(MData : ScrMenuRec);
var i : integer;
begin
with MenuData do
for i := 1 to MaxChoices do
begin
selection[i] := MData.selection[i];
Descripts[i,1] := MData.descripts[i,1];
Descripts[i,2] := MData.descripts[i,2];
Descripts[i,3] := MData.descripts[i,3];
end;
end;

function ScrMenuType.GetChoice : integer;
var
i : integer;
Resp : Response_Type;
Dir : Movement;
KeyCh : char;

procedure PutDescripts;
var i : integer;
begin
window(0,0,79,24);
Solid_Box(3,21,79,24,lightgray);
for i := 1 to 3 do
Put_Colored_Text(MenuData.Descripts[last,i],20+i,4,white,lightgray);
end;

begin
with MenuData do
begin
for i := 0 to NumChoices-1 do
Put_String(Selection[i+1],Line+i,Col,0);
Put_String(Selection[Last],Line+Last-1,Col,1);
Resp := No_Response;
while Resp <> Return do
begin
PutDescripts;
Get_Response(Resp,Dir,KeyCh);
case Resp of
Arrow :
if Dir = Up then
begin
Put_String(Selection[Last],Line+Last-1,Col,0);
if Last = 1 then
Last := NumChoices
else
Last := Last-1;
Put_String(Selection[Last],Line+Last-1,Col,1);
end
else if Dir = Down then
begin
Put_String(Selection[Last],Line+Last-1,Col,0);
if Last = NumChoices then
Last := 1
else
Last := Last+1;
Put_String(Selection[Last],Line+Last-1,Col,1);
end;
end;
end;
end;
end;
{ Initialization Area }
begin
end.


  3 Responses to “Category : Pascal Source Code
Archive   : LIBPAS.ZIP
Filename : LIBRARY.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/