Category : Miscellaneous Language Source Code
Archive   : ADAMENU2.ZIP
Filename : ADALIB.PKG

 
Output of file : ADALIB.PKG contained in archive : ADAMENU2.ZIP
-- .asis
with Text_io, video, msdos;
use Text_io, video;

package body Adalib is
use Strings;

cr : constant CHARACTER := CHARACTER'Val (13);
esc : constant CHARACTER := CHARACTER'Val (27);
bs : constant CHARACTER := CHARACTER'Val (8);
cntrlc : constant CHARACTER := CHARACTER'Val (3);

function UpCase ( Ch : in CHARACTER ) return CHARACTER is
-- Return uppercase ch
Temp : CHARACTER;
begin
Temp := Ch;
if (Ch in 'a'..'z') then
Temp := CHARACTER'Val(CHARACTER'Pos(ch)-32);
end if;
return Temp;
end UpCase;

function Upperstr (s : in LSTRING) return LSTRING is
-- Convert STRING s to uppercase.
Temp : LSTRING;
begin
Temp := s;
for i in 1..Length (s) loop
if Temp.Data (i) in 'a'..'z' then
Temp.Data (i) := CHARACTER'Val
(CHARACTER'Pos(Temp.Data(i))-32);
end if;
end loop;
return Temp;
end Upperstr;

procedure Show_at (x, y : in POSITIVE;
s : in STRING ) is
-- Go to cursor location x, y, and display s
begin
GoToXY (x, y);
Video.Write (s);
end show_at;

procedure show_at (x, y : in POSITIVE;
s : in LSTRING) is
-- Go to cursor location x, y, and display s
begin
GoToXY (x, y);
Video.Write (S.Data, S.len);
end show_at;

procedure frame ( UpLeftx, UpLefty,
LoRightx, LoRighty : in INTEGER;
Style : in Border_Style := DOUBLE) is
-- draw a frame on the screen using given coords.
UR_corner,
UL_corner,
LR_corner,
LL_corner,
Horiz, Vert : INTEGER;
begin
case Style is
when SINGLE => UL_corner := 218;
UR_corner := 191;
LL_corner := 192;
LR_corner := 217;
Horiz := 196;
Vert := 179;
when DOUBLE => UL_corner := 201;
UR_corner := 187;
LL_corner := 200;
LR_corner := 188;
Horiz := 205;
Vert := 186;
end case;
GoToXY (UpLeftX, UpLeftY);
Video.Write (UL_corner); -- draw upper left corner
for i in (upleftx + 1)..(lorightx - 1) loop
Video.Write (Horiz); -- draw the top line
end loop;
Video.Write (UR_corner); -- draw upper right corner
for i in (uplefty + 1)..(lorighty - 1)
loop -- draw the sides
GoToXY (upleftx , i); Video.Write (Vert);
GoToXY (lorightx, i); Video.Write (Vert);
end loop;
GoToXY (upleftx, lorighty);
Video.Write (LL_corner); -- draw the lower left corner
for i in (upleftx + 1)..(lorightx - 1) loop
Video.Write (Horiz); -- draw the bottom line
end loop;
Video.Write (LR_corner); -- draw bottom right corner
end frame;

procedure savexy (x, y : in out INTEGER) is
-- save the current cursor location in x and y
begin
x := wherex;
y := wherey;
end savexy;

procedure Read_Line ( St : in out LSTRING;
Len : in out INTEGER ) is
-- All string input is done through this routine.
-- Len is the maximum number of characters to read, and
-- it returns the number of chars in St.
Ch : CHARACTER;
x, y, i : INTEGER;
begin
St.Data := (others => CHARACTER'Val (0));
loop
Ch := MsDos.Kybdchar;
if (Length (St) < Len) or
(Ch = bs) or (Ch = esc) then
case Ch is
when CHARACTER'Val(32)..
CHARACTER'Val(127)
=> St := concat (St, Ch);
Video.Write (CHARACTER'Pos(ch));
when cr => null;
when bs => if (length (St) > 0) then
delete (st, length (st), 1);
put (bs);
put (' ');
put (bs);
else MsDos.bell;
end if;
when esc => Ch := cr;
St := (Length => St.Length,
Data => (others => CHARACTER'Val (0)),
Len => 0);
when others => MsDos.bell;
end case;
elsif (Ch /= cr) then MsDos.bell;
end if;
exit when (Ch = cr);
end loop;
end Read_Line;

function Float_Val (s : in LSTRING) return FLOAT is
--
-- Return the floating point value of s.
-- Reads the string left to right and converts until an invalid
-- character is read.
-- If s is null, or if it begins with an invalid character,
-- FLOAT_val returns 0.0
--
last : constant CHARACTER := '/';
space : constant CHARACTER := ' ';
z : constant INTEGER := CHARACTER'Pos ('0');
i : INTEGER := 1; -- Buffer index pointer
a : FLOAT := 0.0; -- Accumulator for the return value
f : FLOAT := 0.1; -- Fractional multiplication factor
Ch : CHARACTER; -- The current character
neg : BOOLEAN; -- Negative number flag
Gs : LSTRING ; -- Local buffer for the string

begin
Gs := concat (s, last); -- Make buffer length at least 1,
-- with a non numeric terminator.
while (Gs.Data (1) = space) loop
delete (Gs, 1, 1); -- Strip any leading spaces.
end loop;
Ch := Gs.Data (1);
if (Ch = '-') then -- Check for a leading minus sign.
neg := true; -- If found, set negative flag to true,
i := i+1; -- increment the buffer index pointer,
Ch := Gs.Data (i); -- get the next char in the buffer.
else -- else
neg := false; -- Set the negative flag to false.
if (Ch = '+') then -- If there is a leading positive sign,
i := i+1; -- then incremment the buffer,
Ch := Gs.Data (i); -- and get the next character.
end if;
end if;
if (Ch in '0'..'9') then -- Check for a numeric character
loop
a := 10.0*a+FLOAT -- If valid, multiply return value
(CHARACTER'Pos(ch)-z); -- by 10 and add the value of ch,
i := i+1; -- Increment the buffer index pointer,
Ch := Gs.Data (i); -- and get the next character.
exit when not (Ch in '0'..'9');
end loop;
end if;
--
if (Ch = '.') then -- If there's a decimal point,
i := i+1; -- increment the buffer pointer,
Ch := Gs.Data (i); -- and get the next character.
while (Ch in '0'..'9') loop -- Check next character
a := a+FLOAT -- If valid numeric, then multiply the
(CHARACTER'Pos(ch)-z)*f; -- value of Ch by the factor and
-- add it to the return value (a)
f := f*0.1; -- Calculate next factor
i := i+1; -- Increment the buffer index,
Ch := Gs.Data (i); -- and get the next character.
end loop;
end if;
if neg then a := -a; end if; -- make negative if flag was set
return a;
exception
when NUMERIC_ERROR => return 0.0;
end Float_Val;

end Adalib;


  3 Responses to “Category : Miscellaneous Language Source Code
Archive   : ADAMENU2.ZIP
Filename : ADALIB.PKG

  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/