unit Hannu;
interface
uses
Graph, CRT, DOS;
procedure Graphics;
procedure DeleteFile (NAME :String);
procedure RenameFile (OLDNAME, NEWNAME :String);
procedure Sammuta_Kursori;
procedure Sytyta_Kursori;
procedure CopyFile (SOURCEFILE, TARGETFILE :String);
procedure Save_Screen(FILENAME :String);
procedure Load_Screen(FILENAME :String);
procedure Wait_Key;
procedure Print (X, Y :Integer; S :String);
procedure DrawLine (X, Y :Integer; PITUUS :Word; KULMA :Real);
procedure DrawLine2 (X, Y :Integer; SADE :Word; PITUUS :Word; KULMA :Real);
procedure Lines(K1, K2 :PointType);
procedure Empty_keybuffer;
procedure Zeros(var S :String; PITUUS :Byte);
procedure LineEnd(K :PointType; PITUUS :Word; KULMA :Real;
var T :PointType);
function ReadSpecialKey :Integer;
function Etaisyys (X1, Y1, X2, Y2 :Integer) :LongInt;
function Upper (S :String) :String;
function Lower (S :String) :String;
function UpperCase (C :Char) :Char;
function LowerCase (C :Char) :Char;
function StrFunc (X :Real) :String;
function ValFunc (S :String) :Real;
function BinStr (LUKU :LongInt) :String;
function BinVal (BIN :String) :LongInt;
function Name (NIMI :String) :String;
function Radians (ASTEET :Real) :Real;
function LineEndX(X :Integer; PITUUS :Word; KULMA :Real) :Integer;
function LineEndY(Y :Integer; PITUUS :Word; KULMA :Real) :Integer;
function Summa (LUKU1, LUKU2 :String) :String;
const
KB_LEFT = 1;
KB_RIGHT = 2;
KB_UP = 3;
KB_DOWN = 4;
KB_ESCAPE = 5;
KB_TAB = 6;
KB_INSERT = 7;
KB_DELETE = 8;
KB_HOME = 9;
KB_UPLEFT = 9;
KB_ENDKEY = 10;
KB_DOWNLEFT = 10;
KB_PAGEUP = 11;
KB_UPRIGHT = 11;
KB_PAGEDOWN = 12;
KB_DOWNRIGHT = 12;
KB_F1 = 13;
KB_F2 = 14;
KB_F3 = 15;
KB_F4 = 16;
KB_F5 = 17;
KB_F6 = 18;
KB_F7 = 19;
KB_F8 = 20;
KB_F9 = 21;
KB_F10 = 22;
KB_F11 = 23;
KB_F12 = 24;
KB_BACKSPACE = 25;
KB_ENTER = 26;
LEFTBUTTON = 1;
RIGHTBUTTON = 2;
BOTHBUTTONS = 3;
BOTHUP = 0;
type
GraphX = 0 .. 639;
GraphY = 0 .. 479;
TextX = 1 .. 80;
TextY = 1 .. 25;
ColorType = 0 .. 15;
Bit6 = 0 .. 63;
RGB_Record = record
RED :Bit6;
GREEN :Bit6;
BLUE :Bit6;
end (* record RGB_Record *);
implementation
function ReadSpecialKey :Integer;
var
NAPPI :Char;
OK :Boolean;
begin
NAPPI := ReadKey;
case Ord(NAPPI) of
27:
begin
ReadSpecialKey := KB_ESCAPE;
OK := True;
end (* 27 *);
8:
begin
ReadSpecialKey := KB_BACKSPACE;
OK := True;
end (* 8 *);
9:
begin
ReadSpecialKey := KB_TAB;
OK := True;
end (* 9 *);
13:
begin
ReadSpecialKey := KB_ENTER;
OK := True;
end (* 13 *);
0:
begin
NAPPI := ReadKey;
case Ord(NAPPI) of
82:
begin
ReadSpecialKey := KB_INSERT;
OK := True;
end (* 82 *);
83:
begin
ReadSpecialKey := KB_DELETE;
OK := True;
end (* 83 *);
71:
begin
ReadSpecialKey := KB_HOME;
OK := True;
end (* 71 *);
79:
begin
ReadSpecialKey := KB_ENDKEY;
OK := True;
end (* 79 *);
73:
begin
ReadSpecialKey := KB_PAGEUP;
OK := True;
end (* 73 *);
81:
begin
ReadSpecialKey := KB_PAGEDOWN;
OK := True;
end (* 81 *);
75:
begin
ReadSpecialKey := KB_LEFT;
OK := True;
end (* 75 *);
77:
begin
ReadSpecialKey := KB_RIGHT;
OK := True;
end (* 77 *);
72:
begin
ReadSpecialKey := KB_UP;
OK := True;
end (* 72 *);
80:
begin
ReadSpecialKey := KB_DOWN;
OK := True;
end (* 80 *);
59:
begin
ReadSpecialKey := KB_F1;
OK := True;
end (* 59 *);
60:
begin
ReadSpecialKey := KB_F2;
OK := True;
end (* 60 *);
61:
begin
ReadSpecialKey := KB_F3;
OK := True;
end (* 61 *);
62:
begin
ReadSpecialKey := KB_F4;
OK := True;
end (* 62 *);
63:
begin
ReadSpecialKey := KB_F5;
OK := True;
end (* 63 *);
64:
begin
ReadSpecialKey := KB_F6;
OK := True;
end (* 64 *);
65:
begin
ReadSpecialKey := KB_F7;
OK := True;
end (* 65 *);
66:
begin
ReadSpecialKey := KB_F8;
OK := True;
end (* 66 *);
67:
begin
ReadSpecialKey := KB_F9;
OK := True;
end (* 67 *);
68:
begin
ReadSpecialKey := KB_F10;
OK := True;
end (* 68 *);
133:
begin
ReadSpecialKey := KB_F11;
OK := True;
end (* 133 *);
134:
begin
ReadSpecialKey := KB_F12;
OK := True;
end (* 134 *);
end (* case Ord(NAPPI) *);
end (* 0 *);
end (* case Ord(NAPPI) *);
end (* function ReadSpecialKey *);
procedure Graphics;
var
GRAPHDRIVER :Integer;
GRAPHMODE :Integer;
begin
GRAPHDRIVER := VGA;
GRAPHMODE := VGAHi;
InitGraph(GRAPHDRIVER, GRAPHMODE, 'C:\OHJELMAT\TP\BGI\EGAVGA.BGI');
end (* procedure Graphics *);
procedure Sammuta_Kursori;
const
VGA10 = $3D4;
begin
Port[VGA10+0] := 10;
Port[VGA10+1] := 16;
end (* procedure Sammuta_Kursori *);
procedure Sytyta_Kursori;
const
VGA10 = $3D4;
begin
Port[VGA10+0] := 10;
Port[VGA10+1] := 13;
end (* procedure Sytyta_Kursori *);
procedure Save_Screen(FILENAME :String);
var
F :Text;
X :Integer;
Y :Integer;
begin
Assign(F, FILENAME);
ReWrite(F);
for Y := 0 to 479 do begin
for X := 0 to 319 do begin
Write(F, Chr(GetPixel(X*2, Y)*16 + GetPixel(X*2 + 1, Y)));
end (* for X *);
end (* for Y *);
Close(F);
end (* procedure Save_Screen *);
procedure Load_Screen(FILENAME :String);
var
F :Text;
X :Integer;
Y :Integer;
COLOR :Char;
begin
Assign(F, FILENAME);
Reset(F);
for Y := 0 to 479 do begin
for X := 0 to 319 do begin
Read(F, COLOR);
PutPixel(X*2, Y, Ord(COLOR) div 16);
PutPixel(X*2 + 1, Y, Ord(COLOR) mod 16);
end (* for X *);
end (* for Y *);
Close(F);
end (* procedure Load_Screen *);
procedure Empty_keybuffer;
var
CH :Char;
begin
while KeyPressed do begin
CH := ReadKey;
end (* while KeyPressed *);
end (* procedure Empty_keybuffer *);
procedure Wait_Key;
var
CH :Char;
begin
Empty_Keybuffer;
CH := ReadKey;
end (* procedure Wait_Key *);
function Etaisyys (X1, Y1, X2, Y2 :Integer) :LongInt;
var
X :Integer;
Y :Integer;
begin
X := Abs (X2 - X1);
Y := Abs (Y2 - Y1);
Etaisyys := Round(Sqrt(X*X + Y*Y));
end (* function Etaisyys *);
function Potenssi (X, Y :Real) :Real;
begin
Potenssi := Exp(Ln(X) * Y);
end (* function Potenssi *);
function LowerCase (C :Char) :Char;
begin
case Ord(C) of
65 .. 90:
begin
LowerCase := Chr(Ord(C) + 32);
end;
142:
begin
LowerCase := 'ä';
end;
153:
begin
LowerCase := 'ö';
end;
143:
begin
LowerCase := 'å';
end;
else begin
LowerCase := C;
end;
end (* case C of *);
end (* function LowerCase *);
function Upper (S :String) :String;
var
I :Integer;
begin
for I := 1 to Length(S) do begin
S[I] := UpperCase(S[I]);
end (* for I *);
Upper := S;
end (* function Upper *);
function Lower (S :String) :String;
var
I :Integer;
begin
for I := 1 to Length(S) do begin
S[I] := LowerCase(S[I]);
end (* for I *);
Lower := S;
end (* function Lower *);
procedure DeleteFile
(NAME :String);
var
DIRINFO :SearchRec;
F :File;
begin
FindFirst(NAME, AnyFile - Directory, DIRINFO);
while DOSError = 0 do begin
Assign(F, DIRINFO.Name);
Reset(F);
Erase(F);
Close(F);
FindNext(DIRINFO);
end;
end (* procedure DeleteFile *);
procedure RenameFile (OLDNAME, NEWNAME :String);
var
DIRINFO :SearchRec;
F :File;
begin
Assign(F, OLDNAME);
Rename(F, NEWNAME);
Close(F);
end (* procedure RenameFile *);
procedure CopyFile
(SOURCEFILE :String;
TARGETFILE :String);
var
SOURCE :File;
TARGET :File;
NUMREAD :Word;
NUMWRITTEN :Word;
BUF :array [1 .. 16384] of Char;
begin
Assign(SOURCE, SOURCEFILE);
Assign(TARGET, TARGETFILE);
Reset(SOURCE, 1);
ReWrite(TARGET, 1);
if DOSError = 0 then begin
repeat
BlockRead(SOURCE, BUF, SizeOf(BUF), NUMREAD);
BlockWrite(TARGET, BUF, NUMREAD, NUMWRITTEN);
until (NUMREAD = 0) or (NUMWRITTEN <> NUMREAD);
end (* if DOSError = 0 then begin *);
Close(SOURCE);
Close(TARGET);
end (* procedure CopyFile *);
procedure Print (X, Y :Integer; S :String);
var
OLDX :Integer;
OLDY :Integer;
begin
OLDX := WhereX;
OLDY := WhereY;
GotoXY(X, Y);
Write(S);
GotoXY(OLDX, OLDY);
end (* procedure Print *);
function LineEndX(X :Integer; PITUUS :Word; KULMA :Real) :Integer;
var
RADIANS :Real;
begin
RADIANS := KULMA/360*2*Pi;
LineEndX := X + Round(Cos(RADIANS)*(PITUUS - 1));
end (* function LineEndX *);
function LineEndY(Y :Integer; PITUUS :Word; KULMA :Real) :Integer;
var
RADIANS :Real;
begin
RADIANS := KULMA/360*2*Pi;
LineEndY := Y - Round(Sin(RADIANS)*(PITUUS - 1));
end (* function LineEndY *);
function Radians (ASTEET :Real) :Real;
begin
Radians := ASTEET/360*2*Pi;
end (* function Radians *);
procedure DrawLine (X, Y :Integer; PITUUS :Word; KULMA :Real);
var
X2 :Integer;
Y2 :Integer;
RADIANS :Real;
begin
RADIANS := KULMA/360*2*Pi;
X2 := X + Round(Cos(RADIANS)*(PITUUS - 1));
Y2 := Y - Round(Sin(RADIANS)*(PITUUS - 1));
Line(X, Y, X2, Y2);
end (* procedure DrawLine *);
procedure DrawLine2 (X, Y :Integer; SADE :Word; PITUUS :Word; KULMA :Real);
var
X1 :Integer;
Y1 :Integer;
X2 :Integer;
Y2 :Integer;
RADIANS :Real;
begin
RADIANS := KULMA/360*2*Pi;
X1 := X + Round(Cos(RADIANS)*(SADE - 1));
Y1 := Y - Round(Sin(RADIANS)*(SADE - 1));
X2 := X + Round(Cos(RADIANS)*(SADE - PITUUS));
Y2 := Y - Round(Sin(RADIANS)*(SADE - PITUUS));
Line(X1, Y1, X2, Y2);
end (* procedure DrawLine2 *);
procedure Zeros (var S :String; PITUUS :Byte);
var
I :Byte;
begin
for I := 1 to PITUUS - Length(S) do begin
S := '0' + S;
end (* for I := 1 to PITUUS - Length(S) *);
end (* procedure Zeros *);
function StrFunc (X :Real) :String;
var
S :String;
begin
Str(X, S);
StrFunc := S;
end (* function StrFunc *);
function ValFunc (S :String) :Real;
var
V :LongInt;
CODE :Integer;
begin
Val(S, V, CODE);
if CODE = 0 then begin
ValFunc := V;
end
else begin
ValFunc := 0;
end (* if *);
end (* function ValFunc *);
function Summa (LUKU1, LUKU2 :String) :String;
var
TULOS :String;
MUISTI :Integer;
TEMP :Integer;
I :Integer;
begin
TULOS := '';
MUISTI := 0;
if Length(LUKU1) <> Length(LUKU2) then begin
if Length(LUKU1) > Length(LUKU2) then begin
Zeros(LUKU2, Length(LUKU1));
end
else begin
Zeros(LUKU1, Length(LUKU2));
end (* if *);
end (* if Length(LUKU1) <> Length(LUKU2) *);
for I := Length(LUKU1) downto 1 do begin
TEMP := Round(ValFunc(Copy(LUKU1, I, 1))) +
Round(ValFunc(Copy(LUKU2, I, 1))) + MUISTI;
if Length(StrFunc(TEMP)) = 2 then begin
if I > 1 then begin
MUISTI := Round(ValFunc(Copy(StrFunc(TEMP), 1, 1)));
TULOS := Copy(StrFunc(TEMP), 2, 1) + TULOS;
end
else begin
TULOS := StrFunc(TEMP) + TULOS;
end (* if *);
end
else begin
MUISTI := 0;
TULOS := StrFunc(TEMP) + TULOS;
end (* if *);
end (* for I := Length(LUKU1) downto 1 *);
Summa := TULOS;
end (* function Summa *);
function BinStr (LUKU :LongInt) :String;
var
BINAARI :String;
begin
BINAARI := '';
repeat
if LUKU mod 2 = 1 then begin
BINAARI := '1' + BINAARI;
end
else begin
BINAARI := '0' + BINAARI;
end (* if *);
LUKU := LUKU div 2;
until LUKU = 0;
BinStr := BINAARI;
end (* function BinStr *);
function BinVal (BIN :String) :LongInt;
var
I :Integer;
begin
end (* function BinVal *);
function UpperCase (C :Char) :Char;
begin
case C of
'ä':
begin
UpperCase := 'Ä';
end;
'ö':
begin
UpperCase := 'Ö';
end;
'å':
begin
UpperCase := 'Å';
end;
'Ä':
begin
UpperCase := 'Ä';
end;
'Ö':
begin
UpperCase := 'Ö';
end;
'Å':
begin
UpperCase := 'Å';
end;
else begin
UpperCase := UpCase(C);
end;
end (* case C of *);
end (* function UpperCase *);
function Name (NIMI :String) :String;
begin
while NIMI[1] = ' ' do begin
Delete(NIMI, 1, 1);
end (* while NIMI[1] = ' ' *);
end (* function Name *);
procedure LineEnd(K :PointType; PITUUS :Word; KULMA :Real;
var T :PointType);
begin
T.X := LineEndX(K.X, PITUUS, KULMA);
T.Y := LineEndY(K.Y, PITUUS, KULMA);
end (* procedure LineEnd *);
procedure Lines(K1, K2 :PointType);
begin
Line(K1.X, K1.Y, K2.X, K2.Y);
end (* procedure Lines *);
end.
