LowerDownCaseIsWhite
(* >>> LowerDounCaseIsWhite <<< ----- ----- --------------- *)
(* Nume fisier : UPDNCASE.SRC *)
(* Colectie de rutine pentru testarea caracterelor. *)
(* -------- ----- ------ ----- ----- ----------- *)
FUNCTION CapsLock (Ch: CHAR): CHAR;
(* ---- Converteste o litera mica in litera mare. --- *)
CONST
LowerCase: SET OF CHAR= ['a'..'z'];
BEGIN
IF Ch IN LowerCase THEN
CapsLock := CHR (ORD (Ch) - 32)
ELSE
CapsLock := Ch
END;
FUNCTION DownCase (Ch: CHAR): CHAR;
(* ---- Converteste o litera mare in litera mica. --- *)
CONST
UpperCase: SET OF CHAR= ['A'..'Z'];
BEGIN
IF Ch IN UpperCase THEN
DownCase := CHR (ORD (Ch) + 32)
ELSE
DownCase := Ch
END;
FUNCTION IsWhite (Ch: CHAR): BOOLEAN;
(* --- Verifica daca caracteruì apartine "spatiilor albe". --- *)
CONST
Whitespace: SET OF CHAR= [#8, #10, #12, #13, ' '];
BEGIN
IsWhite := Ch IN Whitespace
END;
Rooter
(* >>> Rooter <<< -------- ----- ------ -- *)
(* Nume fisier : ROOTER.PAS *)
(* Program demonstrativ instructiuni simple. *)
(* -------- ----- ------ ----- ----- ------- *)
PROGRAM Rooter;
VAR
r, s: REAL;
BEGIN
WriteLn ('>> Determinarea radacinii patrate a unui numar <<'); WriteLn;
Write ('>> Introduceti numarul : '); ReadLn (r);
S := Sqrt (r);
WriteLn (' Radacina patrata a lui ', r:10:5, ' este ', s:10:5, '.');
ReadLn
END.
BetterRooter
(* >>> BetterRooter <<< ----- ----- --------- ----- ----- *)
(* Nume fisier : ROOTER2.PAS *)
(* Program demonstrativ cu instructiuni compuse. *)
(* -------- ----- ------ ----- ----- ------- *)
PROGRAM BetterRooter;
VAR
r, s: REAL;
BEGIN
WriteLn('>> Determinarea radacinii patrate a unui numar <<'); WriteLn;
r := 1;
WHILE r <> 0 DO
BEGIN
Write('>> Introduceti numarul (0 pentru terminare) : '); ReadLn(r);
IF r > 0 THEN
BEGIN
S := Sqrt (r);
Write(' Radacina patrata a lui ', r:10:5);
WriteLn(' este ', s:10:5, '.'); WriteLn
END
ELSE
IF r < 0 THEN
BEGIN
WriteLn('>> Eroarea !<< Nu se calculeaza radacina');
WriteLn(' patrata din numere negative.'); WriteLn
END
END;
WriteLn('>> S-a terminat determinarea radacinilor patrate ...')
END.
IsMono
(* >>> IsMono <<< -------- ----- ------ -------- *)
(* Nume fisier : ISMONO.PAS *)
(* Programul testeaza daca display-ul instalat in sistem *)
(* este monocrom sau color, folosind functia Monochrome. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM IsMono;
BEGIN
IF Monochrome THEN
Halt (5)
ELSE
Halt (0)
END.
BoxTest
(* >>> BoxTest <<< -------- ----- ------ ----- *)
(* Nume fisier : BOXTEST.PAS *)
(* Program demonstrativ - caractere grafice. *)
(* -------- ----- ------ ----- ----- ----------- *)
PROGRAM BoxTest;
USES CRT;
TYPE
GrafRec= RECORD
ULCorner,
URCorner,
LLCorner,
LRCorner,
HBar,
VBar,
LineCross,
TDown,
TUp,
TRight,
TLeft: STRING[4]
END;
String80= STRING[80];
VAR
GrafChars: GrafRec;
X, Y,
Width,
Height: INTEGER;
PROCEDURE DefineChars (VAR GrafChars: GrafRec);
BEGIN
WITH GrafChars DO
BEGIN
ULCorner := CHR (201);
URCorner := CHR (187);
LLCorner := CHR (200);
LRCorner := CHR (188);
HBar := CHR (205);
VBar := CHR (186);
LineCross := CHR (206);
TDown := CHR (203);
TUp := CHR (202);
TRight := CHR (185);
TLeft := CHR (204)
END
END;
PROCEDURE MakeBox (X, Y, Width, Height: INTEGER; GrafChars: GrafRec);
VAR
i, j: INTEGER;
BEGIN
IF X < 0 THEN
X := (80 - Width) DIV 2;
WITH GrafChars DO
BEGIN
GoToXY (X, Y);
Write (ULCorner);
FOR i := 3 TO Width DO
Write (HBar);
Write (URCorner);
GoToXY (X, (Y + Height) - 1);
Write (LLCorner);
FOR i := 3 TO Width DO
Write (HBar);
Write (LRCorner);
FOR i := 1 TO Height - 2 DO
BEGIN
GoToXY (x, Y + i); Write (VBar);
GoToXY ((X + Width) - 1, Y + i); Write (VBar)
END
END
END;
BEGIN
Randomize;
ClrScr;
DefineChars(GrafChars);
WHILE NOT KeyPressed DO
BEGIN
X := Random(72);
Y := Random(21);
REPEAT
Width := Random(80 - X)
UNTIL Width > 1;
REPEAT
Height := Random 25 - Y)
UNTIL Height > 1;
MakeBox(X, Y, Width, Height, GrafChars);
Delay(500)
END
END.
ShellSort
(* >>> ShellSort <<< -------- ----- ------ -- *)
(* Nume fisier : SHELSORT.SRC *)
(* Rutina de sortare folosind algoritmul Shell. *)
(* -------- ----- ------ ----- ----- ---------- *)
PROCEDURE ShellSort(VAR SortBuf: KeyArray; Recs: INTEGER);
VAR
Spread,
i, j, k, l: INTEGER;
PROCEDURE KeySwap(VAR RR, SS: KeyRec);
VAR
T: KeyRec;
BEGIN
T := RR;
RR := SS;
SS := T
END;
BEGIN
Spread := Recs DIV 2;
WHILE Spread > 0 DO
BEGIN
FOR I := Spread + 1 TO Recs DO
BEGIN
J := I - Spread;
WHILE J > 0 DO
BEGIN
L := J + Spread;
IF SortBuf[J].KeyData <= SortBuf[L].KeyData THEN
J := 0
ELSE
KeySwap (SortBuf[J], SortBuf[L]);
J := J - Spread
END
END;
Spread := Spread DIV 2
END
END;
PushPop
(* >>> PushPop <<< -------- ----- ------ ------ *)
(* Nume fisier : PUSHPOP.PAS *)
(* Program demonstrativ pentru recursivitate. *)
(* -------- ----- ------ ----- ----- ------------ *)
PROGRAM PushPop;
CONST
Levels= 5;
VAR
Depth: INTEGER;
PROCEDURE Dive (VAR Depth: INTEGER);
BEGIN
WriteLn ('Push !');
WriteLn ('Adincimea dv. este acum : ', Depth);
Depth := Depth + 1;
IF Depth <= Levels THEN
Dive (Depth);
WriteLn ('Pop !')
END;
BEGIN
Depth := 1;
Dive (Depth)
END.
Factorial
(* >>> Factorial <<< -------- ----- ------ ----- *)
(* Nume fisier : FACTRIAL.SRC *)
(* Rutina recursiva pentru calculul factorialului. *)
(* -------- ----- ------ ----- ----- ------------- *)
FUNCTION Factorial (N: INTEGER): INTEGER;
BEGIN
IF N > 1 THEN
Factorial := N * Factorial (N - 1)
ELSE
Factorial := 1
END;
QuickSort
(* >>> QuickSort <<< -------- ----- ------ --- *)
(* Nume fisier : QUIKSORT.SRC *)
(* Rutina de sortare folosind algoritmul Quick Sort. *)
(* -------- ----- ------ ----- ----- ----------- *)
PROCEDURE QuickSort (VAR SortBuf: KeyArray; Recs: String30);
PROCEDURE KeySwap (VAR RR, SS: KeyRec);
VAR
T: KeyRec;
BEGIN
T := RR;
RR := SS;
SS := T
END;
PROCEDURE DoSort (Low, High: INTEGER);
VAR
I, J: INTEGER;
Pivot: KeyRec;
BEGIN
IF Low < High THEN
BEGIN
I := Low; J := High;
Pivot := SortBuf[J];
REPEAT
WHILE (I < J) AND (SortBuf[I].KeyData <= Pivot.KeyData) DO
INC (I);
WHILE (J > I) AND (SortBuf[J].KeyData >= Pivot.KeyData) DO
DEC (J);
IF I < J THEN
KeySwap (SortBuf[I], SortBuf[J])
UNTIL I >= J;
KeySwap (SortBuf[I], SortBuf[High]);
IF (I - Low) < (High - I) THEN
BEGIN
DoSort (Low, I - 1);
DoSort (I + 1, High)
END
ELSE
BEGIN
DoSort (I + 1, High);
DoSort (Low, I + 1)
END
END
END;
BEGIN
DoSort (1, Recs)
END.
SortTest
(* >>> SortTest <<< -------- ----- ------ ---- *)
(* Nume fisier : SORTTEST.PAS *)
(* Program demonstrativ - sortarea datelor. *)
(* -------- ----- ------ ----- ----- ----------- *)
PROGRAM SortTest;
USES CRT, DOS, BoxStuff;
CONST
HighLite= TRUE;
CR= TRUE;
NoHighLite= FALSE;
NoCR= FALSE;
GetInteger= FALSE;
Numeric= TRUE;
CapsLock= TRUE;
Shell= TRUE;
Quick= FALSE;
TYPE
String255= STRING[255]
String80= STRING[80];
String30= STRING[30];
KeyRec= RECORD
Ref: INTEGER;
KeyData: String30
END;
KeyArray= ARRAY[0..500] OF KeyRec;
KeyFile= FILE OF KeyRec;
VAR
I, J¬ IVal,
Error: INTEGER;
R: REAL;
Ch: CHAR;
Response: String80;
Escape: BOOLEAN;
WorkArray: KeyArray;
Randoms: KeyFile;
PROCEDURE GenerateRandomKeyFile (KeyQuantity: INTEGER);
VAR
WorkKey: KeyRec;
I, J: INTEGER;
BEGIN
Assign (Randoms, 'RANDOMS.KEY');
Rewrite (Randoms);
FOR I := 1 TO KeyQuantity DO
BEGIN
FillChar (WorkKey, SizeOf (WorkKey), 0);
FOR J := 1 TO SizeOf (WorkKey, KeyData) - 1 DO
WorkKey.KeyData[J] := CHR (Pull (65, 91));
WorkKey.KeyData[0] := CHR (30);
Write (Randoms, WorkKey)
END;
Close (Randoms)
END;
PROCEDURE DisplayKeys;
VAR
WorkKey: KeyRec;
BEGIN
Assign (Randoms, 'RANDOMS.KEY');
Reset (Randoms);
Window (25, 13, 70, 22);
GoToXY (1, 1);
WHILE NOT EOF (Randoms) DO
BEGIN
Read (Randoms, WorkKey);
IF NOT EOF (Randoms) THEN
WriteLn (WorkKey.KeyData)
END;
Close (Randoms);
WriteLn;
WriteLn (' >>>> Apasati <CR> <<<<');
ReadLn;
ClrScr;
Window (1, 1, 80, 25)
END;
PROCEDURE DoSort (Shell: BOOLEAN);
VAR
Counter: INTEGER;
BEGIN
Assign (Randoms, 'RANDOMS.KEY'); Reset (Randoms);
Counter := 1;
WriteAt (20, 15, NoHighLite, NoCR, 'Incarcare ...');
WHILE NOT EOF (Randoms) DO
BEGIN
Read (Randoms, WorkArray[Counter];
Counter := Succ (Counter)
END;
Close (Randoms);
Write ('... sortare ...');
IF Shell THEN
ShellSort (WorkArray, Counter - 1)
ELSE
QuickSort (WorkArray, Counter - 1);
Write ('... gata');
WriteAt (-1, 21, NoHighLite, NoCR, '>>> Tastati <CR> <<<');
ReadLn;
ClearRegion (2, 15, 77, 22)
END;
BEGIN
ClrScr; CursorOff;
MakeBox (1, 1, 80, 24, GrafChars);
WriteAt (24, 3, HighLite, NoCr, 'Sortare - COMPLETE TURBO PASCAL V5.0');
REPEAT
WriteAt(25,5,NoHighLite,NoCR,'[1] Generare fisier cu chei aleatoare');
WriteAt(25,6,NoHighLite,NoCR,'[2] Afisare fisier cu chei aleatoare');
WriteAt(25,7,NoHighLite,NoCR,'[3] Sortare cu algoritmul Shell');
WriteAt(25,8,NoHighLite,NoCR,'[4] Sortare cu algoritmul Quick Sort');
WriteAt (30, 10, NoHighLite, NoCR,'Introduceti 1 - 4 : ');
Response := ''; IVal := 0;
GetString (46, 10, Response, 2, CapsLock, Numeric,
GetInteger, R, IVal, Error, Escape);
CASE IVal OF
0:;
1: GenerateRandomKeyFile (250);
2: DisplayKeys;
3: DoSort (Shell);
4: DoSort (Quick)
END
UNTIL (IVal = 0) OR Escape;
CursorOn
END.
StripWhite
(* >>> StripWhite <<< -------- ----- ------ -- *)
(* Nume fisier : STRIPWHT.SRC *)
(* Rutine elimina caracterele "spatii albe" din fata *)
(* unui sir. *)
(* -------- ----- ------ ----- ----- ----------- *)
PROCEDURE StripWhite (VAR Target: STRING);
CONST
Whitespace: SET OF CHAR= [#8, #10, #12, #13, ' '];
BEGIN
WHILE (Length (Target) > 0) AND (Target[1] IN Whitespace) DO
Delete (Target, 1, 1)
END;
GetExt
(* >>> GetExt <<< -------- ----- ------ ------ *)
(* Nume fisier : GETEXT.SRC *)
(* Rutina returneaza extensia unui fisier. *)
(* -------- ----- ------ ----- ----- ----------- *)
FUNCTION GetExt (FileName: STRING): STRING;
VAR
DotPos: INTEGER;
BEGIN
DotPos := Pos ('.', FileName);
IF DotPos = 0 THEN
GetExt := ''
ELSE
GetExt := Copy (FileName, DotPos, (Length (FileName) - DotPos) + 1)
END;
Evaluator
(* >>> Evaluator <<< -------- ----- ------ ---- *)
(* Nume fisier : EVALUTOR.PAS *)
(* Program demonstrativ - conversie sir numeric in *)
(* valoare numerica. *)
(* -------- ----- ------ ----- ----- ------------ *)
PROGRAM Evaluator;
VAR
SST: STRING;
R: REAL;
Result: INTEGER;
BEGIN
REPEAT
Write ('Introduceti un numar sub forma unui sir : ');
ReadLn (SST);
IF Length (SST) > 0 THEN
BEGIN
VAL (SST, R, Result);
IF Result <> 0 THEN
Write('>> Nu se poate evalua sirul. <<');
Writeln('Caracterul #', Result, ' este eronat.')
ELSE
WriteLn '>> Echivalentul numeric al sirului este : ', R:18:10)
END;
Writeln
UNTIL Length (SST) = 0
END.
GetString
(* >>> GetString <<< -------- ----- ------ ---- *)
(* Nume fisier : GETSTRIN.SRC *)
(* Rutina generalizata de introducere a sirurilor. *)
(* Aceasta prezinta cimpul intre doua bare verticale. *)
(* -------- ----- ------ ----- ----- ------------ *)
PROCEDURE GetString (X, Y: INTEGER;
VAR XString: String80;
MaxLen: INTEGER;
CapsLock,
Numeric,
GetReal: BOOLEAN;
VAR RValue: REAL;
VAR IValue: INTEGER;
VAR Error: INTEGER;
VAR Escape: BOOLEAN);
VAR
I, J: INTEGER;
Ch: CHAR;
Cursor: CHAR;
Dot: CHAR;
BLength: BYTE;
Clearit: String80;
Worker: String80;
Printables: SET OF CHAR;
Lowercase: SET OF CHAR;
Numerics: SET OF CHAR;
CR: BOOLEAN;
BEGIN
Printables := [' '..'}']; Lowercase := ['a'..'z'];
IF GetReal THEN Numerics := ['-', '.', '0'..'9', 'E', 'e']
ELSE Numerics := ['-', '0'..'9'];
Cursor := '_'; Dot := '.';
FillChar (Clearit, SizeOf (Clearit), '.');
Clearit[0] := Chr (MaxLen);
IF Numeric THEN
IF (GetReal AND (RValue = 0.0)) OR
(NOT GetReal AND (IValue = 0)) THEN XString := ''
ELSE
IF GetReal THEN Str (RValue:MaxLen, XString)
ELSE Str(IValue:MaxLen, XString);
IF Length (XString) > MaxLen THEN XString[0] := Chr(MaxLen);
GoToXY(X, Y); Write ('|', Clearit, '|');
GoToXY(X + 1, Y); Write (XString);
IF Length(XString) < MaxLen THEN
BEGIN GoToXY(X + Length (XString) + 1, Y); Write(Cursor) END;
Worker := XString;
REPEAT
WHILE NOT KeyPressed DO BEGIN END;
Ch := ReadKey;
IF Ch IN Printables THEN
IF Length(Worker) >= MaxLen THEN UhUh
ELSE
IF Numeric AND (NOT (Ch IN Numerics)) THEN UhUh
ELSE
BEGIN
IF Ch IN Lowercase THEN
IF CapsLock THEN Ch := Chr(Ord (Ch) - 32);
Worker := CONCAT(Worker, Ch);
GoToXY(X + 1, Y); Write(Worker);
IF Length(Worker) < MaxLen THEN Write (Cursor)
END
ELSE
CASE Ord(Ch) OF
8, 127: IF Length(Worker) <= 0 THEN UhUh
ELSE
BEGIN
Delete(Worker, Length(Worker), 1);
GoToXY(X + 1, Y); Write(Worker, Cursor);
IF Length(Worker) < MaxLen - 1 THEN Write(Dot)
END;
13: CR := TRUE;
24: BEGIN
GoToXY(X + 1, Y); Write(Clearit);
Worker := ''
END;
27: Escape := TRUE;
ELSE UhUh
END;
UNTIL CR OR Escape;
GoToXY(X + 1, Y); Write(Clearit);
GoToXY(X + 1, Y); Write(Worker);
IF CR THEN
BEGIN
XString := Worker;
IF Numeric THEN
CASE GetReal OF
TRUE: Val(Worker, RValue, Error);
FALSE: Val(Worker, IValue, Error)
END
ELSE
BEGIN
RValue := 0.0;
IValue := 0
END
END
END;
Screen
(* >>> Screen <<< -------- ----- ------ ------ *)
(* Nume fisier : SCREEN2.PAS *)
(* Program demonstrativ - ecran de introducere. *)
(* -------- ----- ------ ----- ----- ----------- *)
PROGRAM Screen;
USES CRT, DOS, BoxStuff;
CONST
CapsLock= TRUE;
NoCapsLock= False;
Numeric= TRUE;
NonNumeric= FALSE;
TYPE
String80= STRING[80];
String30= STRING[30];
String6= STRING[6];
String4= STRING[4];
String3= STRING[3];
AdapterType= (None, MDA, CGA, EGAMono, EGAColor,
VGAMono, VGAColor, MCGAMono, MCGAColor);
MAPRec= RECORD
Name,
Address,
City: String30;
State: String3;
Zip: String6
END;
VAR
Ch: CHAR;
CurrentRecord: MAPRec;
Edit,
Quit,
Escape: BOOLEAN;
Width,
Height, I, J: INTEGER;
R: REAL;
PROCEDURE GetScreen (VAR ScreenData: MAPRec;
Edit: BOOLEAN;
VAR Escape: BOOLEAN);
BEGIN
MakeBox (1, 1, 79, 20, GrafChars);
IF NOT Edit THEN
WITH ScreenData DO
BEGIN
Name := '';
Address := '';
City := '';
State := '';
Zip := ''
END;
GoToXY (23, 2);
WriteLn ('>> Ecran pentru introducere date personale <<');
With ScreenData DO
BEGIN
GoToXY (9, 7);
Write ('>> Nume : |..............................|');
GoToXY (9, 9);
Write ('>> Adresa : |..............................|');
GoToXY (9, 11);
Write ('>> Localitate : |..............................|');
GoToXY (9, 13);
Write ('>> Judet: |...|');
GoToXY (9, 15);
Write ('>> Cod postal: |......|');
IF Edit THEN
WITH ScreenData DO
BEGIN
GoToXY (26, 7); Write (Name);
GoToXY (26, 9); Write (Address);
GoToXY (26, 11); Write (City);
GoToXY (26, 13); Write (State);
GoToXY (26, 15); Write (Zip)
END;
GetString (25, 7, Name, 30, NoCapsLock, NonNumeric,
FALSE, R, I, J, Escape);
IF NOT Escape THEN
GetString (25, 9, Address, 30, NoCapsLock, NonNumeric,
FALSE, R, I, J, Escape);
IF NOT Escape THEN
GetString (25, 11, City, 30, NoCapsLock, NonNumeric,
FALSE, R, I, J, Escape);
IF NOT Escape THEN
GetString (25, 13, State, 30, NoCapsLock, NonNumeric,
FALSE, R, I, J, Escape);
IF NOT Escape THEN
GetString (25, 15, Zip, 30, NoCapsLock, NonNumeric,
FALSE, R, I, J, Escape);
END
END;
BEGIN
Edit := FALSE;
CursorOff;
REPEAT
ClrScr;
GetScreen (CurrentRecord, Edit, Escape);
IF Escape THEN
Quit := TRUE
ELSE
BEGIN
Quit := FALSE; GoToXY(1, 22);
Write ('>> Rezumat : ');
WITH CurrentRecord DO
BEGIN
Write (Name, '/', Address, '/', Zip);
GoToXY (1, 23); Write ('>> Corect (D/N) ? ');
IF Da THEN Edit := FALSE
ELSE Edit := TRUE
END
END
UNTIL Quit;
ClrScr;
CursorOn
END.
ReverseName
(* >>> ReverseName <<< -------- ----- ------ -- *)
(* Nume fisier : RVRSNAME.SRC *)
(* Rutina inverseaza numele cu prenumele. *)
(* -------- ----- ------ ----- ----- ------------ *)
PROCEDURE ReverseName (VAR Name: STRING);
VAR
TName: STRING;
BEGIN
IF Pos ('*', Name) <> 0 THEN
BEGIN
TName := Copy (Name, 1, (Pos ('*', Name) - 1));
Delete (Name, 1, Pos ('*', Name);
Name := Concat (Name, ' ', TName)
END
END;
ForceCase
(* >>> ForceCase <<< -------- ----- ------ ---- *)
(* Nume fisier : FRCECASE.SRC *)
(* Rutina asigura conversia literelor in mari sau mici, *)
(* in functie de valoarea parametrului Up. *)
(* -------- ----- ------ ----- ----- ------------ *)
FUNCTION ForceCase (Up: BOOLEAN; Target: STRING): STRING;
CONST
UpperCase: SET OF CHAR= ['A'..'Z'];
LowerCase: SET OF CHAR= ['a'..'z'];
VAR
I: INTEGER;
BEGIN
IF Up THEN
FOR i := 1 TO LENGTH (Target) DO
IF Target[i] IN LowerCase THEN
target[i] := UpCase (Target[i])
ELSE
ELSE
FOR i := 1 TO LENGTH (Target) DO
IF Target[i] IN Uppercase THEN
Target[i] := CHR (ORD (Target[i]) + 32);
ForceCase := Target
END;
Power
(* >>> Power <<< -------- ----- ------ -------- *)
(* Nume fisier : POWER.SRC *)
(* Rutina pentru ridicarea la puteri reale. *)
(* -------- ----- ------ ----- ----- ------------ *)
FUNCTION Power (Mantissa, Exponent: REAL): REAL;
BEGIN
Power := Exp (Ln (Mantissa) * Exponent)
END;
Pull
(* >>> Pull <<< -------- ----- ------ -------- *)
(* Nume fisier : PULL.SRC *)
(* Rutina returneaza un numar aleator cuprins intr-un *)
(* interval dat. *)
(* -------- ----- ------ ----- ----- ----------- *)
FUNCTION Pull (Low, High: INTEGER): INTEGER;
VAR
I: INTEGER;
BEGIN
REPEAT
I := Random (High + 1)
UNTIL I >= Low;
Pull := I
END;
Rollem
(* >>> Rollem <<< -------- ----- ------ ----- *)
(* Nume fisier : ROLLEM.PAS *)
(* Program demonstrativ numere aleatoare. *)
(* -------- ----- ------ ----- ----- ---------- *)
PROGRAM Rollem;
USES CRT, BoxStuff;
CONST
DiceFaces: ARRAY[0..5, 0..2] OF STRING[5]=
((' ', ' o ', ' '),
('o ', ' ', ' o'),
(' o', ' o ', 'o '),
('o o', ' ', 'o o'),
('o o', ' o ', 'o o'),
('o o o', ' ', 'o o o'));
TYPE
String80= STRING[80];
VAR
Dice, Toss¬ I,
DiceX¬ X¬ Y,
Width, Height: INTEGER;
Quit: BOOLEAN;
Ch: CHAR;
Banner: String80;
PROCEDURE Roll (X, Y: INTEGER;
NumberOfDice: INTEGER;
VAR Toss: INTEGER);
VAR
I, J¬ Throw¬ XOffset: INTEGER;
BEGIN
IF (NumberOfDice * 9) + X >= 80 THEN
NumberOfDice := (80 - X) DIV 9;
FOR I := 1 TO NumberOfDice DO
BEGIN
XOffset := (I + 1) * 9;
MakeBox (X + XOffset, Y, 7, 5, GrafChars);
Throw := Random (6);
FOR J := 0 TO 2 DO
BEGIN
GoToXY (X + 1 + XOffset, Y + 1 + J);
Write (DiceFaces [Throw, j])
END
END
END;
BEGIN
Randomize;
ClrScr;
Quit := FALSE;
Banner := 'GONNA Roll THE BONES!';
MakeBox(-1, 1, Length(Banner) + 4, 3, GrafChars);
GoToXY (80 - Length (Banner)) DIV 2, 2); Write(Banner);
REPEAT
REPEAT
FOR I := 6 TO 18 DO
BEGIN
GoToXY (1, I); ClrEol
END;
GoToXY (1, 6); Write ('>> Cite zaruri vreti in acest joc : ');
ReadLn (Dice);
IF Dice = 0 THEN
Quit := TRUE
ELSE
IF (Dice < 1) OR (Dice > 5) THEN
BEGIN
GoToXY(0, 23); Write ('>> Numarul corect este intre 1 si 5 <<')
END
UNTIL (Dice >= 0) AND (Dice <= 5);
GoToXY (0, 16); ClrEol;
IF NOT Quit THEN
BEGIN
DiceX := (80 - (9 * Dice)) DIV 2;
REPEAT
GoToXY(1, 16); ClrEol;
Roll(DiceX, 9, Dice, Toss);
GoToXY(1, 16); Write('>> Jucati din nou (Y/N) : '); ReadLn(Ch)
UNTIL NOT (Ch IN ['Y', 'y']);
GoToXY (1, 18); Write ('>>Jucati din nou (Y/N) : '); ReadLn(Ch);
IF NOT (Ch IN ['Y', 'y']) THEN
Quit := TRUE
END
UNTIL Quit
END.
Beep
(* >>> Beep <<< -------- ----- ------ -------- *)
(* Nume fisier : BEEP.SRC *)
(* Rutina de avertizare
(* -------- ----- ------ ----- ----- ----------- *)
PROCEDURE Beep;
VAR
I: INTEGER;
BEGIN
FOR I := 1 TO 3 DO
BEGIN
Sound (800);
Delay (50);
Sound (500);
Delay (50)
END;
NoSound
END;
UhUh
(* >>> UhUh <<< -------- ----- ------ --------- *)
(* Nume fisier : UHUH.SRC *)
(* Rutina de avertizare
(* -------- ----- ------ ----- ----- ------------ *)
PROCEDURE UhUh;
VAR
I: INTEGER;
BEGIN
FOR I := 1 TO 2 DO
BEGIN
Sound (50);
Delay (100);
NoSound;
Delay (50)
END
END;
SendMorse
(* >>> SendMorse <<< -------- ----- ------ ----- *)
(* Nume fisier : SENDMORS.SRC *)
(* Rutina converteste un text intr-un cod morse audibil, *)
(* cu o frecventa si viteza stabilita. Textul este transmis *)
(* rutinei sub forma unui sir de caractere. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROCEDURE SendMorse(PlainText: STRING; ToneFrequency, CodeSpeed: INTEGER);
VAR
I, DitLength,
ToneLength: INTEGER;
CodeChar: STRING;
BlendNextTwo: BOOLEAN;
PROCEDURE Morse (CodeChar: STRING);
(* -------- ----- ------ ----- ----- ---------- *)
(* Rutina converteste textul codificat, sub forma de *)
(* puncte si linii, in sunete cu durate corespunzatoare. *)
(* -------- ----- ------ ----- ----- ---------- *)
VAR
I: INTEGER;
BEGIN
FOR I := 1 TO Length (CodeChar) DO
IF CodeChar[I] IN ['.', '-'] THEN
BEGIN
IF CodeChar[I] = '.' THEN ToneLength := DitLength
ELSE ToneLength := DitLength * 3;
Sound (ToneFrequency); Delay (ToneLength);
NoSound; Delay (DitLength)
END
END;
BEGIN
BlendNextTwo := FALSE;
DitLength := Round ((1.2 / CodeSpeed) * 1000.0);
FOR I := 1 TO Length (PlainText) DO
IF PlainText[I] = '*' THEN BlendNextTwo := TRUE
ELSE
BEGIN
PlainText[I] := UpCase (PlainText[I]);
CASE PlainText[I] OF
'A': CodeChar := '.-';
'B': CodeChar := '-...';
'C': CodeChar := '-.-.';
'D': CodeChar := '-..';
'E': CodeChar := '.';
'F': CodeChar := '..-.';
'G': CodeChar := '--.';
'H': CodeChar := '....';
'I': CodeChar := '..';
'J': CodeChar := '.---';
'K': CodeChar := '-.-';
'L': CodeChar := '.-..';
'M': CodeChar := '--';
'N': CodeChar := '-.';
'O': CodeChar := '---';
'P': CodeChar := '.--.';
'Q': CodeChar := '--.-';
'R': CodeChar := '.-.';
'S': CodeChar := '...';
'T': CodeChar := '-';
'U': CodeChar := '..-';
'V': CodeChar := '...-';
'W': CodeChar := '.--';
'X': CodeChar := '-..-';
'Y': CodeChar := '--..';
'Z': CodeChar := '--..';
'1': CodeChar := '.----';
'2': CodeChar := '..---';
'3': CodeChar := '...--';
'4': CodeChar := '....-';
'5': CodeChar := '.....';
'6': CodeChar := '-....';
'7': CodeChar := '--...';
'8': CodeChar := '---..';
'9': CodeChar := '----.';
'0': CodeChar := '-----';
'?': CodeChar := '..--..';
'.': CodeChar := '.-.-.-';
',': CodeChar := '--..--';
'/': CodeChar := '-..-.';
'$': CodeChar := '...-..-';
'-': CodeChar := '-....-';
ELSE CodeChar := ''
END;
Morse (CodeChar);
IF NOT BlendNextTwo THEN Delay (DitLength * 2);
BlendNextTwo := FALSE
END
END;
MorseTest
(* >>> MorseTest <<< -------- ----- ------ ---- *)
(* Nume fisier : MORSETEST.PAS *)
(* Program demonstrativ - conversie morse. *)
(* -------- ----- ------ ----- ----- ------------ *)
PROGRAM MorseTest;
USES CRT;
TYPE
String80= STRING[80];
VAR
SendString: String80;
SendSpeed: INTEGER;
BEGIN
ClrScr;
Write (' Viteza de transmitere : ');
ReadLn (SendSpeed);
WriteLn;
WriteLn;
Write (' Textul de transmis : ');
Readln (SendString);
SendMorse (SendString, 850, SendSpeed)
END.
BoxStuff
(* >>> BoxStuff <<< -------- ----- ------ -- *)
(* Nume fisier : BOXSTUFF.PAS *)
(* Biblioteca de rutine pentru "casete" de text. *)
(* -------- ----- ------ ----- ----- --------- *)
UNIT BoxStuff;
INTERFACE
USES CRT;
TYPE
GrafRec= RECORD
ULCorner, URCorner,
LLCorner, LRCorner,
HBar, VBar,
LineCross,
TDown, TUp,
TRight, TLeft: STRING[4]
END;
VAR
GrafChars: GrafRec;
PROCEDURE MakeBox (X, Y, Width, Height: INTEGER; GrafChars: GrafRec);
IMPLEMENTATION
PROCEDURE DefineChars (VAR GrafChars: GrafRec);
(* -------- ----- ------ ----- ----- ----------- *)
(* Rutina locala apelata in partea de initializare a *)
(* unit-ului si este folosita pentru atribuirea valorilor *)
(* cimpurilor din GrafChars. *)
(* -------- ----- ------ ----- ----- ----------- *)
BEGIN
WITH GrafChars DO
BEGIN
ULCorner := CHR (201); URCorner := CHR (187);
LLCorner := CHR (200); LRCorner := CHR (188);
HBar := CHR (205); VBar := CHR (186);
LineCross := CHR (206);
TDown := CHR (203); TUp := CHR (202);
TRight := CHR (185); TLeft := CHR (204)
END
END;
PROCEDURE MakeBox (X, Y, Width, Height: INTEGER; GrafChars: GrafRec);
(* -------- ----- ------ ----- ----- -------- *)
(* Rutina asigura desenarea casetei in functie de *)
(* valorile transmise. *)
(* -------- ----- ------ ----- ----- -------- *)
VAR
i, j: INTEGER;
BEGIN
IF X < 0 THEN
X := (80 - Width) DIV 2;
WITH GrafChars DO
BEGIN
GoToXY (X, Y); Write (ULCorner);
FOR i := 3 TO Width DO
Write (HBar);
Write (URCorner);
GoToXY (X, (Y + Height) - 1);
Write (LLCorner);
FOR i := 3 TO Width DO
Write (HBar);
Write (LRCorner);
FOR i := 1 TO Height - 2 DO
BEGIN
GoToXY (X, Y + i); Write (VBar);
GoToXY ((X + Width) - 1, Y + i); Write (VBar)
END
END
END;
BEGIN
DefineChars (GrafChars)
END.
BoxTest2
(* >>> BoxTest2 <<< -------- ----- ------ -- *)
(* Nume fisier : BOXTEST2.PAS *)
(* Program demonstrativ pentru unit-ul BoxStuff. *)
(* -------- ----- ------ ----- ----- --------- *)
PROGRAM BoxTest2;
USES CRT, BoxStuff;
TYPE
String80= STRING[80];
CONST
EscKey= #27;
VAR
X, Y, J,
Width,
Height: INTEGER;
Ch: CHAR;
BEGIN
FOR J := 0 TO 5 DO
BEGIN
ClrScr;
X := 10 + J * 2;
Y := 6 - J;
Width := 20 + J * 5;
Height := 10 + J;
MakeBox (X, Y, Width, Height, GrafChars);
REPEAT UNTIL KeyPressed;
Ch := ReadKey
END
END.
Mouse
(* >>> Mouse <<< -------- ----- ------ -- *)
(* Nume fisier : MOUSE.PAS *)
(* Rutine pentru lucru cu mouse-ul. *)
(* -------- ----- ------ ----- ----- ------ *)
UNIT Mouse;
INTERFACE
USES DOS;
VAR
ButtonCount: INTEGER;
FUNCTION IsLogitechMouse: BOOLEAN;
PROCEDURE ResetMouse;
PROCEDURE PointerOn;
PROCEDURE PointerOff;
PROCEDURE PollMouse (VAR x, y: WORD; VAR Left, Center, Right: BOOLEAN);
PROCEDURE PointerToXY (x, y: WORD);
PROCEDURE SetColumnRange (High, Low: WORD);
PROCEDURE SetRowRange (High, Low: WORD);
IMPLEMENTATION
VAR
M1, M2, M3, M4: WORD;
PROCEDURE MouseCall (VAR M1, M2, M3, M4: WORD);
VAR
Regs: Registers;
BEGIN
WITH Regs DO
BEGIN
AX := M1; BX := M2;
CX := M3; DX := M4
END;
Intr (51, Regs);
WITH Regs DO
BEGIN
M1 := AX; M2 := BX;
M3 := CX; M4 := DX
END
END;
FUNCTION NumberOfMouseButtons: INTEGER;
BEGIN
M1 := 0;
MouseCall (M1, M2, M3, M4);
NumberOfMouseButtons := M2
END;
FUNCTION MouseIsInstalled: BOOLEAN;
TYPE
BytePtr= ^BYTE;
VAR
TestVector: BytePtr;
BEGIN
GetIntVec (51, POINTER (TestVector));
IF (TestVector = NIL) OR (TestVector^ = $CF) THEN
MouseIsInstalled := FALSE
ELSE MouseIsInstalled := TRUE
END;
FUNCTION IsLogitechMouse;
TYPE
Signature= ARRAY[0..13] OF CHAR;
SigPtr= ^Signature;
CONST
LogitechSig: Signature= 'LOGITECH MOUSE';
VAR
TestVector: SigPtr;
l: LONGINT;
BEGIN
GetIntVec (51, POINTER (TestVector));
LONGINT (TestVector) := LONGINT (TestVector) + 16;
IF TestVector^ = LogitechSig THEN IsLogitechMouse := TRUE
ELSE IsLogitechMouse := FALSE
END;
PROCEDURE ResetMouse;
BEGIN
M1 := 0;
MouseCall (M1, M2, M3, M4)
END;
PROCEDURE PointerOn;
BEGIN
M1 := 1;
MouseCall (M1, M2, M3, M4)
END;
PROCEDURE PointerOff;
BEGIN
M1 := 2;
MouseCall (M1, M2, M3, M4)
END;
PROCEDURE PollMouse (VAR X, Y: WORD; VAR Left, Center, Right: BOOLEAN);
BEGIN
M1 := 3;
MouseCall (M1, M2, M3, M4);
X := M3; Y := M4;
IF (M2 AND $01) = $01 THEN Left := TRUE ELSE Left := FALSE;
IF (M2 AND $02) = $02 THEN Right := TRUE ELSE Right := FALSE;
IF (M2 AND $04) = $04
END;
PROCEDURE PointerToXY (X, Y: WORD);
BEGIN
M1 := 4; M3 := X; M4 := Y;
MouseCall (M1, M2, M3, M4)
END;
PROCEDURE SetColumnRange (High, Low: WORD);
BEGIN
M1 := 7; M3 := Low; M4 := High;
MouseCall (M1, M2, M3, M4)
END;
PROCEDURE SetRowRange (High, Low: WORD);
BEGIN
M1 := 8; M3 := Low; M4 := High;
MouseCall (M1, M2, M3, M4)
END;
(* ----- ----- ---- Sectiunea de initializare ----- ----- ----- *)
(* Functia MouseIsInstalled verifica intreruperea 51 din *)
(* vector; daca aceasta este NIL sau refera un IRET, atunci *)
(* se presupune ca muose-ul este neinstalat. *)
(*-------- ----- ------ ----- ----- ---------------*)
BEGIN
IF NOT MouseIsInstalled THEN
BEGIN
WRITELN ('>>> EROARE : Driver-ul mouse nu a fost detectat.');
WRITELN (' Revenire in DOS'); HALT (1)
END;
ButtonCount := NumberOfMouseButtons
END.
Unit1
(* >>> Unit1 <<< -------- ----- ------ ------ *)
(* Nume fisier : UNIT1.PAS *)
(* Rutine salveaza valoarea curenta a lui ExitProc *)
(* intr-un pointer. *)
(* -------- ----- ------ ----- ----- ---------- *)
UNIT Unit1;
INTERFACE
IMPLEMENTATION
VAR
Save: POINTER;
PROCEDURE Unit1ExitProcedure;
BEGIN
WriteLn ('Unit #1 -- Exit procedure ...');
ExitProc := Save
END;
BEGIN
Save := ExitProc;
ExitProc := @Unit1ExitProcedure;
WriteLn ('Unit #1 -- Initialization procedure ...')
END.
Unit2
(* >>> Unit2 <<< -------- ----- ------ ------- *)
(* Nume fisier : UNIT1.PAS *)
(* Rutina salveaza adresa procedurii de iesire din *)
(* Unit1. *)
(* *)
(* -------- ----- ------ ----- ----- ----------- *)
UNIT Unit2;
INTERFACE
IMPLEMENTATION
VAR
Save: POINTER;
PROCEDURE Unit2ExitProcedure;
BEGIN
WriteLn ('Unit #2 -- Exit procedure ...');
ExitProc := Save
END;
BEGIN
Save := ExitProc;
ExitProc := @Unit2ExitProcedure;
WriteLn ('Unit #2 -- Initialization procedure ...')
END.
Unit3
(* >>> Unit3 <<< -------- ----- ------ ------ *)
(* Nume fisier : UNIT3.pas *)
(* Rutine salveaza valoarea curenta a lui ExitProc *)
(* intr-un pointer. *)
(* -------- ----- ------ ----- ----- ---------- *)
UNIT Unit3;
INTERFACE
IMPLEMENTATION
VAR
Save: POINTER;
PROCEDURE Unit3ExitProcedure;
BEGIN
WriteLn ('Unit #3 -- Exit procedure ...');
ExitProc := Save
END;
BEGIN
Save := ExitProc;
ExitProc := @Unit3ExitProcedure;
WriteLn ('Unit #3 -- Initialization procedure ...')
END.
(* >>> Main <<< -------- ----- ------ ---------- *)
(* Nume fisier : MAIN.PAS *)
(* Program demonstrativ - inlantuirea procedurilor de *)
(* iesire. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM
USES Unit1, Unit2, Unit3;
BEGIN
WriteLn ('Programul principal incepe aici.');
WriteLn ('Programul principal se termina aici.')
END.
ClearRegion
(* >>> ClearRegion <<< ----- ----- --------- ----- ----- *)
(* Nume fisier : CLREGION.SRC *)
(* Rutina sterge portiunea indicata de pe ecran. *)
(* -------- ----- ------ ----- ----- ------ *)
PROCEDURE ClearRegion (X1, Y1, X2, Y2: INTEGER);
BEGIN
Window (X1, Y1, X2, Y2);
ClrScr;
Window (1, 1, 80, 25)
END;
WriteAt
(* >>> WriteAt <<< -------- ----- ------ -- *)
(* Nume fisier : WRITEAT.SRC *)
(* Rutina asigura afisarea unui mesaj in pozitia *)
(* indicata (daca X si Y sint pozitivi) sau centrata *)
(* (daca X si/sau Y sint negativi). *)
(* -------- ----- ------ ----- ----- -------- *)
PROCEDURE WriteAt(X,Y: INTEGER; HighLite, UseCR: BOOLEAN; TheText: STRING);
BEGIN
IF Y < 0 THEN Y := 12;
IF X < 0 THEN X := (80 - LENGTH(TheText)) DIV 2; GoToXY(X, Y);
IF HighLite THEN LowVideo;
IF UseCR THEN
WriteLn (TheText)
ELSE
Write (TheText);
NormVideo
END;
Da
(* <<< Da >>> -------- ----- ------ --------- *)
(* Nume fisier : DA.SRC *)
(* Fisierul contine functia Da. *)
(*-------- ----- ------ ----- ----- ----------- *)
FUNCTION Da: BOOLEAN;
VAR
Ch: CHAR;
BEGIN
REPEAT
Ch := UpCase (ReadKey)
UNTIL Ch IN ['D', 'N'];
WriteLn (Ch);
IF Ch = 'D' THEN
Da := TRUE
ELSE
Da := FALSE
END;
FlipField
(* >>> FlipField <<< -------- ----- ------ -------- *)
(* Nume fisier : FLIPFLD.SRC *)
(* Rutina faciliteaza introducerea datelor pentru cimpurile *)
(* ce pot avea una din doua valori diferite. Pentru aceasta *)
(* specificati pozitia cimpului (X, Y), un sir ptr. fiecare caz*)
(* adevarat si fals, si valoarea logica initiala ce indica care*)
(* din cele doua alternative se va afisa la inceput. *)
(* -------- ----- ------ ----- ----- ---------------- *)
PROCEDURE FlipField (X, Y: INTEGER;
TrueString: String30; FalseString: String30; VAR Escape: BOOLEAN);
VAR
Blanker: String80;
KeyStroke: 0..255;
WorkState: BOOLEAN;
Ch: CHAR;
PROCEDURE ShowState (NowState: BOOLEAN);
BEGIN
GoToXY (X, Y); Write (Blanker);
GoToXY (X, Y);
IF NowState THEN Write (TrueString© ELSE Write (FalseString)
END;
BEGIN
Escape := FALSE; Ch := CHR (0);
LowVideo;
FillChar (Blanker, SizeOf (Blanker), ' ');
WorkState := State;
IF LENGTH (TrueString) > LENGTH (FalseString) THEN
Blanker[0] := CHR(LENGTH(TrueString))
ELSE
Blanker[0] := CHR(LENGTH(FalseString));
ShowState (WorkState);
REPEAT
WHILE NOT KeyStat (Ch) DO BEGIN END;
KeyStroke := ORD (Ch);
IF KeyStroke = 27 THEN Escape := TRUE
ELSE
IF KeyStroke <> 13 THEN WorkState := NOT WorkState;
ShowState (WorkState)
UNTIL (KeyStroke = 13) OR Escape;
IF NOT Escape THEN State := WorkState;
NormVideo;
ShowState (State)
END;
QueryDispzitiv
(* >>> QueryAdapterType <<< ----- ----- --------- ----- ------- *)
(* Nume fisier : QUERYDSP.SRC *)
(* Rutina determina tipul cuplorului display-ului curent *)
(* instalat, pe care-l returneaza sub forma unei valori a *)
(* tipului enumerat AdapterType. *)
(* Tipuì AdapterType trebuie sa fie predefinit astfel : *)
(* AdapterType= (None, MDA, CGA, EGAMono, EGAColor, *)
(* VGAMono, VGAColor, MCGAMono, MCGAColor); *)
(* -------- ----- ------ ----- ----- ------------- *)
FUNCTION QueryAdapterType: AdapterType;
VAR
Regs: Registers;
Code: BYTE;
BEGIN
Regs.AH := $1A;
Regs.AL := $00;
Intr ($10, Regs);
IF Regs.AL = $1A THEN
CASE Regs.BL OF
$00: QueryAdapterType := None;
$01: QueryAdapterType := MDA;
$02: QueryAdapterType := CGA;
$04: QueryAdapterType := EGAColor;
$05: QueryAdapterType := EGAMono;
$07: QueryAdapterType := VGAMono;
$08: QueryAdapterType := VGAColor;
$0A, $0C: QueryAdapterType := MCGAColor;
$0B: QueryAdapterType := MCGAMono;
ELSE QueryAdapterType := CGA
END
ELSE
BEGIN
Regs.AH := $12;
Regs.BX := $10;
Intr ($10, Regs);
IF Regs.BX <> $10 THEN
BEGIN
Regs.AH := $12;
Regs.BL := $10;
Intr ($10, Regs);
IF (Regs.BH = 0) THEN QueryAdapterType := EGAColor
ELSE QueryAdapterType := EGAMono
END
ELSE
BEGIN
Intr ($11, Regs);
Code := (Regs.AL AND $30) SHR 4;
CASE Code OF
1: QueryAdapterType := CGA;
2: QueryAdapterType := CGA;
3: QueryAdapterType := MDA
ELSE QueryAdapterType := CGA
END
END
END
END;
CursorOff
(* >>> CursorOff <<< -------- ----- ------ --- *)
(* Nume fisier : CURSOFF.SRC *)
(* Suprima cursorul dispaly-ului. *)
(* -------- ----- ------ ----- ----- ----------- *)
PROCEDURE CursorOff;
VAR
Regs: Registers;
BEGIN
WITH Regs DO
BEGIN
AX := $0100;
CX := $2000
END;
Intr (16, Regs)
END;
DeterminePoints
(* >>> DeterminePoints <<< ----- ----- --------- ----- ------- *)
(* Nume fisier : FONTSIZE.SRC *)
(* Rutina determina inaltimea celulei caracterului ptr. *)
(* fontul curent in uz. Pentr MDA si CGA aceasta valoare *)
(* este stabilita hard; ptr. EGA, VGA si MCGA valoarea *)
(* trebuie obtinuta din ROM BIOS. *)
(* -------- ----- ------ ----- ----- ------------ *)
FUNCTION DeterminePoints: INTEGER;
VAR
Regs: Registers;
BEGIN
CASE QueryAdapterType OF
CGA: DeterminePoints := 8;
MDA: DeterminePoints := 14;
EGAMono,
EGAColor,
VGAMono,
VGAColor,
MCGAMono,
MCGAColor: BEGIN
WITH Regs DO
BEGIN
AH := $11;
BL := 0
END;
Intr ($10, Regs);
DeterminePoints := Regs.CX
END
END
END;
CursorOn
(* >>> CursorOn <<< -------- ----- ------ ----- *)
(* Nume fisier : CURSON.SRC *)
(* Activeaza cursorul dispaly-ului. *)
(* -------- ----- ------ ----- ----- ------------ *)
PROCEDURE CursorOn;
VAR
Points: BYTE;
Regs: Registers;
BEGIN
Points := DeterminePoints;
Mem[$40:$87] := Mem[$40:$87] OR $01;
WITH Regs DO
BEGIN
AX := $0100; CH := Points - 3; CL := Points - 1
END;
Intr (16, Regs)
END;
Font
(* >>> Font <<< -------- ----- ------ --------- *)
(* Nume fisier : FONT.PAS *)
(* Utilitar pentru aflarea si modificarea fontului. *)
(* -------- ----- ------ ----- ----- ------------ *)
PROGRAM Font;
USES CRT, DOS;
TYPE
AdapterType= (None, MDA, CGA, EGAMono, EGAColor,
VGAMono, VGAColor, MCGAMono, MCGAColor);
FontSizes= SET OF BYTE;
CONST
AdapterStrings: ARRAY[AdapterType] OF STRING=
('None', 'MDA', 'CGA', 'EGAMono', 'EGAColor',
'VGAMono', 'VGAColor', 'MCGAMono', 'MCGAColor');
VAR
InstalledAdapter: AdapterType;
LegalSizes, AdapterSizes: FontSizes;
ErrorPos: INTEGER;
ErrorSize: STRING;
NewFont, FontCode: BYTE;
OldAdapters: SET OF AdapterType;
Regs: Registers;
PROCEDURE ShowFontSizeError (BadSize: STRING);
BEGIN
WriteLn (BadSize, ' nu este o dimensiune valida pentru font.');
WriteLn ('Valorile legale sint 8, 14 si 16,');
WriteLn ('*daca* cuplorul dispaly-ului dv. le admite.')
END;
BEGIN
LegalSizes := [8, 14, 16];
OldAdapters := [CGA, MDA];
IF ParamCount < 1 THEN
BEGIN
InstalledAdapter := QueryAdapterType;
WriteLn('>> FONT << V1.1 de Jeff Duntemann');
WriteLn(' din COMPLETE TURBO PASCAL 5.0'); WriteLn;
WriteLn('Cuplorul instalat este: ',AdapterStrings[InstalledAdapter]);
WriteLn(' Dimensiunea fontului curent este : ', DeterminePoints);
WriteLn; WriteLn;
WriteLn(' Pentru a modifica dimensiunea fontului curent, apelati');
WriteLn('FONT.EXE avind ca parametru dimensiunea dorita, care');
WriteLn('trebuie sa fie 8, 14 sau 16'); WriteLn;
WriteLn('Spre exemplu :'); WriteLn(' C>FONT 14'); WriteLn;
WriteLn(' Retineti ca dimensiunea fontului la CGA sau MDA nu');
WriteLn('se poate modifica.'); Writeln; ReadLn
END
ELSE
BEGIN
VAL (ParamStr (1), NewFont, ErrorPos);
IF ErrorPos <> 0 THEN ShowFontSizeError(ParamStr(2))
ELSE
IF NOT (NewFont IN LegalSizes) THEN
BEGIN
STR(NewFont, ErrorSize); ShowFontSizeError(ErrorSize)
END
ELSE
BEGIN
InstalledAdapter := QueryAdapterType;
CASE InstalledAdapter OF
CGA: AdapterSizes := [8];
MDA: AdapterSizes := [14];
EGAMono, EGAColor: AdapterSizes := [8, 14];
VGAMono, VGAColor: AdapterSizes := [8, 14, 16];
MCGAMono, MCGAColor: AdapterSizes := [16]
END;
IF NOT (NewFont IN AdapterSizes) THEN
BEGIN
WriteLn (' Aceasta dimensiune a fontului nu exista');
WriteLn ('in cuplorul display-ului dv.')
END
ELSE
BEGIN
ClrScr;
IF NOT (InstalledAdapter IN OldAdapters) THEN
BEGIN
CASE NewFont OF
8: FontCode := $12;
14: FontCode := $11;
16: FontCode := $10
END;
Regs.AH := $11;
Regs.AL := FontCode; Regs.BX := 0; Intr ($10, Regs);
Mem[$40:$87] := Mem[$40:$87] OR $01;
Regs.AX := $100;
Regs.BX := 0;
Regs.CH := NewFont - 2; Intr ($10, Regs);
HALT (DeterminePoints)
END
END
END
END
END.
WriteInt
(* >>> WriteInt <<< -------- ----- ------ ------ *)
(* Nume fisier : WRITEINT.PAS *)
(* Programul scrie echivalentul ASCII al numerelor de la *)
(* 1 la 25 intr-un fisier text. Fiecare numar este urmat de *)
(* perechea codurilor CR/LF. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM WriteInt;
VAR
IntText: TEXT;
I: INTEGER;
BEGIN
Assign (IntText, 'INTEGERS.BIN');
Rewrite (IntText);
FOR I := 1 TO 25 DO
WriteLn (IntText, I);
Close (IntText)
END.
Averager
(* >>> Averager <<< -------- ----- ------ --- *)
(* Nume fisier : AVERAGER.PAS *)
(* Program demonstrativ pentru I/O in fisiere binare. *)
(* -------- ----- ------ ----- ----- ---------- *)
PROGRAM Averager;
VAR
intFile: FILE OF INTEGER;
i, j, Count: Integer;
Average, Total: REAL;
BEGIN
ASSIGN (intFile, 'INTEGERS.BIN');
RESET (intFile);
i := IOResult;
IF i <> 0 THEN
WriteLn ('>> Fisierul INTEGERS.BIN lipseste.')
ELSE
BEGIN
Count := 0; Total := 0.0;
WHILE NOT EOF (intFile) DO
BEGIN
Read (intFile, j);
IF NOT EOF (intFile) THEN
BEGIN
Count := Count + 1; Total := Total + j
END;
END;
CLOSE (intFile); Average := Total / Count; WriteLn;
WriteLn ('>> Exista ', Count, ' intregi in INTEGERS.BIN.');
WriteLn (' Valoarea lor medie este : ', Average:10:4, '.')
END;
READLN
END.
Case
(* >>> Caser <<< -------- ----- ------ ------- *)
(* Nume fisier : CASE.PAS *)
(* Program de conversie litere mari/litere mici pentru *)
(* fisierele text. *)
(* -------- ----- ------ ----- ----- ----------- *)
PROGRAM Caser;
CONST
Upper= TRUE;
Lower= FALSE;
TYPE
String40= STRING[40];
String80= STRING[80];
String255= STRING[255];
VAR
i, j, k: INTEGER;
Quit,
NewCase: BOOLEAN;
Ch: CHAR;
WorkFile,
TempFile: TEXT;
WorkLine,
WorkName,
TempName,
CaseTag: String80;
PROCEDURE MakeTemp (FileName: String80; VAR TempName: String80);
(* -------- ----- ------ ----- ----- -------------- *)
(* Determina numele fisierului temporar. Extensia acestui *)
(* fisier va fi .$$$. *)
(* -------- ----- ------ ----- ----- -------------- *)
VAR
Point: INTEGER;
BEGIN
Point := POS ('.', FileName);
IF Point > 0 THEN
Delete (FileName, Point, LENGTH (FileName) - Point + 1);
TempName := Concat (FileName, '.$$$')
END;
BEGIN
Quit := FALSE;
IF ParamCount < 2 THEN
BEGIN
WriteLn('>> CASE << V2.0 COMPLETE TURBO PASCAL V5.0');
WriteLn(' Jeff Duntemann'); WriteLn;
WriteLn(' Programul forteaza ca toate caracterele unui fisier');
WriteLn(' text sa fie sau cu litere mari sau cu litere mici.');
WriteLn; WriteLn(' Sintaxa de apelare :'); WriteLn;
WriteLn(' CASE UP|DOWN <specificator_fisier>'); WriteLn;
WriteLn(' Spre exemplu, pentru a forta ca toate caracterele');
WriteLn(' fisierului FOO.COB sa fie cu litere mari se va');
WriteLn(' apela programul CASE in modul urmator :'); WriteLn;
WriteLn(' CASE UP FOO.COB'); WriteLn
END
ELSE
BEGIN
WorkName := ParamStr(2);
ASSIGN(WorkFile, WorkName);
RESET (WorkFile);
IF IOResult <> 0 THEN
BEGIN
WriteLn('<< Eroare !<< Fisierul ', WorkName, ' nu exista.');
WriteLn(' Incercati cu un alt nume de fisier.')
END
ELSE
BEGIN
CaseTag := ParamStr(1); CaseTag := ForceCase(Upper, CaseTag);
IF CaseTag = 'UP' THEN NewCase := Upper
ELSE IF CaseTag = 'DOWN' THEN NewCase := Loweò
ELSE Quit := TRUE;
IF Quit THEN
BEGIN
WriteLn ('>> Eroare ! << Parametrul de conversie trebuie');
WriteLn ('sa fie UP (litere mari) si DOWN (litere mici).');
WriteLn (' Apelati din CASE fie cu UP fie cu DOWN.')
END
ELSE
BEGIN
Write ('Conversia se face in ');
IF NewCase THEN WriteLn('litere mari.')
ELSE WriteLn('litere mici.');
MakeTemp(WorkName, TempName);
ASSIGN(tempFile, tempName); REWRITE(tempFile);
WHILE NOT EOF (WorkFile) DO
BEGIN
ReadLn(WorkFile, WorkLine);
Write('.');
WorkLine := ForceCase(NewCase, WorkLine);
WriteLn(tempFile, WorkLine)
END;
CLOSE(tempFile); CLOSE(WorkFile);
ERASE(WorkFile);
RENAME(tempFile, WorkName)
END
END
END
END.
KeySearch
(* >>> KeySearch <<< -------- ----- ------ --- *)
(* Nume fisier : KSEARCH.SRC *)
(* Rutina de cautare binara pentru cheia unui articol *)
(* dintr-un fisier. Tipul articolului trebuie sa fie *)
(* definit de urmatoarea maniera : *)
(* KeyRec= RECORD *)
(* Ref: INTEGER; *)
(* KeyData: String30 *)
(* END; *)
(* Functia returneaza TRUE daca cheia este gasita. *)
(* -------- ----- ------ ----- ----- ----------- *)
FUNCTION KeySearch (VAR Keys: KeyFile; VAR KeyRef: INTEGER;
Matchit: String80): BOOLEAN;
VAR
RecCount, Mid¬ High, Low: INTEGER;
Found¬ Collided: BOOLEAN;
SearchRec: KeyRec;
BEGIN
KeyRef := 0;
RecCount := FileSize (Keys); High := RecCount; Low := 0;
KeySearch := FALSE; Found := FALSE; Collided := FALSE;
Mid := (Low + High) DIV 2;
IF RecCount > 0 THEN
REPEAT
Seek (Keys, Mid);
Read (Keys, SearchRec);
IF (low = Mid) OR (High = Mid) THEN Collided := TRUE;
IF Matchit = SearchRec.KeyData THEN
BEGIN
Found := TRUE;
KeySearch := TRUE;
KeyRef := SearchRec.Ref
END
ELSE
BEGIN
IF Matchit > SearchRec.KeyData THEN
Low := Mid
ELSE
High := Mid;
Mid := (Low - High + 1) DIV 2;
KeyRef := Mid
END
UNTIL Collided OR Found
END;
ShowName
(* >>> ShowName <<< -------- ----- ------ ------ *)
(* Nume fisier : SHOWNAME.PAS *)
(* Program demonstrativ pentru cautarea binara intr-un *)
(* fisier cu chei. *)
(* Programul are nevoie de doua fisiere : FRIENDS.MAP si *)
(* FRIENDS.KEY. FRIENDS.MAP contine articole cu urmatoarele *)
(* date : nume, adresa, localitate, cod stat si cod postal. *)
(* Fisierul FRIENDS.KEY este un fisier de chei sortate *)
(* continind cheile extrase din FRIENDS.MAP. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM ShowName;
TYPE
String3= STRING[3];
String6= STRING[6];
String10= STRING[10];
String30= STRING[30];
String40= STRING[40];
String80= STRING[80];
String255= STRING[255];
MAPRec= RECORD
Name,
Address,
City: String30;
State: String3;
Zip: String6;
Phone: String10
END;
MAPFile= FILE OF MAPRec;
KeyRec= RECORD
Ref: INTEGER;
KeyData: String30
END;
KeyFile= FILE OF KeyRec;
VAR
i, j, k,
RecNum: INTEGER;
Parm: String30;
WorkRec: MAPRec;
WorkFile: MAPFile;
WorkKey: KeyFile;
BEGIN
IF ParamCount < 1 THEN
BEGIN
WriteLn('>> Eroare !<< Trebuie sa introduceti numele dorit');
WriteLn(' in linia de comanda.'); WriteLn;
WriteLn(' SHOWNAME Ionescu*Ion')
END
ELSE
BEGIN
Parm := ParamStr(1);
ASSIGN(WorkFile, 'FRIENDS.MAP');
RESET(WorkFile);
ASSIGN(WorkKey, 'FRIENDS.KEY');
RESET(WorkKey);
IF KeySearch(WorkKey, RecNum, Parm) THEN
BEGIN
Seek(WorkFile, RecNum);
Read(WorkFile, WorkRec);
WITH WorkRec DO
BEGIN
WriteLn('>>Nume : ', name);
WriteLn(' Adresa : ', address);
WriteLn(' Localitate : ', City);
WriteLn(' Cod postal : ', Zip);
WriteLn(' Telefon : ', Phone)
END
END
ELSE
WriteLn('>> Regret, ', Parm, ' nu este in fisier.')
END
END.
GLoad
(* >>> GLoad <<< -------- ----- ------ ------- *)
(* Nume fisier : GLOAD.SRC *)
(* Rutina incarca ecranul grafic dintr-un fisier. *)
(* -------- ----- ------ ----- ----- ----------- *)
PROCEDURE GLoad (GName: STRING; VAR IOR: INTEGER);
TYPE
ScreenBuff= ARRAY[0..16383] OF BYTE;
VAR
GBuff: ScreenBuff ABSOLUTE $8800:0;
GFile: FILE;
BEGIN
Assign(GFile, GName);
Reset (GFile, 16384);
IOR := IOResult;
IF IOR = 0 THEN
BEGIN
BlockRead(GFile, GBuff, 1); Close(GFile)
END
END;
GSave
(* >>> GSave <<< -------- ----- ------ ------- *)
(* Nume fisier : GSAVE.SRC *)
(* Rutina salveaza ecranul grafic intr-un fisier. *)
(* -------- ----- ------ ----- ----- ----------- *)
PROCEDURE GSave (GName: STRING; VAR IOR: INTEGER);
TYPE
ScreenBuff= ARRAY[0..16383] OF BYTE;
VAR
GBuff: ScreenBuff ABSOLUTE $8800:0;
GFile: FILE;
BEGIN
Assign(GFile, GName); Rewrite(GFile, 16384);
BlockWrite(GFile, GBuff, 1);
IOR := IOResult; Close (GFile)
END;
GraphFiler
(* >>> GraphFiler <<< -------- ----- ------ ---- *)
(* Nume fisier : GFILE.PAS *)
(* Program demonstrativ - I/O fisier grafica. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM GraphFiler;
USES CRT, GRAPH3;
VAR
I, ErrorCode: INTEGER;
BEGIN
ClrScr;
HiResColor (15);
HiRes;
TextColor (1);
FOR I := 0 to 199 DO
IF I MOD 5 = 0 THEN
Draw (0, 0, 640, I, 1);
GSave ('LINES.PIC', ErrorCode);
Write ('Apasati <RETURN> ptr. stergere ecran si incarcarea imaginii');
ReadLn;
HiRes;
GLoad ('LINES.PIC', ErrorCode);
ReadLn
END.
HexDump
(* >>> HexDump <<< -------- ----- ------ ----- *)
(* Nume fisier : HEXDUMP.PAS *)
(* Program pentru afisarea hexazecimala a continutului *)
(* fiserelor disc. *)
(* -------- ----- ------ ----- ----- ----------- *)
PROGRAM HexDump;
USES CRT;
CONST
Up= TRUE;
Down= FALSE;
TYPE
String255= STRING[255];
String128= STRING[128];
String80= STRING[80];
String40= STRING[40];
Block= ARRAY[0..127] OF BYTE;
BlockArray= ARRAY[0..15] OF Block;
VAR
Parm: String80;
Ch: CHAR;
DumpFile: FILE;
XBlock: Block;
DiskData: BlockArray;
I, J, K,
Blocks,
BlockCount,
Buffers,
BytesRead,
Remains: INTEGER;
Device: TEXT;
PROCEDURE DumpBlock (XBlock: Block; VAR Device: TEXT);
VAR
I, J, K: INTEGER;
Ch: CHAR;
BEGIN
FOR I := 0 TO 8 DO
BEGIN
FOR J := 0 TO 15 DO
BEGIN
WriteHex (Device, Ord (XBlock[(I * 16) + J]));
Write (Device, ' ')
END;
Write (Device,' |');
FOR J := 0 TO 15 DO
BEGIN
Ch := Chr (XBlock[(I * 16) + j]);
IF ((Ord (Ch) < 127) AND (Ord (Ch) > 31)) THEN
Write (Device, Ch)
ELSE
Write (Device, '.')
END;
WriteLn (Device, '|')
END;
FOR I := 0 TO 1 DO WriteLn (Device, '')
END;
PROCEDURE ShowHelp (HelpName: String80);
VAR
HelpFile: TEXT;
HelpLine: String80;
I: INTEGER;
BEGIN
WriteLn;
Assign(HelpFile, HelpName);
Reset (HelpFile);
IF IOResult = 0 THEN
FOR I := 1 TO 24 DO
BEGIN
ReadLn (HelpFile, HelpLine);
WriteLn (HelpLine)
END;
Close (HelpFile)
END;
BEGIN
Parm := '';
IF ParamCount > 1 THEN
Parm := ForceCase (Up, ParamStr (2));
IF ParamCount < 1 THEN
BEGIN
WriteLn('>>Eroare !<< Trebuie sa introduceti un nume de');
WriteLn(' fisier dupa comanda.');
Write(' Doriti afisarea ecranului Help (D/N) : ');
IF Da THEN ShowHelp('UMPHELP.TXT')
END
ELSE
BEGIN
Assign (DumpFile, ParamStr (1));
Reset (DumpFile);
IF IOResult <> 0 THEN
BEGIN
WriteLn('>>Eroare !<< Fisierul ', ParamStr (1), ' nu exista.');
Write(' Doriti afisarea ecranului Help (D/N) : ');
IF Da THEN ShowHelp ('UMPHELP.TXT')
END
ELSE
BEGIN
IF (Pos('PRINT', Parm) = 1) OR (Pos ('P', Parm) = 1) THEN
Assign(Device, 'PRN')
ELSE Assign (Device, 'CON');
Rewrite(Device);
BlockCount := FileSize(DumpFile) + 1;
IF BlockCount = 0 THEN
WriteLn('Fisierul ', ParamStr (1), ' este gol.')
ELSE
BEGIN
Buffers := BlockCount DIV 16; Remains := BlockCount MOD 16;
FOR I := 1 TO Buffers DO
BEGIN
BlockRead(DumpFile, DiskData, 16, BytesRead);
FOR J := 0 TO 15 DO DumpBlock (DiskData[J], Device)
END;
IF Remains > 0 THEN
BEGIN
BlockRead (DumpFile, DiskData, Remains, BytesRead);
FOR I := 0 TO Remains - 1 DO
DumpBlock(DiskData[I], Device)
END
END;
Close (DumpFile)
END
END
END.
ShowDir
(* >>> ShowDir <<< -------- ----- ------ ------- *)
(* Nume fisier : SHOWDIR.PAS *)
(* Program demonstrativ - citire director. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM ShowDir;
VAR
I: BYTE;
Error: INTEGER;
CurrentDirectory: STRING;
BEGIN
FOR I := 0 TO 4 DO
BEGIN
GetDir (I, CurrentDirectory);
IF I = 0 THEN
Write ('Logged drive : ')
ELSE
Write ('Drive ', Chr (64 + I), ': ');
WriteLn (CurrentDirectory)
END
END.
Vectors
(* >>> Vectors <<< -------- ----- ------ --------- *)
(* Nume fisier : VECTORS.PAS *)
(* Programul permite inspectarea si modificarea vectorilor *)
(* intreruperilor 8086 precum si vizionarea primilor 256 de *)
(* octeti ai orcarui vector. *)
(* -------- ----- ------ ----- ----- --------------- *)
PROGRAM Vectors;
USES DOS;
CONST
Up= TRUE;
TYPE
String80= STRING[80];
Block= ARRAY[0..255] OF BYTE;
PtrPieces= ARRAY[0..3] OF BYTE;
VAR
I, NewVector¬ VSeg, VOfs,
ErrorPosition¬ VectorNumber: INTEGER;
Vector: POINTER;
MemBlock: Block;
Quit: BOOLEAN;
Command: String80;
CommandChar: CHAR;
PROCEDURE StripWhite (VAR Target: STRING);
CONST
Whitespace: SET OF CHAR= [#8, #10, #12, #13, ' '];
BEGIN
WHILE (Length (Target) > 0) AND (Target[1] IN Whitespace) DO
Delete(Target, 1, 1)
END;
PROCEDURE WriteHex(BT: BYTE);
CONST
HexDigits: ARRAY[0..15] OF CHAR= '0123456789ABCDEF';
VAR
BZ: BYTE;
BEGIN
BZ := BT AND $06;
BT := BT SHR 4;
Write (HexDigits[BT], HexDigits[BZ])
END;
FUNCTION ForceCase(Up: BOOLEAN; Target: STRING): STRING;
CONST
UpperCase: SET OF CHAR= ['A'..'Z'];
LowerCase: SET OF CHAR= ['a'..'z'];
VAR
I: INTEGER;
BEGIN
IF Up THEN
FOR I := 1 TO Length (Target) DO
IF Target[I] IN Lowercase THEN
Target[I] := UpCase (Target[I])
ELSE
ELSE
FOR I := 1 TO Length (Target) DO
IF Target[I] IN UpperCase THEN
Target[I] := Chr (Ord (Target[I]) + 32);
ForceCase := Target
END;
PROCEDURE ValHex(HexString:STRING;VAR Value:LONGINT;VAR ErrCode:INTEGER);
VAR
I, Position: INTEGER;
PlaceValue, TempValue: LONGINT;
HexDigits: STRING;
BEGIN
ErrCode := 0; TempValue := 0; PlaceValue := 1;
HexDigits := '0123456789ABCDEF'; StripWhite (HexString);
IF Pos ('$', HexString) = 1 THEN Delete (HexString, 1, 1);
HexString := ForceCase (Up, HexString);
IF (Length (HexString) > 8) THEN ErrCode := 9
ELSE
IF (Length (HexString) < 1) THEN ErrCode := 1
ELSE
BEGIN
FOR I := Length (HexString) DOWNTO 1 DO
BEGIN
Position := Pos (Copy (HexString, I, 1), HexDigits);
IF Position = 0 THEN
BEGIN
ErrCode := 1;
Exit
END;
TempValue := TempValue + ((Position - 1) * PlaceValue);
PlaceValue := PlaceValue * 16
END;
Value := TempValue
END
END;
PROCEDURE DumpBlock (XBlock: Block);
VAR
I, J, K: INTEGER;
Ch: CHAR;
BEGIN
FOR I := 0 TO 15 DO
BEGIN
FOR J := 0 TO 15 DO
BEGIN
WriteHex(Ord (XBlock[(I * 16) + J])); Write(' ')
END;
Write(' |');
FOR J := 0 TO 15 DO
BEGIN
Ch := Chr (XBlock[(I * 16) + J]);
IF ((Ord(Ch) < 127) AND (Ord(Ch) > 31)) THEN Write(Ch)
ELSE Write('.')
END;
WriteLn ('|')
END;
FOR I := 0 TO 1 DO WriteLn ('')
END;
PROCEDURE ShowHelp;
BEGIN
WriteLn;
WriteLn(' Apasati RETURN pentru a trece la urmatorul vector.');
WriteLn;
WriteLn(' Pentru afisarea unui anumit vector, introduceti numarul');
WriteLn('vectorului (0-255) in zecimal sau precedat de "$" pentru');
WriteLn('hexazecimal, dupa care apasati RETURN.');
WriteLn;
WriteLn(' Comenzile valide sint :'); WriteLn;
WriteLn('D: Vidajul primilor 256 octeti referiti de vectorul curent.');
Write('E: Introducerea unei valori noi(zecimal sau hexa) ptr.');
WriteLn(' vectorul curent.');
WriteLn('H: Afisarea acestui mesaj Help.');
WriteLn('Q: Iesire din VECTORS');
WriteLn('X: Iesire din VECTORS');
Write('Z: Adresa segment si de start a vectorului curent egala ');
WriteLn('cu 0.');
WriteLn('?: Afisarea acestui mesaj Help'); WriteLn;
WriteLn(' Indicatorul ">>IRET" semnifica referirea pointerului ');
WriteLn('unei instructiuni IRET'); WriteLn
END;
PROCEDURE DisplayVector (VectorNumber: INTEGER);
VAR
Dump: INTEGER;
Chunks: PtrPieces;
Vector: POINTER;
Tester: ^BYTE;
BEGIN
GetIntVec (VectorNumber, Vector); Tester := Vector;
Chunks := PtrPieces (Vector); Write(VectorNumber:3, ' $');
WriteHex(VectorNumber); Write(' [');
WriteHex(Chunks[3]); WriteHex(Chunks[2]); Write(':');
WriteHex(Chunks[1]); WriteHex(Chunks[0]); Write(']');
IF Tester^ = $CF THEN Write(' >>IRET ') ELSE Write(' ')
END;
PROCEDURE DumpTargetData (VectorNumber: INTEGER);
VAR
Vector: POINTER;
Tester: ^Block;
BEGIN
GetIntVec (VectorNumber, Vector);
Tester := Vector; MemBlock := Tester^;
IF MemBlock[0] = $CF THEN WriteLn ('Vectorul refera un IRET.');
DumpBlock (MemBlock)
END;
PROCEDURE ChangeVector (VectorNumber: INTEGER);
VAR
Vector: POINTER;
LongTemp, TempValue: LONGINT;
SegPart, OfsPart: WORD;
BEGIN
GetIntVec(VectorNumber, Vector); LongTemp := LONGINT(Vector);
SegPart := LongTemp SHL 16; OfsPart := LongTemp AND $0000FFFF;
Write('Introduceti segmentul ');
Write('(RETURN retine valoarea curenta) : '); ReadLn (Command);
StripWhite (Command);
IF Length (Command) > 0 THEN
BEGIN
Val (Command, TempValue, ErrorPosition);
IF ErrorPosition = 0 THEN SegPart := TempValue
ELSE
BEGIN
ValHex(Command, TempValue, ErrorPosition);
IF ErrorPosition = 0 THEN SegPart := TempValue
END;
Vector := Ptr(SegPart, OfsPart);
SetIntVec(VectorNumber, Vector)
END;
DisplayVector(VectorNumber);
WriteLn; Write('Introduceti adresa de start ');
Write('(RETURN retine valoarea curenta) : '); ReadLn (Command);
StripWhite(Command);
IF Length (Command) > 0 THEN
BEGIN
Val (Command, TempValue, ErrorPosition);
IF ErrorPosition = 0 THEN OfsPart := TempValue
ELSE
BEGIN
ValHex (Command, TempValue, ErrorPosition);
IF ErrorPosition = 0 THEN OfsPart := TempValue
END
END;
Vector := Ptr(SegPart, OfsPart);
SetIntVec(VectorNumber, Vector)
END;
BEGIN
Quit := FALSE;
VectorNumber := 0;
WriteLn('>> VECTORS << V2.0 de Jeff Duntemann');
WriteLn(' din COMPLETE TURBO PASCAL V5.0'); WriteLn;
WriteLn; ShowHelp;
REPEAT
DisplayVector(VectorNumber); Readln(Command);
IF Length (Command) > 0 THEN
BEGIN
Val (Command, NewVector, ErrorPosition);
IF ErrorPosition = 0 THEN VectorNumber := NewVector
ELSE
BEGIN
StripWhite(Command);
Command := ForceCase (Up, Command);
CommandChar := Command[1];
CASE CommandChar OF
'Q', 'X': Quit := TRUE;
'D': DumpTargetData (VectorNumber);
'E': ChangeVector (VectorNumber);
'H': ShowHelp;
'Z': BEGIN
Vector := NIL;
SetIntVec (VectorNumber, Vector);
DisplayVector (VectorNumber);
WriteLn ('zerorizare.');
VectorNumber := (VectorNumber + 1) MOD 256
END;
'?': ShowHelp
END
END
END
ELSE
VectorNumber := (VectorNumber + 1) MOD 256
UNTIL Quit
END.
FlushKey
(* >>> FlushKey <<< -------- ----- ------ ------ *)
(* Nume fisier : FLUSHKEY.SRC *)
(* Rutina foloseste serviciile ROM BIOS pentru a extrage *)
(* din bufferul tastaturii caracterele asteptate. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROCEDURE FlushKey;
VAR
Regs: Registers;
BEGIN
Regs.AH := $01;
Intr ($16, Regs);
IF (Regs.Flags AND $0040) = 0 THEN
REPEAT
Regs.AH := 0;
Intr ($16, Regs);
Regs.AH := $01;
Intr ($16, Regs)
UNTIL (Regs.Flags AND $0040) <> 0
END;
FlushTest
(* >>> FlushTest <<< -------- ----- ------ ----- *)
(* Nume fisier : FLUSHTST.PAS *)
(* Program demonstrativ - golirea bufferului tastaturii. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM FlushTest;
USES CRT, DOS;
VAR
I, J: INTEGER;
Ch: CHAR;
PROCEDURE Counter;
BEGIN
FOR I := 1 TO 1000 DO
BEGIN
GoToXY (1, WhereY); ClrEol;
J := J + 1; Write (J)
END; WriteLn
END;
BEGIN
REPEAT
Counter; FlushKey;
Write('Terminati programul acum (Y/N) ? '); ReadLn
UNTIL Ch IN ['Y', 'y']
END
GetKey
(* >>> GetKey <<< -------- ----- ------ --------- *)
(* Nume fisier : GETKEY.SRC *)
(* Rutina foloseste serviciile ROM BIOS pentru testarea *)
(* prezentei caracterului asteptat in bufferul tastaturii, *)
(* iar daca este cel asteptat, il va returna. Functia insasi *)
(* va returna TRUE daca a fost citit un caracter. Caracterul *)
(* este furnizat in Ch. Daca s-a apasat o tasta "speciala" *)
(* (non-ASCII), variabila Extended devine TRUE iar codul *)
(* scan al tastei speciale va fi furnizat in variabila Scan. *)
(* In plus GETKEY furnizeaza starea "shift" ori de cite ori *)
(* este apelata indiferent daca s-a citit sau nu un caracter.*)
(* Starea Shift este returnata in octetul Shifts astfel : *)
(* Biti Semnificatie *)
(* 7 6 5 4 3 2 1 0 *)
(* 1 . . . . . . . INSERT ( 1 = Activat ) *)
(* . 1 . . . . . . CAPS LOCK ( 1 = Activat ) *)
(* . . 1 . . . . . NUM LOCK ( 1 = Activat ) *)
(* . . . 1 . . . . SCROLL LOCK ( 1 = Activat ) *)
(* . . . . 1 . . . ALT ( 1 = Apasat ) *)
(* . . . . . 1 . . CTRL ( 1 = Apasat ) *)
(* . . . . . . 1 . LEFT SHIFT ( 1 = Apasat ) *)
(* . . . . . . . 1 RIGHT SHIFT ( 1 = Apasat ) *)
(* Testarea bitilor individual se face folosind operatorul *)
(* AND si o masca, spre exemplu : *)
(* IF (Shifts AND $0A) = $0A THEN CtrlAndAltArePressed; *)
(* -------- ----- ------ ----- ----- -------------- *)
FUNCTION GetKey (VAR Ch: CHAR; VAR Extended: BOOLEAN;
VAR Scan: BYTE; VAR Shifts: BYTE): BOOLEAN;
VAR
Regs: Registers;
Ready: BOOLEAN;
BEGIN
Extended := FALSE; Scan := 0;
Regs.AH := $01;
Intr ($16, Regs);
Ready := (Regs.Flags AND $40) = 0;
IF Ready THEN
BEGIN
Regs.AH := 0;
Intr ($16, Regs);
Ch := Chr (Regs.AL);
Scan := Regs.AH;
IF Ch = Chr (0) THEN Extended := TRUE ELSE Extended := FALSE
END;
Regs.AH := $02;
Intr ($16, Regs);
Shifts := Regs.AL;
GetKey := Ready
END;
KeyTest
(* >>> KeyTest <<< -------- ----- ------ ------- *)
(* Nume fisier : KEYTEST.PAS *)
(* Program demonstrativ - accesul complet la tastatura. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM KeyTest;
USES CRT, DOS;
VAR
Ch: CHAR;
Ready,
Extended: BOOLEAN;
Scan,
Shifts: BYTE;
BEGIN
Ch := ' '; Ready := FALSE; ClrScr;
CursorOff;
GoToXY (20, 1);
Write ('>> COMPLETE TURBO PASCAL - demo citire tastatura');
GoToXY (30, 2); Write ('(Apasati ESC pentru iesire ... )');
GoToXY (12, 17); Write ('Ctrl: ');
GoToXY (5, 18); Write ('Left Shift: ');
GoToXY (46, 18); Write ('Right Shift: ');
GoToXY (13, 19); Write ('Alt: ');
GoToXY (50, 19); Write ('Caps Lock: ');
GoToXY (64, 19); Write ('Insert: ');
GoToXY (52, 13); Write ('Num Lock: ');
GoToXY (64, 13); Write ('Scroll Lock: ');
GoToXY (31, 7); Write ('<Ultima tasta apasata: >');
FlushKey;
REPEAT
Ready := GetKey (Ch, Extended, Scan, Shifts);
GoToXY (29, 8);
IF Ready THEN
IF Extended THEN Write ('Extins; Scan cod = ', Scan)
ELSE Write (' ', Ch, ' ');
GoToXY (17, 18); IF (Shifts AND $02) <> 0 THEN
Write (Chr (31))
ELSE Write (Chr (30));
GoToXY (62, 18); IF (Shifts AND $01) <> 0 THEN
Write (Chr (31))
ELSE Write (Chr (30));
GoToXY (18, 17); IF (Shifts AND $04) <> 0 THEN
Write (Chr (31))
ELSE Write (Chr (30));
GoToXY (18, 19); IF (Shifts AND $08) <> 0 THEN
Write (Chr (31))
ELSE Write (Chr (30));
GoToXY (61, 19); IF (Shifts AND $40) <> 0 THEN
Write (Chr (15))
ELSE Write (' ');
GoToXY (72, 19); IF (Shifts AND $80) <> 0 THEN
Write (Chr (15))
ELSE Write (' ');
GoToXY (62, 13); IF (Shifts AND $20) <> 0 THEN
Write (Chr (15))
ELSE Write (' ');
GoToXY (77, 13); IF (Shifts AND $10) <> 0 THEN
Write (Chr (15))
ELSE Write (' ');
UNTIL Ch = Chr (27);
TextMode (3)
END.
CalcTime
(* >>> CalcTime <<< -------- ----- ------ ------ *)
(* Nume fisier : CALCTIME.SRC *)
(* Rutina converteste valorile timpului DOS transmis in *)
(* TimeRec in siruri. Articolul TimeRec trebuie definit : *)
(* TimeRec= RECORD *)
(* TimeComp: WORD; *)
(* TimeString: String80; *)
(* Hours, Minutes, *)
(* Seconds, Hundredths: INTEGER *)
(* END; *)
(* -------- ----- ------ ----- ----- ------------- *)
PROCEDURE CalcTime (VAR ThisTime: TimeRec);
TYPE
String5= STRING[5];
VAR
Temp1,
Temp2: String5;
AmPm: CHAR;
I: INTEGER;
BEGIN
WITH THisTime DO
BEGIN
I := Hours;
IF Hours = 0 THEN I := 12;
IF Hours > 12 THEN
I := Hours - 12;
IF Hours > 11 THEN AmPm := 'p' ELSE AmPm := 'a';
Str (I:2, Temp1); Str (Minutes, Temp2);
IF Length (Temp2) < 2 THEN Temp2 := '0' + Temp2;
TimeString := Temp1 + ':' + Temp2 + AmPm;
TimeComp := (Hours SHL 11 ) OR (Minutes SHL 5) OR (Seconds SHR 1)
END
END;
TimeRec
(* >>> TimeRec <<< -------- ----- ------ ------ *)
(* Nume fisier : TIMEREC.DEF *)
(* Contine definirea articolului TimeRec. *)
(* -------- ----- ------ ----- ----- ------------ *)
TimeRec= RECORD
TimeComp: WORD;
TimeString: String80;
PM: BOOLEAN;
Hours, Minutes, Seconds, Hundredths: INTEGER
END;
CalcDate
(* >>> CalcDate <<< -------- ----- ------ ------- *)
(* Nume fisier : CALCDATE.SRC *)
(* Rutina determina valorile cimpurilor DateString, *)
(* LongDateString si DateComp di articolul DateRec transmis *)
(* acesteia. Calculele se fac pe baza datelor din cimpurile *)
(* Year, Month si Day ale aceluiasi articol. *)
(* Articolul DateRec trebuie definit astfel : *)
(* DateRec= RECORD *)
(* DateComp: WORD *)
(* LongDateString: String80; *)
(* DateString: String80; *)
(* Year, Month, Day: INTEGER; *)
(* DayOfWeek: INTEGER *)
(* END; *)
(* DateString va fi de forma : Wednesday, July 17, 1986 *)
(* DateOfWeek este un cod cuprins intre 0 si 6, 0 = Sunday. *)
(* DateComp este un cardinal generat cu formula : *)
(* DateComp = (Year - 1980) * 512 + (Month * 32) + Day *)
(* Este utilizat ptr.compararea a doua date calendaristice. *)
(* -------- ----- ------ ----- ----- -------------- *)
PROCEDURE CalcDate (VAR ThisDate: DateRec);
TYPE String9= STRING[9];
CONST
MonthTags: ARRAY[1..12] OF String9=
('January', 'February', 'March', 'April', 'May', 'June', 'July',
'August', 'September', 'Octomber', 'November', 'December');
DayTags: ARRAY[0..6] OF String9= ('Sunday', 'Monday', 'Tuesday',
'Wednesday', 'Thursday', 'Friday', 'Saturday');
VAR Temp1: String80;
BEGIN
WITH ThisDate DO
BEGIN
DayOfWeek := DateToDayOfWeek(Year, Month, Day);
Str(Month, DateString); Str (Day, Temp1);
DateString := DateString + '/' + Temp1;
LongDateString := DayTags[DayOfWeek] + ', ';
LongDateString := LongDateString +
MonthTags[Month] + ' ' + Temp1 + ', ';
Str (Year, Temp1); LongDateString := LongDateString + Temp1;
DateString := DateString + '/' + Copy (Temp1, 3, 2);
DateComp := (Year - 1980) * 512 + (Month * 32) + Day
END
END;
DateRec
(* >>> DateRec <<< -------- ----- ------ ------ *)
(* Nume fisier : DATEREC.DEF *)
(* Contine definirea articolului DateRec. *)
(* -------- ----- ------ ----- ----- ------------ *)
DateRec= RECORD
DateComp: WORD;
LongDateString: String80;
DateString: String80;
Year, Month, Day, DayOfWeek: INTEGER
END;
Toucher
(* >>> Toucher <<< -------- ----- ------ -------- *)
(* Nume fisier : TOUCHER.PAS *)
(* Demonstreaza folosirea rutinelor calendaristice DOS. *)
(* -------- ----- ------ ----- ----- -------------- *)
PROGRAM Toucher;
USES DOS;
VAR
I: INTEGER;
Stamp: LONGINT;
Now: DateTime;
Target: FILE;
Sec100, DayOfWeek: WORD;
BEGIN
IF ParamCount < 1 THEN
BEGIN
WriteLn ('>>TOUCHER V1.0 de Jeff Duntemann');
WriteLn (' din COMPLETE TURBO PASCAL V5.0');
WriteLn; WriteLn; WriteLn (' Forma de apelare :');
WriteLn; WriteLn (' TOUVHER <nume_fisier>'); WriteLn;
WriteLn (' TOUCHER este un utilitar care inlocuieste "marca"');
WriteLn (' timp/data a fisierului specificat cu timpul si data ');
WriteLn ('curenta. Acesta se poate utiliza pentru actualizarea');
WriteLn ('datei unui fisier.'); WriteLn
END
ELSE
BEGIN
Assign (Target, ParamStr (1));
Reset (Target);
I := IOResult;
IF I <> 0 THEN
WriteLn ('>>Eroare ! Fisierul indicat nu poate fi deschis ...')
ELSE
BEGIN
WITH Now DO
GetTime (Hour, Min, Sec, Sec100);
WITH Now DO
GetDate (Year, Month, Day, DayOfWeek);
PackTime (Now, Stamp);
SetFTime (Target, Stamp);
Close (Target)
END
END
END.
DateToDayOfWeek
(* >>> DateToDayOfWeek <<< -------- ----- ------ - *)
(* Nume fisier : DAYOWEEK.SRC *)
(* Rutina determina denumirea zilei datei transmise. *)
(* Principiul de lucru se bazeaza pe stabilirea datei curente *)
(* a sistemului ca fiind data transmisa pentru a obtine ziua *)
(* din saptamina in AL. (Data curenta reala se salveaza la *)
(* inceputul lucrului rutinei si se restaureaza la terminare *)
(* acesteia). *)
(* -------- ----- ------ ----- ----- --------------- *)
FUNCTION DateToDayOfWeek (Year, Month, Day: INTEGER): INTEGER;
VAR
DayNumber: INTEGER;
LeapYearDay: BOOLEAN;
SaveDate¬ WorkDate: Registers;
CONST
DayArray: ARRAY[1..12] OF INTEGER=
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
BEGIN
LeapYearDay := FALSE;
IF (Month = 2) AND ((Year MOD 4) = 0) AND (Day = 29) THEN
LeapYearDay := TRUE;
IF (NOT LeapYearDay) AND (Day > DayArray[Month]) THEN
DateToDayOfWeek = -1
ELSE
BEGIN
WorkDate.AH := $2B;
SaveDate.AH := $2A;
MSDOS (SaveDate);
WITH WorkDate DO
BEGIN
CX := Year; DH := Month; DL := Day;
MSDOS (WorkDate);
AH := $2A;
MSDOS (WorkDate);
DayNumber := AL;
IF LeapYearDay THEN
IF DayNumber = 0 THEN
DayNumber := 6
ELSE
DayNumber := Pred (DayNumber);
DateToDayOfWeek := DayNumber
END;
SaveDate.AH := $2B;
MSDOS (SaveDate)
END
END;
DirRec
(* >>> DirRec <<< -------- ----- ------ ------- *)
(* Nume fisier : DIRREC.DEF *)
(* Definirea articolului DirRec. *)
(* -------- ----- ------ ----- ----- ------------ *)
DirRec= RECORD
FileName: String15;
Attrib: BYTE;
FileSize: LONGINT;
TimeStamp: TimeRec;
DateStamp: DateRec;
Prior, Next: DIRPtr
END;
ListMan
(* >>> ListMan <<< -------- ----- ------ --------- *)
(* Nume fisier : LISTMAN.PAS *)
(* Program demonstrativ - utilizarea variabilelor dinamice *)
(* -------- ----- ------ ----- ----- --------------- *)
PROGRAM ListMan;
USES CRT;
TYPE
String30= STRING[30];
String15= STRING[15];
String6= STRING[6];
ArtPtr= ^ArticolLista;
ArticolLista= RECORD
Nume, Adresa,
Oras: String30;
Tara: String15;
CodPostal: String6;
Urmator: ArtPtr
END;
FisierPersoane= FILE OF ArticolLista;
VAR
Ch: CHAR;
Radacina: ArtPtr;
Iesire: BOOLEAN;
PROCEDURE StergeLini (Prima, Ultima: INTEGER);
VAR
I: INTEGER;
BEGIN
FOR I := Prima TO Ultima DO
BEGIN GOTOXY(1, I); ClrEol; GOTOXY(1, Prima) END
END;
PROCEDURE PrezentareArticol (ArtLucru: ArticolLista);
VAR
I: INTEGER;
BEGIN
StergeLini (17, 22);
WITH ArtLucru DO
BEGIN
WriteLn(' >> Nume: ', Nume); WriteLn(' >> Adresa: ',Adresa);
WriteLn(' >> Localitate: ', Oras); WriteLn(' >> Tara: ', Tara);
WriteLn(' >> Cod postal: ', CodPostal)
END
END;
PROCEDURE VerificareSpatiu;
VAR
Spatiu: INTEGER;
SpatiuReal¬ SpatiuArticol: REAL;
BEGIN
Spatiu := MemAvail;
IF Spatiu < 0 THEN SpatiuReal := 65536.0 + Spatiu
ELSE SpatiuReal := Spatiu;
SpatiuArticol := SpatiuReal / SizeOf (ArticolLista);
StergeLini (2, 3); WriteLn (' >> Exista spatiu pentru ',SpatiuArticol:6:0,
' articole in lista dumneavoastra.');
END;
PROCEDURE EliminareLista (VAR Radacina: ArtPtr);
VAR
Retine: ArtPtr;
BEGIN
GOTOXY(27, 10); Write(' >> Sinteti sigur (D/N) ? ');
IF Da THEN
IF Radacina <> NIL THEN
REPEAT
Retine := Radacina^.Urmator;
Dispose(Radacina);
Radacina := Retine
UNTIL Radacina = NIL;
StergeLini (10, 10); VerificareSpatiu
END;
PROCEDURE AdaugaArticole ( VAR Radacina: ArtPtr);
VAR
I: INTEGER;
Abandonº BOOLEAN;
ArtLucru: ArticolLista;
Ultim¬ Curent: ArtPtr;
BEGIN
GOTOXY(27, 7); Write ('<< Adaugare articole >>');
REPEAT
StergeLini (24, 24);
FillChar(ArtLucru, SizeOf(ArtLucru), CHR(0));
StergeLini(9, 15);
WITH ArtLucru DO
BEGIN
Write (' >> Nume: '); ReadLn (Nume);
Write (' >> Adresa: '); ReadLn (Adresa);
Write (' >> Localitate: '); ReadLn (Oras);
Write (' >> Tara: '); ReadLn (Tara);
Write (' >> Cod postal: '); ReadLn (CodPostal)
END; Abandon := FALSE;
IF Radacina = NIL THEN
BEGIN
New (Radacina); ArtLucru.Urmator := NIL; Radacina^ := ArtLucru
END
ELSE
BEGIN
Curent := Radacina;
REPEAT
IF Curent^.Nume = ArtLucru.Nume THEN
BEGIN
PrezentareArticol(Curent^);
GotoXY (1, 15); Write(' >> Articolul exista deja in lista. ',
'Abandonati introducerea (D/N) ? ');
IF Da THEN Abandon := TRUE ELSE Abandon := FALSE;
StergeLini (15, 22)
END; Ultim := Curent; Curent := Curent^.Urmator
UNTIL (Curent = NIL) OR Abandon OR (Curent^.Nume > ArtLucru.Nume);
IF NOT Abandon THEN
IF Radacina^.Nume > ArtLucru.Nume THEN
BEGIN
New (Radacina);
ArtLucru.Urmator:=Ultim;
Radacina^:=ArtLucru
END
ELSE
BEGIN
New (Ultim^.Urmator);
ArtLucru.Urmator := Curent;
Ultim^.Urmator^:=ArtLucru;
VerificareSpatiu
END
END;
GotoXY (1, 24); Write (' >> Adaugati un alt articol in lista (D/N) ? ')
UNTIL NOT Da
END;
PROCEDURE IncarcaLista (VAR Radacina: ArtPtr);
VAR
NumeLucru: String30;
FisierLucru: FisierPersoane;
Curent: ArtPtr;
I: INTEGER;
Ok: BOOLEAN;
BEGIN
Iesire := FALSE;
REPEAT
StergeLini (10, 10);
Write (' >> Introduceti numele fisierului ce se va incarca : ');
ReadLn (NumeLucru);
IF Length (NumeLucru) = 0 THEN
BEGIN StergeLini (10, 12); Iesire := TRUE END
ELSE
BEGIN
Assign (FisierLucru, NumeLucru);
Reset (FisierLucru);
IF IOResult <> 0 THEN
BEGIN
Write(' >> Acest fisier nu exista. Introduceti alt nume.');
Ok := FALSE
END
ELSE Ok := TRUE
END
UNTIL Ok OR Iesire;
IF NOT Iesire THEN
BEGIN
StergeLini (10, 12); Curent := Radacina;
IF Radacina = NIL THEN
BEGIN
New (Radacina);
Read(FisierLucru, Radacina^);
Curent := Radacina
END
ELSE
WHILE Curent^.Urmator <> NIL DÏ Curent := Curent^.Urmator;
IF Radacina^.Urmator <> NIL THEN
REPEAT
New (Curent^.Urmator);
Curent := Curent^.Urmator;
Read (FisierLucru, Curent^)
UNTIL Curent^.Urmator = NIL;
VerificareSpatiu; Close (FisierLucru)
END
END;
PROCEDURE VizualizareLista (Radacina: ArtPtr);
VAR
I: INTEGER;
FisierLucru: FisierPersoane;
Curent: ArtPtr;
BEGIN
IF Radacina = NIL THEN
BEGIN
GotoXY(27, 18); WriteLn(' >> Lista dv. este goala. '); GotoXY(26, 20);
Write(' >> Apasati <CR> pentru continuare ...'); ReadLn
END
ELSE
BEGIN
GotoXY(31, 7); Write(' >> Vizualizare articole <<');
Curent := Radacina;
WHILE Curent <> NIL DO
BEGIN
PrezentareArticol (Curent^); Curent := Curent^.Urmator;
GotoXY (1, 23);
Write('>> Apasati <CR> pentru a vizualiza urmatorul articol...');
ReadLn
END; StergeLini(19, 22)
END
END;
PROCEDURE SalvareLista (Radacina: ArtPtr);
VAR
NumeLucru: String30;
FisierLucru: FisierPersoane;
Curent: ArtPtr;
I: INTEGER;
BEGIN
GotoXY (1, 10);
Write (' >> Numele fisierului in care se va salva lista : ');
ReadLn (NumeLucru);
Assign (FisierLucru, NumeLucru);
Rewrite (FisierLucru);
Curent := Radacina;
WHILE Curent <> NIL DO
BEGIN
Write (FisierLucru, Curent^);
Curent := Curent^.Urmator
END;
Close (FisierLucru)
END;
BEGIN
ClrScr; GotoXY (28, 1); Write ('<< Construirea listei inlantuite >>');
VerificareSpatiu;
GotoXY (18,8); Write ('-------- ----- ------ ----');
Radacina := NIL; Iesire := FALSE;
REPEAT
StergeLini (4, 7); StergeLini (9, 24); GotoXY (1, 4);
WriteLn('>> [A]daugare articol, [I]ncarcare, [V]izualizare, [S]alvare,');
Write(' [E]liminare lista sau [T]erminare : ');
REPEAT
Ch := UpCase (ReadKey)
UNTIL Ch IN ['A', 'E', 'I', 'S', 'T', 'V']; WriteLn (Ch);
CASE Ch OF
'A' : AdaugaArticole (Radacina);
'E' : EliminareLista (Radacina);
'I' : IncarcaLista (Radacina);
'S' : SalvareLista (Radacina);
'T' : Iesire := TRUE;
'V' : VizualizareLista (Radacina)
END
UNTIL Iesire
END.
GetDirectory
(* >>> GetDirectory <<< -------- ----- ------ --- *)
(* Nume fisier : GETDIR.SRC *)
(* Rutina returneaza un pointer catre lista inlantuita cu *)
(* articole de tip DIRRec, articole ce trebuie predefinite, *)
(* impreuna cu tipul pointer DIRPtr care le refera : *)
(* DIRPtr= ^DIRRec; *)
(* DIRRec= RECORD *)
(* FileName: String15; *)
(* Attrib: BYTE; *)
(* FileSize: LONGINT; *)
(* TimeStamp: TimeRec; *)
(* DateStamp: DateRec; *)
(* Prior, *)
(* Next: DIRPtr *)
(* END; *)
(* Lista inlantuita va contine un articol pentru fiecare *)
(* fisier din directorul curent. *)
(* Tipurile TimeRec si DateRec trebuie sa fie definite *)
(* inainte de utilizarea rutinei GetDirectory; la fel si *)
(* tipul String80 si rutina DTAToDIR. *)
(* -------- ----- ------ ----- ----- -------------- *)
PROCEDURE GetDirectory (FileSpec: String80; Sorted, SortOnName: BOOLEAN;
VAR Ascending, Descending: DIRPtr);
TYPE
String9: STRING[9];
VAR
I, FindError: INTEGER;
Regs: Registers;
OurDTA: SearchRec;
Root, Current, Last, Holder: DIRPtr;
PositionFound: BOOLEAN;
FUNCTION LaterThan (LeftEntry, RightEntry: DIRPtr): BOOLEAN;
BEGIN
IF LeftEntry^.DateStamp.DateComp > RightEntry^.DateStamp.DateComp THEN
LaterThan := TRUE
ELSE
IF (LeftEntry^.DateStamp.DateComp = RightEntry^.DateStamp.DateComp)
AND
(LeftEntry^.TimeStamp.TimeComp > RightEntry^.TimeStamp.TimeComp) THEN
LaterThan := TRUE
ELSE
LaterThan := FALSE
END;
PROCEDURE AppendToEnd (VAR Holder, Descending: DIRPtr);
BEGIN
Descending^.Next := Holder;
Descending^.Next^.Prior := Descending;
Descending := Descending^.Next
END;
BEGIN
FindFirst (FileSpec, $16, OurDTA);
FindError := DOSError;
IF FindError = 2 THEN
BEGIN
Ascending := NIL;
Descending := NIL
END
ELSE
BEGIN
New (Root);
DTAToDIR(Root^);
Current := Root;
Descending := Root;
IF FindError <> 18 THEN
REPEAT
FindNext (OurDTA);
FindError := DOSError;
IF FindError <> 18 THEN
BEGIN
New(Holder);
DTAToDIR(Holder^);
IF Sorted THEN
BEGIN
Current := Root;
REPEAT
IF SortOnName THEN
IF Current^.FileName > Holder^.FileName THEN
PositionFound := TRUE
ELSE
PositionFound := FALSE
ELSE
IF LatherThan (Current, Holder) THEN
PositionFound := TRUE
ELSE
PositionFound := FALSE;
IF NOT PositionFound THEN
Current := Current^.Next
UNTIL (Current = NIL) OR PositionFound;
IF PositionFound THEN
BEGIN
IF Current = Root THEN
BEGIN
Holder^.Next := Root;
Current^.Prior := Holder;
Root := Holder
END
ELSE
BEGIN
Holder^.Next := Current;
Holder^.Prior := Current^.Prior;
Current^.Prior.Next := Holder;
Current^.Prior := Holder
END
END
ELSE
AppendToEnd (Holder, Descending)
END
ELSE
AppendToEnd (Holder, Descending)
END
UNTIL FindError = 18;
Ascending := Root
END
END;
Spacer
(* >>> Spacer <<< -------- ----- ------ ----------- *)
(* Nume fisier : SPACER.PAS *)
(* Program demonstrativ - gestiunea listei dublu inlantuite *)
(* Programul este de fapt un utilitar similar comenzii DIR din *)
(* DOS afisind fisierele conform specificatorului indicat. *)
(* -------- ----- ------ ----- ----- ---------------- *)
PROGRAM Spacer;
USES DOS;
CONST
SortByName= TRUE;
SortByDate= FALSE;
TYPE
String80= STRING[80];
String15= STRING[15];
DTAPtr= ^SearchRec;
VAR
Parms: BYTE;
SpaceTaken: REAL;
RunUp,
RunDown,
Current: DIRPtr;
FileSpec,
WorkString: String80;
Sorted,
SortSpec,
Ascending: BOOLEAN;
I: INTEGER;
BEGIN
Sorted := FALSE;
SortSpec := SortByName;
Ascending := TRUE;
Parms := ORD(ParamCount)
CASE Parms OF
0: BEGIN
WriteLn('>>SPACER<< V2.00 de Jeff Duntemann');
WriteLn(' din COMPLETE TURBO PASCAL V5.0');
WriteLn;
WriteLn(' Programul afiseaza toate directoarele ce corespund');
WriteLn('specificatorului indicat, inclusiv cele ascunse si sistem.');
WriteLn(' In plus, cumuleaza dimensiunile fisierelor gasite, afisind');
WriteLn('la sfirsit cantitatea totala ocupata de acestea.');
WriteLn; WriteLn; WriteLn(' Sintaxa apelului :'); WriteLn;
WriteLn(' SPACER <specificator_fisier> N|D A|D'); WriteLn;
WriteLn('unde <specificator_fisier> este un specificator de fisier');
WriteLn('legal DOS, inclusiv nume cu "*".');
WriteLn(' Al doilea parametru este N sau D :');
WriteLn(' N indica sortarea dupa nume;');
WriteLn(' D indica sortarea dupa data si timp.'); WriteLn;
WriteLn(' Al treilea parametru este A sau D :');
WriteLn(' A indica afisarea in ordine ascendenta;');
WriteLn(' D indica afisarea in ordine descendenta.');
WriteLn('Daca nu se indica acest parametru afisarea se face in')
WriteLn('ordine ascendenta.'); WriteLn;
WriteLn(' Daca nu se indica ultimi doi parametri afisarea se face');
WriteLn('in ordinea fizica.');
Halt
END;
1: FileSpec := ParamStr (1);
2: BEGIN
Sorted := TRUE;
FileSpec := ParamStr (1);
WorkString := ParamStr (2);
CASE UpCase (WorkString [1]) OF
'D': SortSpec := SortByDate;
'N': SortSpec := SortByName
ELSE Sorted := FALSE
END
END;
3: BEGIN
Sorted := TRUE;
FileSpec := ParamStr (1);
WorkString := ParamStr (2);
CASE UpCase (WorkString[1]) OF
'D': SortSpec := SortByDate;
'N': SortSpec := SortByName
ELSE Sorted := FALSE
END;
IF Sorted THEN
BEGIN
WorkString := ParamStr (3);
CASE UpCase (WorkString[1]) OF
'A': Ascending := TRUE;
'D': Ascending := FALSE
ELSE
Ascending := TRUE
END
END
END;
END;
GetDirectory (FileSpec, Sorted, SortSpec, RunUp, RunDown);
IF Ascending THEN Current := RunUp ELSE Current := RunDown;
IF Current = NIL THEN WriteLn ('Nu au fost gasite fisiere,')
ELSE
BEGIN
SpaceTaken := 0.0;
IF Ascending THEN
WHILE Current <> NIL DO
BEGIN
WriteLn (DirToString (Current^));
SpaceTaken := SpaceTaken + Current^.FileSize;
Current := Current^.Next
END
ELSE
WHILE Current <> NIL DO
BEGIN
WriteLn (DirToString (Current^));
SpaceTaken := SpaceTaken + Current^.FileSize;
Current := Current^.Prior
END;
WriteLn; Write('Spatiul total ocupat de aceste fisiere este ');
WriteLn(SpaceTaken:9:0, ' octeti.')
END
END.
DisposeOfDirectory
(* >>> DisposeOfDirectory <<< ----- ----- --------- ----- ------- *)
(* Nume fisier : DISPDIR.SRC *)
(* Rutina elibereaza articolele din lista construita cu *)
(* rutina GetDirectory. *)
(* Tipul DIRRec si DIRPtr trebuie sa fie definit inainte *)
(* de includerea acestei rutine. *)
(* -------- ----- ------ ----- ----- --------------- *)
PROCEDURE DisposeOfDirectory (RootPointer: DIRPtr);
VAR
Holder: DIRPtr;
BEGIN
IF RootPointer <> NIL THEN
REPEAT
Holder := RootPointer^.Next;
Dispose (RootPointer);
RootPointer := Holder
UNTIL RootPointer = NIL
END;
DrawMark
(* >>> DrawMarker <<< -------- ----- ------ ------- *)
(* Nume fisier : DRAWMARK.SRC *)
(* Aceasta rutina foloseste trasarea cu linii relative ptr. *)
(* a desena "poli-markere" in pozitia pointerului curent (CP). *)
(* Modelele ce se vor desena sint date in tablouri, fiecare *)
(* pereche de valori indicind "modificarea pe X" respectiv *)
(* "modificarea pe Y". Prima pereche de valori se foloseste *)
(* ptr. mutarea CP, nu ptr. trasare linie, astfel ca marcherul *)
(* sa fie complet in afara pozitiei CP. *)
(* -------- ----- ------ ----- ----- ---------------- *)
TYPE
PointArray= ARRAY[0..9, 0..1] OF INTEGER;
CONST
Lozenge: PointArray = ((0, -3), (-3, 3), (3, 3), (3, -3), (-3, -3),
(0, 0), (0, 0), (0, 0), (0, 0), (0, 0));
Cross: PointArray = ((0, 0), (0, -3), (0, 6), (0, -3), (3, 0),
(-6, 0), (0, 0), (0, 0), (0, 0), (0, 0));
Square: PointArray = ((-2, -2), (0, 4), (4, 0), (0, -4), (-4, 0),
(0, 0), (0, 0), (0, 0), (0, 0), (0, 0));
PROCEDURE DrawMarker (Marker: PointArray);
VAR
i: INTEGER;
BEGIN
MoveRel(Marker[0,0], Marker[0,1]);
i := 1;
WHILE NOT ((Marker[i,0] = 0) AND (Marker[i,1]) = 0)) DO
BEGIN LineRel (Marker[i,0], Marker[i,1]); Inc (i© END
END;
Square
(* >>> Square <<< -------- ----- ------ ---------- *)
(* Nume fisier : SQUARE.SRC *)
(* Rutina traseaza un patrat in X, Y care este simetric *)
(* independent de dispozitivul sau modul grafic curent. *)
(* Parametrul Side contine marimea laturei, in pixeli, iar *)
(* MeasureXAxis este o valoare logica care indica daca *)
(* marimea lui Side este masurata de-a lungul axei X sau a *)
(* axei Y. MeasureXAxis = TRUE presupune ca Side este masurat *)
(* de-a lungul axei X, si FALSE daca Side este masurat de-a *)
(* lungul axei Y. *)
(* -------- ----- ------ ----- ----- --------------- *)
PROCEDURE Square (x, y, Side: WORD; MeasureXAxis: BOOLEAN);
VAR
xa, ya,
xl, yl: WORD;
BEGIN
xl := Side; yl := Side; GetAspectRatio (xa, ya);
IF MeasureXAxis THEN yl := ROUND ((xa / xa) * Side)
ELSE xl := ROUND ((ya / xa) * Side);
Rectangle (x, y, x + xl, y + yl)
END;
AspectRatio
(* >>> AspectRatio <<< -------- ----- ------ ---- *)
(* Numele fisierului : SETASP.PAS *)
(* Programul demonstreaza reglarea raportului dimensional *)
(* (aspect ratio). *)
(* -------- ----- ------ ----- ----- -------------- *)
PROGRAM AspectRatio;
USES CRT, GRAPH;
VAR
i, Color,
GraphDriver,
GraphMode,
ErrorCode: INTEGER;
Palette : PaletteType;
PROCEDURE AdjustAspectRatio;
VAR
Side, Delta: INTEGER;
w, Color,
XAspect, YAspect: WORD;
Ch: CHAR;
Quit: BOOLEAN;
TheLine: STRING;
Filler: FillSettingsType;
PROCEDURE ShowRatio;
VAR
temp: STRING;
BEGIN
SetFillStyle (0, 0);
Bar (0, 0, GetMaxX, 20);
WITH Filler DO SetFillStyle (Pattern, Color);
GetAspectRatio (XAspect, YAspect);
TheLine := 'Raport curent : ';
STR (XAspect:6, temp);
TheLine := TheLine + temp + '/';
STR (YAspect:6, temp);
TheLine := TheLine + temp +
'. Sagetile pentru ajustare; Q pentru iesire ...';
OutTextXY (10, 10, TheLine)
END;
BEGIN
Quit := FALSE; Side := 180;
Color := GetColor;
GetFillSettings (Filler);
GetAspectRatio (XAspect, YAspect);
Delta := YAspect DIV 100;
Square ((GetMaxX DIV 2) - (Side DIV 2),
(GetMaxY DIV 2) - (Side DIV 2), Side, True);
ShowRatio;
REPEAT
Ch := UpCase (ReadKey);
IF Ch <> #0 THEN
IF Ch = 'Q' THEN Quit := TRUE ELSE Quit := FALSE
ELSE
BEGIN
Ch := ReadKey;
CASE ORD (Ch) OF
$48 : BEGIN
SetColor (0);
Square ((GetMaxX DIV 2) - (Side DIV 2),
(GetMaxY DIV 2) - (Side DIV 2), Side, True);
w := YAspect + Delta;
SetAspectRatio (XAspect, w); SetColor (Color);
Square ((GetMaxX DIV 2) - (Side DIV 2),
(GetMaxY DIV 2) - (Side DIV 2), Side, True);
ShowRatio
END;
$50 : BEGIN
SetColor (0);
Square ((GetMaxX DIV 2) - (Side DIV 2),
(GetMaxY DIV 2) - (Side DIV 2), Side, True);
w := YAspect - Delta;
SetAspectRatio (XAspect, w); SetColor (Color);
Square ((GetMaxX DIV 2) - (Side DIV 2),
(GetMaxY DIV 2) - (Side DIV 2), Side, True);
ShowRatio
END;
END
END
UNTIL Quit
END;
BEGIN
GraphDriver := Detect;
InitGraph (GraphDriver, GraphMode, '');
ErrorCode := GraphResult;
IF ErrorCode <> 0 THEN
BEGIN
WriteLn (' >> Oprire datorita erorii grafice : ',
GraphErrorMsg (ErrorCode));
HALT (2)
END;
AdjustAspectRatio;
CloseGraph
END.
Halucinatii
(* >>> Halucinatii <<< -------- ----- ------ ---- *)
(* Nume fisier : GRAPHABS.PAS *)
(* Programul demonstreaza comutarea paletei culorilor din *)
(* sistemul grafic BGI. *)
(* -------- ----- ------ ----- ----- -------------- *)
PROGRAM Halucinatii;
USES CRT, GRAPH;
VAR
i, Color: INTEGER;
Palette: PaletteType;
GraphDriver, GraphMode, ErrorCode: INTEGER;
BEGIN
GraphDriver := Detect;
InitGraph (GraphDriver, GraphMode, '');
ErrorCode := GraphResult;
IF ErrorCode <> 0 THEN
BEGIN
WriteLn ('>> Abandonarea programului datorita erorii');
WriteLn (' grafice : ', GraphErrorMsg (ErrorCode));
Halt (2)
END;
SetBkColor (White);
Randomize;
GetPalette (Palette);
FOR Color := 0 TO 10000 DO
BEGIN
SetColor (Random (Palette.Size));
Line (Random (GetMaxX), Random (GetMaxY),
Random (GetMaxX), Random (GetMaxY))
END;
REPEAÔ
REPEAÔ i := Random (Palette.Size© UNTIL i <> 0;
SetPalette (i, Random (Palette.Size))
UNTIL KeyPressed;
CloseGraph
END.
Patterns
(* >>> Patterns <<< -------- ----- ------ ------ *)
(* Nume fisier : PATTERNS.PAS *)
(* Program demonstrativ - modele de umplere grafice. *)
(* (patterns) *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM Patterns;
USES GRAPH;
CONST
HalfTone1: FillPatternType ½ ($CC, $33, $CC, $33, $CC, $33, $CC, $33);
HalfTone2: FillPatternType ½ ($AA, $55, $AA, $55, $AA, $55, $AA, $55);
Squiggles: FillPatternType ½ ($94, $84, $48, $30, $00, $C1, $22, $14);
Vertical: FillPatternType ½ ($CC, $CC, $CC, $CC, $CC, $CC, $CC, $CC);
Bricks: FillPatternType ½ ($01, $82, $44, $28, $10, $20, $40, $80);
Blocks: FillPatternType ½ ($00, $3C, $42, $42, $42, $42, $3C, $00);
VAR
GraphDriver,
GraphMode,
ErrorCode: INTEGER;
BEGIN
GraphDriver := Detect;
InitGraph (GraphDriver, GraphMode, '');
ErrorCode := GraphResult;
IF ErrorCode <> 0 THEN
BEGIN
WriteLn ('>> Abandonarea programului datorita unei erori');
WriteLn (' grafice : ', GraphErrorMsg (ErrorCode)); Halt (2)
END;
SetFillPattern (HalfTone1, White);
Bar (0, 0, 99, 100); Rectangle (0, 0, 99, 100);
SetFillPattern (HalfTone2, White);
Bar (110, 0, 209, 100); Rectangle (110, 0, 209, 100);
SetFillPattern (Squiggles, White);
Bar (220, 0, 319, 100); Rectangle (220, 0, 319, 100);
SetFillPattern (Vertical, White);
Bar (0, 105, 99, 199); Rectangle (0, 105, 99, 199);
SetFillPattern (Bricks, White);
Bar (110, 105, 209, 199); Rectangle (110, 105, 209, 199);
SetFillPattern (Blocks, White);
Bar (220, 105, 319, 199); Rectangle (220, 105, 319, 199);
ReadLn; CloseGraph
END.
Polygons
(* >>> Polygons <<< -------- ----- ------ ------- *)
(* Nume fisier : POLYGONS.PAS *)
(* Program demonstrativ - desenare si hasurare poligoane. *)
(* -------- ----- ------ ----- ----- -------------- *)
PROGRAM Polygons;
USES GRAPH;
CONST
Squiggles: FillPatternType = ($94, $84, $48, $30, $00, $C1, $22, $14);
Pentagon: ARRAY[0..5] OF PointType =
((X: 100; Y: 10), (X: 200; Y: 80),
(X: 155; Y: 160), (X: 45; Y: 160),
(X: 0; Y: 80), (X: 100; Y: 10));
BigDipper: ARRAY[0..5] OF PointType =
((X: 350; Y: 20), (X: 420; Y: 35),
(X: 475; Y: 100), (X: 450; Y: 160),
(X: 530; Y: 195), (X: 600; Y: 130));
VAR
GraphDriver, GraphMode, i, ErrorCode: INTEGER;
BEGIN
GraphDriver := Detect;
InitGraph (GraphDriver, GraphMode, '');
ErrorCode := GraphResult;
IF ErrorCode <> 0 THEN
BEGIN
WriteLn (' >> Abandonare program; Eroare grafica : ',
GraphErrorMsg (ErrorCode));
Halt (2)
END;
SetFillPattern (Squiggles, White);
DrawPoly (6, Pentagon);
FOR i := 0 TO 5 DO
Pentagon[i].Y := Pentagon[i].Y + 160;
FillPoly (6, Pentagon);
DrawPoly (6, BigDipper);
FOR i := 0 TO 5 DO
BigDipper[i].Y := BigDipper[i].Y + 140;
FillPoly (6, BigDipper);
ReadLn; CloseGraph
END.
RoundedRectangle
(* >>> RoundedRectangle >>> ----- ----- --------- ----- -------- *)
(* Nume fisier : ROUNDRCT.SRC *)
(* Rutina deseneaza un dreptunghi in punctul de coordonate *)
(* X si Y; dimensiunile in pixeli este Width (latime) si *)
(* Height (inaltime); colturile sint rotunjite ca raza R. *)
(* -------- ----- ------ ----- ----- -------------- *)
PROCEDURE RoundedRectangle (X, Y, Width, Height, R: WORD);
VAR
ULData,
LLData,
LRData,
URData: ArcCoordsType;
BEGIN
Arc (X + R, Y + R, 90, 180, R);
GetArcCoords (ULData);
Arc (X + R, Y + Height + R, 180, 270, R);
GetArcCoords (LLData);
Arc (X + Width + R, Y + Height + R, 270, 360, R);
GetArcCoords (LRData);
Arc (X + Width + R, Y + R, 0, 90, R);
GetArcCoords (URData);
Line (ULData.XEnd, ULData.YEnd, LLData.XStart, LLData.YStart);
Line (LLData.XEnd, LLData.YEnd, LRData.XStart, LRData.YStart);
Line (LRData.XEnd, LRData.YEnd, URData.XStart, URData.YStart);
Line (URData.XEnd, URData.YEnd, ULData.XStart, ULData.YStart);
END;
PieMan
(* >>> PieMan <<< -------- ----- ------ --------- *)
(* Nume fisier : PIEMAN.PAS *)
(* Program demonstrativ - utilizarea procedurii PieSlice. *)
(* -------- ----- ------ ----- ----- -------------- *)
PROGRAM PieMan;
USES GRAPH;
CONST
HalfTone1: FillPatternType = ($CC, $33, $CC, $33, $CC, $33, $CC, $33);
HalfTone2: FillPatternType = ($AA, $55, $AA, $55, $AA, $55, $AA, $55);
Squiggles: FillPatternType = ($94, $84, $48, $30, $00, $C1, $22, $14);
Vertical: FillPatternType = ($CC, $CC, $CC, $CC, $CC, $CC, $CC, $CC);
Bricks: FillPatternType = ($01, $82, $44, $28, $10, $20, $40, $80);
Blocks: FillPatternType = ($00, $3C, $42, $42, $42, $42, $3C, $00);
VAR
GraphDriver,
GraphMode,
ErrorCode: INTEGER;
BEGIN
GraphDriver := Detect;
InitGraph (GraphDriver, GraphMode, '');
ErrorCode := GraphResult;
IF ErrorCode <> 0 THEN
BEGIN
WriteLn ('>> Abandonarea programului datorita unei erori');
WriteLn (' grafice : ', GraphErrorMsg (ErrorCode));
Halt (2)
END;
RoundedRectangle (30, 30, 300, 260, 35);
PieSlice (220, 160, 0, 45, 120);
SetFillPattern (Bricks, White); PieSlice (220, 160, 45, 110, 120);
SetFillPattern (Squiggles, White); PieSlice (220, 160, 110, 130, 120);
SetFillPattern (Halftone1, White); PieSlice (220, 160, 130, 200, 120);
SetFillPattern (Blocks, White); PieSlice (220, 160, 200, 245, 120);
SetFillPattern (Halftone2, White); PieSlice (220, 160, 245, 295, 120);
SetFillPattern (Vertical, White); PieSlice (220, 160, 295, 360, 120);
SetFillStyle (SolidFill, White); PieSlice (500, 230, 0, 360, 70);
SetFillPattern (Bricks, White); PieSlice (500, 75, 0, 360, 70);
SetLineStyle (3, 0, 1);
SetFillStyle (EmptyFill, White); PieSlice (400, 360, 0, 40, 75);
ReadLn; CloseGraph
END.
FontsBGI
(* >>> FontsBGI <<< -------- ----- ------ ------- *)
(* Nume fisier : FONTSBGI.PAS *)
(* Program demonstrativ - fonturile grafice din BGI. *)
(* -------- ----- ------ ----- ----- -------------- *)
PROGRAM FontsBGI;
USES GRAPH;
VAR
i, j, k, GraphDriver, GraphMode, ErrorCode: INTEGER;
TestString: STRING;
BEGIN
GraphDriver := Detect; InitGraph (GraphDriver, GraphMode, '');
ErrorCode := GraphResult;
IF ErrorCode <> 0 THEN
BEGIN
WriteLn ('>> Abandonarea programului datorita unei erori');
WriteLn (' grafice : ', GraphErrorMsg (ErrorCode)); Halt (2)
END;
j := 0; (ª --- Fonôul impliciô --- *)
FOR i := 1 TO 3 DO
BEGIN
SetTextStyle (DefaultFont, HorizDir, i);
OutTextXY (0, j, 'Font implicit');
j := j + 5 + TextHeight('Font implicit')
END;
j := 60; TestString := 'Font mic'; (ª --- Fontuì SmallFonô --- *)
FOR i := 4 TO 8 DO
BEGIN
SetTextStyle (SmallFont, HorizDir, i); OutTextXY (0, j, TestString);
j := j + TextHeight (TestString)
END;
j := 100; TestString := 'Font triplat'; (ª --- Fontuì TriplexFonô --- *)
FOR i := 4 TO 10 DO
BEGIN
SetTextStyle (SmallFont, HorizDir, i); OutTextXY (320, j, TestString);
j := j + TextHeight (TestString)
END;
j := 155; TestString := 'SansSerif'; (ª --- Fontuì SansSeriæ --- *)
FOR i := 4 TO 10 DO
BEGIN
SetTextStyle (SansSerifFont, HorizDir, i); OutTextXY (0, j, TestString);
j := j + TextHeight (TestString)
END;
j := 120; TestString := 'Gothic'; (ª --- Fontuì Gothiã --- *)
FOR i := 4 TO 7 DO
BEGIN
SetTextStyle (GothicFont, VertDir, i); OutTextXY (j, 70, TestString);
j := j + TextHeight (TestString)
END;
ReadLn; CloseGraph
END.
DemoMenu
(* >>> DemoMenõ <<< -------- ----- ------ ------- *)
(* Nume fisier : DEMOMENU.DEF *)
(* Fisierul contine constantele structurate necesare *)
(* afisarii meniurilor "pull-down" si sint folosite in *)
(* unit-ul PULDOWN.PAS. *)
(* Continutul fisierului se va modifica in functie de *)
(* aplicatie. *)
(* Tipul MenuDesc este definit in unit_ul PullDown. *)
(* -------- ----- ------ ----- ----- -------------- *)
CONST
DemoMenu: MenuDesc =
((XStart: 18; XEnd: 58;
Title: 'Fisiere';
MenuSize: 11;
ImagePtr: NIL;
Active: TRUE;
Choices: 5; ItemList:
((Item: 'Receptie'; ItemCode: 21; ItemActive: TRUE),
(Item: 'Salvare '; ItemCode: 22; ItemActive: TRUE),
(Item: 'Stergere'; ItemCode: 23; ItemActive: TRUE),
(Item: 'Redenumire'; ItemCode: 24; ItemActive: TRUE),
(Item: 'Iesire'; ItemCode: 25; ItemActive: TRUE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 74; XEnd: 114;
Title: 'Editare';
MenuSize: 11;
ImagePtr: NIL;
Active: TRUE;
Choices: 9; ItemList:
((Item: 'Grab'; ItemCode: 31; ItemActive: TRUE),
(Item: 'Pull'; ItemCode: 32; ItemActive: TRUE),
(Item: 'Erase'; ItemCode: 33; ItemActive: TRUE),
(Item: 'Join'; ItemCode: 34; ItemActive: TRUE),
(Item: 'Swap'; ItemCode: 35; ItemActive: TRUE),
(Item: 'Invert'; ItemCode: 36; ItemActive: TRUE),
(Item: 'Recolor'; ItemCode: 37; ItemActive: TRUE),
(Item: 'Split'; ItemCode: 38; ItemActive: TRUE),
(Item: 'Duplicate'; ItemCode: 39; ItemActive: TRUE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 129; XEnd: 175;
Title: 'Desen';
MenuSize: 11;
ImagePtr: NIL;
Active: TRUE;
Choices: 4; ItemList:
((Item: 'Freehand'; ItemCode: 41; ItemActive: TRUE),
(Item: 'PolyLine'; ItemCode: 42; ItemActive: TRUE),
(Item: 'Spray'; ItemCode: 43; ItemActive: TRUE),
(Item: 'Dragstemp'; ItemCode: 44; ItemActive: TRUE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 179; XEnd: 215;
Title: 'Text';
MenuSize: 11;
ImagePtr: NIL;
Active: TRUE;
Choices: 5; ItemList:
((Item: 'Load Font'; ItemCode: 51; ItemActive: TRUE),
(Item: 'Place Text'; ItemCode: 52; ItemActive: TRUE),
(Item: 'Set Direction'; ItemCode: 53; ItemActive: TRUE),
(Item: 'Dropsshadow'; ItemCode: 54; ItemActive: TRUE),
(Item: 'Point Size'; ItemCode: 55; ItemActive: TRUE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 15; XEnd: 55;
Title: '';
MenuSize: 0;
ImagePtr: NIL;
Active: FALSE;
Choices: 0; ItemList:
((Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 15; XEnd: 55;
Title: '';
MenuSize: 0;
ImagePtr: NIL;
Active: FALSE;
Choices: 0; ItemList:
((Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 15; XEnd: 55;
Title: '';
MenuSize: 0;
ImagePtr: NIL;
Active: FALSE;
Choices: 0; ItemList:
((Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 15; XEnd: 55;
Title: '';
MenuSize: 0;
ImagePtr: NIL;
Active: FALSE;
Choices: 0; ItemList:
((Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 15; XEnd: 55;
Title: '';
MenuSize: 0;
ImagePtr: NIL;
Active: FALSE;
Choices: 0; ItemList:
((Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 15; XEnd: 55;
Title: '';
MenuSize: 0;
ImagePtr: NIL;
Active: FALSE;
Choices: 0; ItemList:
((Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 15; XEnd: 55;
Title: '';
MenuSize: 0;
ImagePtr: NIL;
Active: FALSE;
Choices: 0; ItemList:
((Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 15; XEnd: 55;
Title: '';
MenuSize: 0;
ImagePtr: NIL;
Active: FALSE;
Choices: 0; ItemList:
((Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))),
(XStart: 15; XEnd: 55;
Title: '';
MenuSize: 0;
ImagePtr: NIL;
Active: FALSE;
Choices: 0; ItemList:
((Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE),
(Item: ''; ItemCode: 0; ItemActive: FALSE))));
PullDown
(* >>> PullDowN <<< -------- ----- ------ ------ *)
(ª Nume fisier º PULLDOWN.PAS *)
(* Sistem grafic de meniuri derulantE "pull-down". *)
(* -------- ----- ------ ----- ----- ------------- *)
UNIT PullDown;
INTERFACE
USES DOS, GRAPH, CRT, Mouse;
TYPE
String15= STRING[15];
ItemRec = RECORD
Item : String15;
ItemCode : BYTE;
ItemActive: BOOLEAN
END;
MenuRec = RECORD
XStart, XEnd: WORD;
Title: String15;
MenuSize: WORD;
ImagePtr: POINTER;
Active: BOOLEAN;
Choices: BYTE;
ItemList: ARRAY [0..18] OF ItemRec
END;
MenuDesc = ARRAY[0..12] OF MenuRec;
PROCEDURE ActivateMenu (VAR CurrentMenu: MenuDesc; MenuNumber: BYTE);
PROCEDURE DeactivateMenu (VAR CurrentMenu: MenuDesc; MenuNumber: BYTE);
PROCEDURE ActivateItem (VAR CurrentMenu: MenuDesc; Code: BYTE);
PROCEDURE DeactivateItem (VAR CurrentMenu: MenuDesc; Code: BYTE);
FUNCTION InvalidMenu (CurrentMenu: MenuDesc; VAR BadCode: BYTE): BOOLEAN;
PROCEDURE SetUpMenu (CurrentMenu : MenuDesc);
PROCEDURE Menu (CurrentMenu: MenuDesc; VAR ReturnCode: WORD;
VAR Amulet: BOOLEAN);
IMPLEMENTATION
PROCEDURE ChangeItemStatus (VAR CurrentMenu: MenuDesc;
Code: BYTE; ToActive: BOOLEAN);
(* -------- ----- ------ ----- ----- ------------*)
(* Rutina este locala unit-ului PullDown si asigura *)
(* modificarea starii (selectat sau nu) unui articol din *)
(* meniul "pull-down". *)
(*-------- ----- ------ ----- ----- -------------*)
VAR
I, MenuNumber: BYTE;
ItemFound: BOOLEAN;
BEGIN
MenuNumber := 0; ItemFound := FALSE;
REPEAT
WITH CurrentMenu[MenuNumber] DO
BEGIN
i := 0;
REPEAT
IF ItemList[i].ItemCode = Code THEN
BEGIN
ItemList[i].ItemActive := ToActive;
ItemFound := TRUE;
IF ImagePtr <> NIL THEN
BEGIN
FreeMem (ImagePtr, MenuSize);
ImagePtr := NIL
END
END
ELSE INC (i)
UNTIL ItemFound OR (i > Choices)
END;
INC (MenuNumber)
UNTIL ItemFound OR (MenuNumber > 12)
END;
PROCEDURE ActivateMenu (VAR CurrentMenu: MenuDesc; MenuNumber: BYTE);
(* -------- ----- ------ ----- ----- -------------*)
(* Rutina activeaza meniul specificat prin MenuNumber, *)
(* indiferent daca acesta a fost sau nu activ la invocare. *)
(* ImagePtr este setat pe NIL si meniul va fi redesenat. *)
(*-------- ----- ------ ----- ----- --------------*)
BEGIN
WITH CurrentMenu[MenuNumber] DO
BEGIN
ImagePtr := NIL; Active := TRUE
END
END;
PROCEDURE DeactivateMenu (VAR CurrentMenu: MenuDesc; MenuNumber: BYTE);
(* -------- ----- ------ ----- ----- -------------*)
(* Rutina inactiveaza meniul specificat prin MenuNumber, *)
(* indiferent daca acesta este activ sau nu la apelare. *)
(* ImagePtr este setat pe NIL si meniul va fi redesenat. *)
(*-------- ----- ------ ----- ----- --------------*)
BEGIN
WITH CurrentMenu[MenuNumber] DO
BEGIN
ImagePtr := NIL; Active := FALSE
END
END;
PROCEDURE ActivateItem (VAR CurrentMenu: MenuDesc; Code: BYTE);
(* -------- ----- ------ ----- ----- -------------*)
(* Rutina activeaza articolul cu codul Code, indiferent *)
(* de starea articolului la invocare. ImagePtr este setat *)
(* pe NIL astfel ca meniul va fi redesenat. *)
(*-------- ----- ------ ----- ----- --------------*)
BEGIN
ChangeItemStatus (CurrentMenu, Code, TRUE)
END;
PROCEDURE DeactivateItem (VAR CurrentMenu: MenuDesc; Code: BYTE);
(* -------- ----- ------ ----- ----- -------------*)
(* Rutina inactiveaza articolul cu codul Code, indiferent *)
(* de starea articolului la invocare. ImagePtr este setat *)
(* pe NIL astfel ca meniul va fi redesenat. *)
(*-------- ----- ------ ----- ----- --------------*)
BEGIN
ChangeItemStatus (CurrentMenu, Code, FALSE)
END;
FUNCTION InvalidMenu (CurrentMenu: MenuDesc; VAR BadCode: BYTE): BOOLEAN;
(* -------- ----- ------ ----- ----- -------------*)
(* Functia verifica daca nu exista un cod duplicat in *)
(* cadrul tabloului meniu transmis prin CurrentMenu. *)
(* Intotdeauna sistemul de meniuri acepta numai articole *)
(* de meniuri cu coduri unice. *)
(* Aceasta functie se va executa pentru orice tablou de *)
(* meniuri pe care doriti sa le folositi si abandonati *)
(* programul daca se detecteaza un cod dublu. *)
(*-------- ----- ------ ----- ----- --------------*)
VAR
i, j : WORD;
OrdSet: SET OF BYTE;
DuplicateFound: BOOLEAN;
BEGIN
DuplicateFound := FALSE;
OrdSet := [];
FOR i := 0 TO 12 DO
WITH CurrentMenu[i] DO
BEGIN
j := 0;
REPEAT
IF ItemList[j].ItemCode > 0 THEN
IF ItemList[j].ItemCode IN OrdSet THEN
BEGIN
DuplicateFound := TRUE;
BadCode := ItemList[j].ItemCode
END
ELSE
BEGIN
OrdSet := OrdSet + [ItemList[j].ItemCode]; INC (j)
END
ELSE INC (j)
UNTIL (j > Choices) OR DuplicateFound
END;
InvalidMenu := DuplicateFound
END;
PROCEDURE SetUpMenu (CurrentMenu: MenuDesc);
(* -------- ----- ------ ----- ----- -------------*)
(* Rutina initializeaza afisarea barei meniu, a titlurilor*)
(* si a amuletei barei meniu. *)
(*-------- ----- ------ ----- ----- --------------*)
VAR
i,
DrawX,
DrawY: WORD;
BEGIN
SetFillStyle (SolidFill, White);
Bar (0, 0, GetMaxX, 11);
SetColor (0);
Rectangle (2, 1, 12, 9);
FOR i := 3 TO 8 DO IF ODD (i) THEN Line (4, 1, 10, 1);
DrawX := CurrentMenu[0].XStart;
DrawY := 2;
i := 0;
REPEAT
OutTextXY (DrawX, DrawY, CurrentMenu[i].Title);
INC (i);
DrawX := CurrentMenu[i].XStart
UNTIL (LENGTH (CurrentMenu[i].Title) = 0) OR (i > 13)
END;
PROCEDURE Menu (CurrentMenu: MenuDesc; VAR ReturnCode: WORD;
VAR Amulet: BOOLEAN);
(* -------- ----- ------ ----- ----- -------------*)
(* Este rutina principala pentru meniuri. Este necesar ca *)
(* inaintea ei sa se fi executat rutinele InvalidMenu si *)
(* SetUpMenu. Selectarea unei comenzi din bara meniu se *)
(* face prin pozitionarea mouse-ului pe cuvintul dorit, *)
(* dupa care se muta mouse-ul in meniul "pull-down" si se *)
(* alege optiunea prin apsarea pe butonul dreapta. *)
(* Codul articolului selectat este furnizat in ReturnCode.*)
(* ReturnCode este 0 daca nu se selecteaza un articol. *)
(*-------- ----- ------ ----- ----- --------------*)
VAR
PointerX, PointerY: Word;
Left, Center, Right: BOOLEAN;
I, J,
MenuWidth,
M1X, M1Y,
M2X, M2Y: INTEGER;
FoundMenu: BOOLEAN;
SaveColor: INTEGER;
UnderMenu: POINTER;
BounceBar: POINTER;
Pick: WORD;
UpperBound, LowerBound: INTEGER;
PROCEDURE RestoreUnderMenuBox ;
BEGIN
PointerOff;
PutImage (M1X, M1Y, UnderMenu^, NormalPut);
PointerOn
END;
BEGIN
Amulet := FALSE; SaveColor := GetColor; SetColor (White);
PollMouse (PointerX, PointerY, Left, Right, Center);
IF (PointerX > 1) AND (PointerX < 13) AND
(PointerY > 0) AND (PointerY < 10) THEN
BEGIN
Amulet := TRUE;
SetColor (SaveColor);
EXIT
END;
i := -1;
REPEAT
i := 1 + 1;
IF (PointerX >= CurrentMenu[i].XStart) AND
(PointerX <= CurrentMenu[i].XEnd) AND
CurrentMenu[i].Active THEN FoundMenõ := True
FoundMenu := TRUE
ELSE FoundMenu := FALSE
UNTIL FoundMenu OR (LENGTH (CurrentMenu[i].Title) = 0) OR (i > 13);
IF FoundMenu THEN
BEGIN
PointerOff;
WITH CurrentMenu[i] DO
BEGIN
MenuWidth := 0;
FOR j := 0 TO Choices - 1 DO
IF LENGTH (ItemList[j].Item) > MenuWidth THEN
MenuWidth := LENGTH (ItemList[j].Item);
MenuWidth := MenuWidth * 8;
M1X := XStart; M1Y := 11; M2X := XStart + MenuWidth + 6;
M2Y := (Choices + 1) * 12;
MenuSize := ImageSize (M1X, M1Y, M2X, M2Y);
GetMem (UnderMenu, MenuSize);
GetImage(M1X, M1Y, M2X, M2Y, UnderMenu^);
SetFillStyle (SolidFill, Black); Bar (M1X, M1Y, M2X, M2Y);
SetFillStyle (SolidFill, White);
GetMem(BounceBar,ImageSize(M1X +1,M1Y + 1,M2X - 1,M1Y + 12));
Bar (M1X + 1, M1Y + 1, M2X - 1, M1Y + 12);
GetImage (M1X + 1, M1Y + 1, M2X -1, M2Y + 12, BounceBar^);
IF ImagePtr = NIL THEN
BEGIN
Rectangle (M1X, M1Y, M2X, M2Y);
SetColor (Black);
IF ItemList[0].ItemActive THEN
OutTextXY (XStart + 3, 14, ItemList[0].Item);
SetColor(White);
FOR j := 1 TO Choices - 1 DO
IF ItemList[j].ItemActive THEN
OutTextXY(XStart + 3,14 * (j * 12), ItemList[j].Item);
GetMem(ImagePtr, MenuSize);
GetImage(M1X, M1Y, M2X, M2Y, ImagePtr^)
END;
PutImage (M1X, M1Y, ImagePtr^, NormalPut);
PointerOn;
UpperBound := 12;
LowerBound := 24;
Pick := 0;
REPEAT
PollMouse (PointerX, PointerY, Left, Center, Right);
IF (PointerX<M1X) OR (PointerX>M2X) OR (PointerY>M2Y) THEN
Right := TRUE
ELSE
BEGIN
IF PointerY < UpperBound THEN
IF PointerY>12 THEN
BEGIN
PointerOff;
IF ItemList[Pick].ItemActive THEN
PutImage(M1X + 1,UpperBound,BounceBar^,XORPut);
UpperBound := UpperBound - 12;
LowerBound := LowerBound - 12;
Pick := Pick - 1;
IF ItemList[Pick].ItemActive THEN
PutImage(M1X + 1,UpperBound,BounceBar^,XORPut);
PointerOn
END;
IF PointerY > LowerBound THEN
BEGIN
PointerOff;
IF ItemList[Pick].ItemActive THEN
PutImage (M1X + 1, UpperBound, BounceBar^,XORPut);
UpperBound := UpperBound + 12;
LowerBound := LowerBound + 12;
Pick := Pick + 1;
IF ItemList[Pick].ItemActive THEN
PutImage (M1X +1, UpperBound, BounceBar^, XORPut);
PointerOn
END
END;
UNTIL (NOT Left) OR Right;
RestoreUnderMenuBox;
IF Right THEN ReturnCode := 0
ELSE
IF ItemList[Pick].ItemActive THEN
ReturnCode := ItemList[Pick].ItemCode
ELSE ReturnCode := 0
END;
PointerOn
END;
SetColor (SaveColor)
END;
END.
Scrrible
(* >>> Scribble <<< -------- ----- ------ ---- *)
(* Nume fisier : SCRIBBLE.PAS *)
(* Program demonstrativ - meniuri "pull down". *)
(* -------- ----- ------ ----- ----- ----------- *)
PROGRAM Scribble;
USES DOS, CRT, GRAPH, Mouse, PullDown;
VAR
GraphDriver, GraphMode, ErrorCode, i, j: INTEGER;
R: REAL;
M1, M2, M3, M4, ReturnCode: WORD;
XText, YText, Mule: STRING;
PointerX, PointerY: WORD;
Left, Center, Right, Amulet, Quit: BOOLEAN;
DuplicateCode: BYTE;
ExitSave: POINTER;
SaveColor: WORD;
Palette: PaletteType;
Color: Word;
PROCEDURE ReturnToTextMode;
BEGIN
PointerOff;
CloseGraph;
ExitProc := ExitSave
END;
BEGIN
ExitSave := ExitProc;
ExitProc := @ReturnToTextMode;
ClrScr;
IF InvalidMenu (DemoMenu, DuplicateCode) THEN
BEGIN
WRITELN('>>> Abandonare pentru meniu dublu : ', DuplicateCode); HALT (1)
END;
GraphDriver := Detect;
InitGraph (GraphDriver, GraphMode, '');
IF ErrorCode <> 0 THEN
BEGIN
WRITELN('>>> Abandonare pentru eroarea grafica : ',
GraphErrorMsg (ErrorCode));
HALT (2)
END;
SetUpMenu(DemoMenu); PointerOn; SetColor(Yellow); Quit := FALSE;
REPEAT
PollMouse (PointerX, PointerY, Left, Center, Right);
IF Left THEN
BEGIN
IF PointerY < 12 THEN
BEGIN
Menu (DemoMenu, ReturnCode, Amulet);
PollMouse (PointerX, PointerY, Left, Center, Right);
MoveTo (PointerX, PointerY);
IF ReturnCode <> 0 THEN
CASE ReturnCode OF
25 : Quit := TRUE;
END;
END
ELSE
IF (GetX <> PointerX) OR (GetY <> PointerY) THEN
BEGIN
PointerOff;
LineTo (PointerX, PointerY);
PointerOn
END
END
ELSE
MoveTo (PointerX, PointerY)
UNTIL KeyPressed OR Quit
END.
VarDump
(* >>> VarDump <<< -------- ----- ------ --- *)
(* Nume fisier : VARDUMP.SRC *)
(* Rutina afiseaza un vidaj hexazecimal a tuturor *)
(* variabilelor sau constantelor cu tip transmise in *)
(* parametrul VAR fara tip, Target. VarDump apeleaza *)
(* WriteHex; fiti siguri ca WriteHex este disponibil. *)
(* -------- ----- ------ ----- ----- --------- *)
PROCEDURE VarDump ( VAR Device: TEXT; VAR Target; ItSize: INTEGER);
CONST
Printables: SET OF CHAR= [' '..'>'];
VAR
i, j, Full, Left: INTEGER;
DumpIt: ARRAY[0..MaxInt] OF BYTE ABSOLUTE Target;
PROCEDURE DumpLine (Offset, ByteCount: INTEGER);
VAR
i: INTEGER;
BEGIN
FOR i := 0 TO ByteCount - 1 DO
BEGIN
WriteHex (Device, DumpIt ([(Offset * 16) + i]);
Write (device, ' ')
END;
FOR i := 0 TO 56 - (ByteCount * 3) DO Write (Device, ' ');
Write (Device ,'|');
FOR i := 0 TO ByteCount - 1 DO
IF CHR (DumpIt[(Offset * 16) + i]) IN Printables THEN
Write (Device, CHR(DumpIt[(Offset * 16) + i]))
ELSE Write (Device, '.');
Write (Device, '|')
END;
BEGIN
Full := ItSize DIV 16;
Left := ItSize MOD 16;
FOR i := 0 TO Full - 1 DO
DumpLine (i, 16);
IF Left > 0 THEN
DumpLine (Full, Left);
WriteLn (Device)
END;
ShowHelp
(* >>> ShowHelp <<< -------- ----- ------ -- *)
(* Nume fisier : SHOWHELP.SRC *)
(* Rutina reprezinta un sistem simplu de help pe un *)
(* singur ecran. Sistemul asigura salvarea ecranului cu *)
(* informatiile utile, afisarea ecranului cu informatia *)
(* help si restaurarea ecranului initial la apasarea *)
(* unei taste. Dv. trebuie sa inlocuiti informati help *)
(* din ShowHelpData cu ceea ce doriti sa afisati (aici *)
(* este prezentat un exemplu pentru programul JTERM). *)
(* Informatia help se afiseaza atunci cind se apasa *)
(* tasta functionala F1. *)
(* -------- ----- ------ ----- ----- --------- *)
PROCEDURE ShowHelp;
CONST
ScreenX= 80;
ScreenY= 25;
VAR
XSave, YSave: INTEGER;
VideoSeg, VidSegment, VideoBufferSize: WORD;
SavePtr, VideoPtr: ^WORD;
Dummy: CHAR;
FUNCTION Monochrome: BOOLEAN;
VAR
Regs: Registers;
BEGIN
INTR (17, Regs);
IF (Regs.AX AND $0030) = $30 THEN Monochrome := TRUE
ELSE Monochrome := FALSE
END;
PROCEDURE SaveScreenOut;
BEGIN
XSave := WhereX; YSave := WhereY;
VideoBufferSize := ScreenX * ScreenY * 2;
GetMem (SavePtr, VideoBufferSize);
IF Monochrome THEN
VidSegment := $8000
ELSE VidSegment := $8800;
VideoPtr := Ptr (VidSegment, 0);
Move (VideoPtr^, VideoPtr^, VideoBufferSize)
END;
PROCEDURE ShowHelpData;
BEGIN
GoToXY(30, 3); WriteLn('>>>> JTERM <<<<');
Write(' Din COMPLETE TURBO PASCAL 5.0, de Jeff Duntemann');
GoToXY(1,7);
WriteLn('Implicit parametrii de comunicare sint 1200, 8, N, 1');
WriteLn('Puteti folosi JTERM la 300 boud prin urmatorul apel :');
WriteLn; WriteLn(' C:\>Jterm 300'); WriteLn;
WriteLn('In mod curent comenzile active sint :'); WriteLn;
WriteLn(' F1: Afisarea acestui ecran help');
WriteLn(' Ctrl-Z: Stergerea ecranului');
WriteLn(' Ctrl-X: Retine si termina JTERM');
END;
PROCEDURE BringScreenBack;
BEGIN
Move (SavePtr^, VideoPtr^, VideoBufferSize);
FreeMem (SavePtr, VideoBufferSize);
GoToXY (XSave, YSave)
END;
BEGIN
SaveScreenOut; ClrScr; ShowHelpData;
GoToXY (20, 23); Write ('Apasati orice tasta pentru continuare ...');
REPEAT UNTIL KeyPressed;
Dummy := ReadKey;
IF Dummy = CHR (0) THEN Dummy := ReadKey;
BringScreenBack
END;
Binary
(* >>> BinaryDemo <<< ----- ----- --------- ----- -------- *)
(* Nume fisier : BITTEST.PAS *)
(* Program demonstrativ - testari binare. *)
(* -------- ----- ------ ----- ----- -------- *)
PROGRAM BinaryDemo;
VAR
i, j: INTEGER;
FUNCTION TestBit (VAR Target; BitNum: INTEGER): BOOLEAN;
VAR
Subject: INTEGER ABSOLUTE Target;
Dummy: INTEGER;
BEGIN
Dummy := Subject;
Dummy := Dummy SHR BitNum;
IF ODD (Dummy) THEN TestBit := TRUE ELSE TestBit := FALSE
END;
BEGIN
REPEAT
Write('>> Introduceti un intreg (0 pentru iesire) : '); ReadLn(i);
FOR j := 15 DOWNTO 0 DO
IF TestBit(i, j) THEN Write ('1') ELSE Write('0');
WriteLn; WriteLn
UNTIL i = 0
END.
WriteHex
(* >>> WriteHex <<< -------- ----- ------ - *)
(* Nume fisier : WRITEHEX.SRC *)
(* Rutina asigura scrierea hexazecimala a datelor. *)
(* -------- ----- ------ ----- ----- -------- *)
PROCEDURE WriteHex (VAR Device: TEXT; BT: BYTE);
CONST
HexDigits: ARRAY[0..15] OF CHAR ='0123456789ABCDEF';
VAR
BZ: BYTE;
BEGIN
BZ := BT AND $0F;
BT := BT SHR 4;
Write (Device, HexDigits[BT], HexDigits[BZ])
END;
SoftTest
(* >>> SoftIntTest <<< ----- ----- --------- ----- ----- *)
(* Nume fisier : SOFTINT.PAS *)
(* Programul demonstrativ pentru rutinele soft de *)
(* deservire a intreruperilor. *)
(* -------- ----- ------ ----- ----- ------ *)
PROGRAM SoftIntTest;
USES DOS, CRT;
VAR
Foo: WORD;
Regs: Registers;
OldVector: Pointer;
PROCEDURE EnableInterrupts;
INLINE ($F8);
PROCEDURE SoftISR (Fings, CS, IP, AX, BX, CX, DX, SI, DS, ES, BP: WORD);
INTERRUPT;
BEGIN
EnableInterrupts;
Foo := AX;
BX := 17
END;
PROCEDURE OurExitProc;
BEGIN
SetIntVec (76, OldVector)
END;
BEGIN
ExitProc := @OurExitProc;
Foo := 0;
ClrScr;
GetIntVec (76, OldVector);
SetIntVec (76, @SoftISR);
Regs.AX := 42;
Regs.BX := 0;
Intr (76, Regs);
WriteLn ('Foo = ', Foo);
WriteLn ('BX = ', Regs.BX);
ReadLn
END.
JTerm
(* >>> JTerm <<< -------- ----- ------ ----- *)
(* Nume fisier : JTERM.PAS *)
(* Programul dirijeaza intreruperile unui "terminal *)
(* mut" pentru PC. Se ilustreaza utilizarea rutinelor *)
(* INTERRUPT din Turbo Pascal, si un mod simplificat de *)
(* utilizare a portului serial al echipamentului. *)
(* -------- ----- ------ ----- ----- --------- *)
PROGRAM JTerm;
USES DOS, CRT;
CONST
Com1Int= 12;
RBR= $3F8;
THR= $3F8;
LCR= $3F8;
IER= $3F9;
MCR= $3FC;
LSR= $3FD;
DLL= $3F8;
DLM= $3F9;
DLAB= $80;
BAUD300= 384;
BAUD1200= 96;
NOPARITY= 0;
BITS8= $03;
DTR= $01;
RTS= $02;
OUT2= $08;
DCW1= $21;
DCW2= $20;
IRQ4= $10;
TYPE
CircularBuffer= ARRAY[0..1023] OF CHAR;
VAR
Quit,
HiBaud: BOOLEAN;
KeyChar,
CommChar: CHAR;
Divisor: WORD;
ClearIt: BYTE;
Buffer: CircularBuffer;
LastRead,
LastSaved: INTEGER;
NoShow: SET OF CHAR;
OldVector: POINTER;
PROCEDURE EnableInterrupts;
INLINE ($F8);
PROCEDURE Incoming (Flags, CS, IP, AX, BX, CX¬ DX, SI, DI, DS, ES,SP: WORD);
INTERRUPT;
BEGIN
EnableInterrupts;
IF LastSaved >= 1023 THEN LastSaved := 0
ELSE INC (LastSaved);
Buffer [LastSaved] := CHAR (Port [RBR]);
Port [DCW2] := $20
END;
PROCEDURE JTermExitProc;
BEGIN
Port[IER] := 0;
Port[DCW1] := Port[DCW1] OR IRQ4;
Port[MCR] := 0;
SetIntVec (Com1Int, OldVector)
END;
PROCEDURE SetupSerialPort;
BEGIN
LastRead := 0; LastSaved := 0;
Port[IER] := 0;
GetIntVec (Com1Int, OldVector);
ExitProc := @JTermExitProc;
SetIntVec (Com1Int, @Incoming);
Port[LCR] := Port[LCR] OR DLAB;
Port[DLL] := Lo (Divisor);
Port[DLM] := Hi (Divisor);
Port[LCR] := BITS8 OR NOPARITY;
Port[MCR] := DTR OR RTS OR OUT2;
ClearIt := Port[RBR];
ClearIt := Port[LSR];
Port[IER] := $01
END;
S FUNCTION InStat: BOOLEAN;
BEGIN
IF LastSaved <> LastRead THEN InStat := TRUE
ELSE InStat := FALSE
END;
FUNCTION InChar: CHAR;
(* -------- ----- ------ ----- ----- --------- *)
(* Rutina returneaza ultimul caracter din bufferul *)
(* circular. *)
(* -------- ----- ------ ----- ----- --------- *)
BEGIN
IF LastRead >= 1023 THEN LastRead := 0
ELSE LastRead := SUCC (LastRead);
InChar := Buffer[LastRead]
END;
PROCEDURE OutChar (Ch: CHAR);
(* ---- Rutina transmite un caracter la portul "comm". ----- *)
BEGIN
Port[THR] := BYTE (Ch)
END;
BEGIN
HiBaud := TRUE;
Divisor := BAUD1200;
IF ParamCount > 0 THEN
IF ParamStr(1) = '300' THEN
BEGIN
HiBaud := FALSE;
Divisor := BAUD300
END;
DirectVideo := TRUE;
NoShow := [#0, #127];
SetupSerialPort;
ClrScr;
WriteLn ('>>> JTERM by Jeff Duntemann');
Quit := FALSE;
REPEAT
IF InStat THEN
BEGIN
CommChar := InChar;
CommChar := CHAR (BYTE (CommChar) AND $7F);
IF NOT (CommChar IN NoShow) THEN
Write (CommChar)
END;
IF KeyPressed THEN
BEGIN
KeyChar := ReadKey;
IF KeyChar = CHR (0) THEN
BEGIN
KeyChar := ReadKey;
CASE ORD (KeyChar) OF
59: ShowHelp;
END
END
ELSE
CASE ORD (KeyChar) OF
24: Quit := TRUE;
26: ClrScr;
ELSE OutChar (KeyChar)
END
END
UNTIL Quit
END.
Searcher
(* >>> Searcher <<< -------- ----- ------ -- *)
(* Nume fisier : SEARCHER.PAS *)
(* Unit-ul contine rutine de cautare in directoare. *)
(* -------- ----- ------ ----- ----- --------- *)
UNIT Searcher;
INTERFACE
USES DOS;
TYPE
HitProc= PROCEDURE (Found: SearchRec; inDirectory:STRING);
PROCEDURE SearchAll (Directory: STRING; Spec: STRING;
Attribute: BYTE; Doit: HitProc);
PROCEDURE SearchOne (Directory: STRING; Spec: STRING;
Attribute: BYTE; Doit: HitProc);
PROCEDURE SearchCurrent (Spec: STRING; Attribute: BYTE; Doit: HitProc);
IMPLEMENTATION
PROCEDURE SearchAll (Directory: STRING; Spec: STRING;
Attribute: BYTE; Doit: HitProc);
(* -------- ----- ------ ----- ----- -------------- *)
(* Rutina este o "masina" de cautare ce parcurge intregul *)
(* arbore al directorului DOS din volumul de disc curent, *)
(* analizind fisierele ce corespund specificatorului Spec si *)
(* au atributele Attribute. Daca se gaseste fisierul cauta, *)
(* atunci DTA fisierului gasit este transmis parametrului *)
(* procedural, care apoi executa o anumita actiune folosind *)
(* informatia din DTA. *)
(* Logica de baza a utilizarii FIND FIRST si FIND NEXT *)
(* este aproape identica cu cea din programul LOCATE.PAS, cu *)
(* deosebirea ca LOCATE.PAS numai afiseaza informatia din *)
(* fisierele gasite. Transmitind diferite proceduri in *)
(* HitProc este posibil sa se execute orice actiune cu un *)
(* fisier gasit. *)
(* -------- ----- ------ ----- ----- -------------- *)
VAR
CurrentDTA: SearchRec;
TempDirectory, NextDirectory: STRING;
BEGIN
IF Directory = '\' THEN TempDirectory := Directory + '*.*'
ELSE TempDirectory := Directory + '\*.*';
FindFirst (TempDirectory, $10, CurrentDTA);
WHILE (DOSError <> 2) AND (DOSError <> 18) DO
BEGIN
IF ((CurrentDTA.Attr AND $10) = $10)
AND (CurrentDTA.Name[1] <> '.') THEN
BEGIN
IF Directory <> '\' THEN NextDirectory := Directory + '\'
ELSE NextDirectory := Directory;
NextDirectory := NextDirectory + CurrentDTA.Name;
SearchAll (NextDirectory, Spec, Attribute, Doit)
END;
FindNext (CurrentDTA)
END;
IF Directory = '\' THEN TempDirectory := Directory + '\' + Spec
ELSE TempDirectory := Directory + Spec;
FindFirst (TempDirectory, Attribute, CurrentDTA);
IF DOSError = 3 THEN
WriteLn ('Calea nu a fost gasita; verifica ortografia.')
ELSE
IF (DOSError = 2) OR (DOSError = 18) THEN
ELSE
BEGIN
Doit (CurrentDTA, Directory);
IF DOSError <> 18 THEN
REPEAT
FindNext (CurrentDTA);
IF DOSError <> 18 THEN Doit (CurrentDTA, Directory)
UNTIL (DOSError = 18) OR (DOSError = 2)
END
END;
PROCEDURE SearchOne (Directory: STRING; Spec: STRING;
Attribute: BYTE; Doit: HitProc);
(* -------- ----- ------ ----- ----- ---------- *)
(* Aceasta procedura reprezinta un subset al rutinei *)
(* SearchAll. Ea cauta numai in directorul specificat in *)
(* Directory, si nu in intreg arborele. *)
(* -------- ----- ------ ----- ----- ---------- *)
VAR
TempDirectory: STRING;
CurrentDTA: SearchRec;
BEGIN
IF Directory = '\' THEN TempDirectory := Directory + '\' + Spec
ELSE TempDirectory := Directory + Spec;
FindFirst (TempDirectory, Attribute, CurrentDTA);
IF DOSError = 3 THEN
WriteLn ('Calea nu a fost gasita; verifica ortografia.')
ELSE
IF (DOSError = 2) OR (DOSError = 18) THEN
ELSE
BEGIN
Doit (CurrentDTA, Directory);
IF DOSError <> 18 THEN
REPEAT
FindNext (CurrentDTA);
IF DOSError <> 18 THEN
Doit (CurrentDTA, Directory)
UNTIL (DOSError = 18) OR (DOSError = 2)
END
END;
PROCEDURE SearchCurrent (Spec: STRING; Attribute: BYTE; Doit: HitProc);
(* ---- Rutina executa cautarea numai in directorul curent® ---- *)
VAR
Directory: STRING;
BEGIN
GetDir (0, Directory);
SearchOne (Directory, Spec, Attribute, Doit)
END;
END.
Tally
(* >>> Tally <<< -------- ----- ------ -------- *)
(* Nume fisier : TALLY.PAS *)
(* Utilitar pentru identificarea dimensiunii fiserelor. *)
(* -------- ----- ------ ----- ----- ------------ *)
PROGRAM Tally;
USES DOS, Searcher;
VAR
i: INTEGER;
Total: LONGINT;
SearchSpec, InitialDirectory: STRING;
PROCEDURE Tallier (Foundit: SearchRec; inDirectory: STRING);
(* ----- Rutina cumuleaza dimensiunea fiecarui fisier gasit
in directorul specificat. ---- *)
BEGIN
IF inDirectory = '\' THEN WriteLn (inDirectory, Foundit.Name)
ELSE WriteLn (inDirectory, '\', Foundit.Name);
Total := Total + Foundit.Size
END;
BEGIN
IF ParamCount = 0 THEN
BEGIN
WriteLn('>>> TALLY <<< V1.00 de Jeff Duntemann');
WriteLn(' din cartea COMPLETE TURBO PASCAL 5.0'); Writeln;
WriteLn (' Programul cauta toate fisierele care corespund');
WriteLn ('specificatorului indicat, afiseaza calea completa');
WriteLn ('si determina spatiul disc ocupat de acestea.'); WriteLn;
WriteLn (' Sintaxa apelului :'); WriteLn;
WriteLn ('TALLY <specificator-fisier>'); WriteLn
END
ELSE
BEGIN Total := 0; WriteLn; SearchSpec := ParamStr(1);
IF POS ('\', SearchSpec) = 0 THEN InitialDirectory := '\'
ELSE
BEGIN
i := LENGTH (SearchSpec);
WHILE SearchSpec[i] <> '\' DÏ i := PRED (i);
InitialDirectory := COPY(SearchSpec, 1, i - 1);
Delete(SearchSpec, 1, i)
END;
SearchAll (InitialDirectory, SearchSpec, 0, Tallier);
WriteLn ('Fisierele listate ocupa ', Total, ' octeti pe disc.')
END
END.
87There
(* >>> Is87There <<< -------- ----- ------ ---- *)
(* Nume fisier : 87THERE.SRC *)
(* Rutina detecteaza prezenta coprocesorului 8087. *)
(* -------- ----- ------ ----- ----- ------------ *)
FUNCTION Is87There: BOOLEAN;
VAR
ControlWord: WORD;
BEGIN
ControlWord := 0;
INLINE
($90/$08/$E3/
$90/$09/$7E/<ControlWord);
IF Hi (ControlWord) = 0 THEN
Is87There := FALSE
ELSE
Is87There := TRUE
END;
Look1
(* >>> Look1 <<< -------- ----- ------ --------- *)
(* Nume fisier : LOOK1.PAS *)
(* Programul goleste stiva inainte de invocarea unei *)
(* functii. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM Look1;
TYPE
String30= STRING[30];
IntArray= ARRAY[0..99] OF INTEGER;
VAR
Ok: BOOLEAN;
Before, After, Register: WORD;
StackMarker: POINTER;
MyArray: IntArray;
FUNCTION Dummy (VAR Values: IntArray; Fudge: INTEGER;
Level, Clearence: CHAR; Message: String30): BOOLEAN;
VAR
Grade, Cutoff: CHAR;
BEGIN
INLINE ($90/$90/$90/$90);
INLINE ($88/$25/$A3/Register);
After := Register;
StackMarker := Ptr (SSeg, Register);
VarDump (Output, StackMarker^, Trunc (Before - After))
END;
BEGIN
INLINE ($88/$C4/$A3/Register);
Before := Register;
Ok := Dummy (MyArray, 42, 'Q', 'Z', 'I was burn on a pirate ship. ')
END.
Look2
(* >>> Look2 <<< -------- ----- ------ --------- *)
(* Nume fisier : LOOK2.PAS *)
(* Program demonstrativ - vidarea stivei inainte si dupa *)
(* pozitionarea poineterului stivei. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM Look2;
TYPE
String30= STRING[30];
IntArray= ARRAY[0..9] OF INTEGER;
VAR
Ok: BOOLEAN;
Before, After, Register: WORD;
StackMarker: POINTER;
MyArray: IntArray;
FUNCTION Dummy (VAR Values:IntArray; Fudge: INTEGER;
Level, Clearence: CHAR; Message: String30): BOOLEAN;
BEGIN
INLINE ($88/$C4/$A3/Register);
After := Register;
StackMarker := Ptr (SSeg, Register);
WriteLn ('Inainte modificarii rezultatelor sau a variabilelor locale :');
VarDump (Output, StackMarker^, Trunc (Before - After);
Dummy := FALSE;
Grade := 'A';
Cutoff := 'C';
WriteLn ('Dupa modificarea rezultatelor sau a variabilelor locale :');
VarDump (Output, StackMarker^, Trunc (Before - After)
END;
BEGIN
INLINE ($88/$C4/$A3/Register);
Before := Register; WriteLn ('Continutul stivei :');
Ok := Dummy (MyArray, 42, 'Q','Z', 'I was born on a pirate ship. ')
END.
MovLocal
(* >>> MOVLocal <<< -------- ----- ------ ------ *)
(* Nume fisier : MOVLOCAL.PAS *)
(* Program demonstrativ - mutarea variabilelor locale. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM MOVLocal;
USES CRT;
PROCEDURE Foo;
VAR Fee, Fie: INTEGER;
BEGIN
Fee := 0; Fie := 0; INLINE ($B8/$11/00);
INLINE ($89/$86/Fee);
WriteLn ('Fee = ', Fee); ReadLn; INLINE ($8B/$9E/Fee);
INLINE ($89/$9E/Fie);
WriteLn ('Fie = ', Fie); ReadLn
END;
BEGIN
ClrScr; Foo
END.
MovParameter
(* >>> MOVParameter <<< -------- ----- ------ -- *)
(* Nume fisier : MOVPARAM.PAS *)
(* Program demonstrativ - mutarea parametrilor. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM MOVParameter;
USES CRT;
PROCEDURE Foo (Foe, Fum: INTEGER);
VAR
Fee, Fie: INTEGER;
BEGIN
Fee := 0; Fie := 0; WriteLn ('Fum = ', Fum);
INLINE ($8B/$8E/Foe);
INLINE ($89/$8E/Fee);
WriteLn ('Fee = ', Fee); ReadLn;
INLINE ($8B/$96/Fee);
INLINE ($89/$96/Fum);
WriteLn ('Fum = ', Fum); ReadLn
END;
BEGIN
ClrScr; Foo (42, 17)
END.
VARParamINLINE
(* >>> VARParmINLINE <<< -------- ----- ------ - *)
(* Nume fisier : MVPARMIN.PAS *)
(* Program demonstrativ - utilizarea instructiunii LES *)
(* (Load Pointer Using ES) in INLINE. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM VARParmINLINE;
USES CRT;
VAR
Flarf: INTEGER;
PROCEDURE Foo (VAR Fum: INTEGER);
BEGIN
INLINE ($C4/$BE/Fum);
INLINE ($BA/$71/$00);
INLINE ($26/$89/$15)
END;
BEGIN
ClrScr; Flarf := 0; Foo (Flarf);
WriteLn ('Flarf = ', Flarf); ReadLn
END.
FastIncrement
(* >>> FastIncrement <<< -------- ----- ------ - *)
(* Nume fisier : FASTINX.PAS *)
(* Program demonstrativ - lucru cu parametrii variabile. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM FastIncrement;
USES CRT;
TYPE
IntArray= ARRAY[0..16000] OF INTEGER;
VAR
I: INTEGER;
Scores: IntArray;
PROCEDURE Increment (VAR Scores: IntArray;
ByHowMuch: INTEGER);
BEGIN
INLINE ($C4/$BE/Scores/
$89/$80/$3E/
$8B/$9E/ByHowMuch/
$26/$01/$1D/
$47/
$47/
$E2/$FA);
END;
BEGIN
ClrScr;
FillChar (Scores, SizeOf (Scores), Chr (0));
FOR I := 0 TO 10 DO
WriteLn (Scores[I]);
Readln;
Increment (Scores, 72);
FOR I := 0 TO 10 DO
WriteLn (Scores[I]);
ReadLn
END.
PointerINLINE
(* >>> PointerINLINE <<< -------- ----- ------ -- *)
(* Nume fisier : PTRINLN.PAS *)
(* Program demonstrativ - variabile dinamice cu INLINE. *)
(* -------- ----- ------ ----- ----- -------------- *)
PROGRAM PointerINLINE;
USES CRT;
TYPE IntPtr= ^INTEGER;
VAR MyPtr: IntPtr;
BEGIN
ClrScr; New (MyPtr); MyPtr^ := 42;
WriteLn('Inainte : ', MyPtr^);
INLINE($C4/$3E/MyPtr/
$26/$80/$05/$03);
WriteLn ('Dupa : ', MyPtr^);
ReadLn
END.
CodeMark
(* >>> CodeMark <<< -------- ----- ------ ------- *)
(* Nume fisier : CODEMARK.SRC *)
(* Rutina este un macro INLINE care furnizeaza un pointer *)
(* catre codul urmatoarei instructiuni. Acest pointer poate *)
(* fi transmis catre VarDump pentru a afisa a zona de cod. *)
(* -------- ----- ------ ----- ----- -------------- *)
FUNCTION CodeMark: POINTER;
INLINE ($8C/$CA/
$E8/$00/$00/
$58/
$05/$0B/$00);
Boiler
; B O I L E R - Boilerplate external assembly language source file
; Boiler se apeleaza din programe Turbo Pascal folosind conventia
; de procedura /EXTERNAL
; Declararea procedurii insasi ca externa in program se realizeaza astfel :
;
; PROCEDURE Boiler; EXTERNAL;
; Pentru reasamblare/relinkeditare BOILER se foloseste MASM sau TASM :
; C>TASM BOILER
CODE SEGMENT BYTE PUBLIC
ASSUME CS:CODE
PUBLIC BOILER
BOILER PROC NEAR
PUSH BP ; Salvarea valorii anterioare a lui BP in stiva
MOV BP, SP ; SP devine noua valoare a lui BP
; Corpul procesului dv. incepe aici ...
MOV SP, BP ; Restaurarea pointerului stivei
POP BP
RET
BOILER ENDP
CODE ENDS
END
Clears
; C L E A R S - primitiva pentru stergerea ecranului in Turbo Pascal
; Rutina CLEARS se apeleaza folosind conventiile de apelare a procedurilor
; externe - /EXTERNAL.
; Avantajul acestei rutine fata de ClrScr consta in faptul ca ea poate
; sterge un ecran memorat in heap si poate sterge ecranul cu un caracter
; diferit de spatiu. In bufferul de sters se poate scrie un atribut ca un
; caracter de stergere.
; Pentru a folosi CLEARS pe un ecran vizibil, trebuie sa declarati un
; pointer care sa refere bufferul grafic sau text :
; VAR
; VisibileScreen: POINTER;
; VisibileScreen := Ptr ($8000, 0);
; VisibileScreen := Ptr ($8800, 0);
; Declararea procedurii insasi se realizeaza astfel :
; PROCEDURE CLEARS (Target: POINTER; ScreenSize: INTEGER;
; Attribute: INTEGER; CharFill: BYTE);
; EXTERNAL;
; Transmiteti lui CLEARS codul atributului pe care doriti sa-l folositi
; in Attribute (in mod normal $0700 pentru display text "normal") si
; caracterul pentru "sters" in CharFill. Folositi 32 sau Ord(' ') pentru
; spatii sau caracterele "halftone" (176-178) pentru ecrane in stil
; Framework. Retineti ca, codul atributului trebuie sa fie in octetul HIGH
; in parametrul actual transmis lui Attribute.
; Exemple :
; Stergerea ecranului vizibil cu spatii :
; Clears (VisibleScreen, 4096, $0700, ' ');
; Stergerea unui ecran din heap :
; Clears (NewScreen, 4096, $0700, 176);
; Desigur, trebuie sa declarati VisibleScreen si NewScreen si sa le
; stabiliti sa refere fie ecranul din heap fie bufferul ecranului vizibil.
CODE SEGMENT BYTE PUBLIC
ASSUME CS:CODE
PUBLIC CLEARS
; Structura stivei
ONSTACK STRUC
OLDBP DW ? ; BP apelantului este salvat in stiva
RETADDR DW ? ; Adresa cea mai recenta de revenire
FILLER DW ? ; Caracterul care umple bufferul de sters
ATTRIB DW ? ; Atributul bufferului de sters
BUFSIZE DW ? ; Dimensiunea, in octeti, a bufferului de sters
BUFOFS DW ? ; Originea de start a bufferului
BUFSEG DW ? ; Originea segmentului bufferului
ENDMARK DB ? ; Eticheta fictiva ptr. a marca sfirsitul datelor din stiva
ONSTACK ENDS
CLEARS PROC NEAR
PUSH BP
MOV BP, SP ; Conventia de apelare
; In primul rind se testeaza pentru buffer = NIL ... iesire daca este asa
START: CLD ; Stergerea indicatorilor de directie
MOV AX, [BP].ATTRIB ; Incarca codul atributului in AX
AND AX, 0FF00H ; Mascarea octetului inferior al codului atributului
MOV BX, [BP].FILLER ; Incarca codul de umplere in BX
AND BX, 0FFH ; Mascarea octetului superior al codului de umplere
OR AX, BX ; Si combina ATTRIB & FILLER in AX
MOV BX, [BP].BUFOFS ; Stabileste DI pentru bufferul TARGET
MOV DI, BX
MOV BX, [BP].BUFSEG
MOV ES, BX
; Ciclare pentru inregistrarea caracterului si a atributului in buffer
MOV CX, [BP].BUFSIZE ; Setarea contorului
REP STOSW ; Executa memorarea sirului
; Curatirea stivei si iesire
BYE: MOV SP, BP ; Restaurarea valoriloe anterioare
POP SP
RET ENDMARK-RETADDR-2
CLEARS ENDP
CODE ENDS
END
Stick
; S T I C K - intrare joystick, in limbaj de asamblare, pentru Turbo Pascal
; STICK se apeleaza folosind conventia de apelarea procedurilor externe :
; /EXTERNAL.
; Declararea procedurii insasi se realizeaza astfel :
;
; PROCEDURE STICK (StickNumber: INTEGER;
; VAR X, Y: INTEGER); EXTERNAL;
; StickNumber specifica care din joystick-uri se citeste, iar X si Y sint
; parametrii ce returneaza intregi proportionali cu pozitia joystick-ului.
; Acesti intregi difera de la stick la stick in functie de rezistenta
; potentiometrelor folosite in stick, dar in mod obisnuit sint cuprinsi
; intre 3 si 150.
; Placa IBM standard pentru controlul jocului se compune din doua manete
; (one-shots), care transmit un impuls la portul $201 de I/O. Durata acestui
; impuls depinde de constanta RC a portiunii de rezistenta a potentiometrului
; joystick-ului.
; Pentru citirea unuia din cele doua joystick-uri, o valoare fictiva este
; scrisa in portul $201 de I/O. Portul $201 trebuie apoi testat continuu,
; incrementind un registru la fisecare eveniment. Atunci cind bitul care
; corespunde coordonatelor X sau Y ale joystick-ului isi modifica starea,
; valoarea din registru este returnata drept valoare a coordonatelor
; stick-ului care a fost manevrat.
; Configuratia de biti ai joystick-ului returnati portului $201 este :
; |7 6 5 4 3 2 1 0|
; | | | |______ coordonata X, joystick #1
; | | |________ coordonata Y, joystick #1
; | |__________ coordonata X, joystick #2
; |____________ coordonata Y, joystick #2
; Urmatoareá structura defineste planul parametrilor unui stick :
ONSTACK STRUC
OLDSP DW ? ; Virful stivei
RETADDR DD ? ; Adresa indepartata de revenire
YADDR DD ? ; Adresa indepartata a valorii Y
XADDR DD ? ; Adresa indepartata a valorii X
STIK_NO DW ? ; Numarul stic-ului
ONSTACK ENDS
CODE SEGMENT PUBLIC
ASSUME CS:CODE
PUBLIC STICK
STICK_X EQU 1
STICK_Y EQU 2
STICK PROC FAR
PUSH BP ; Salvarea BP al apelantului
MOV BP, SP ; Pointerul stivei devine noul BP
PUSH DS
; Citirea valorii axei X
MOV AH, STICK_X ; Mutarea bitilor de testat
CMP [BP].STIK_NO, 2 ; Se verifica daca este stic-ul #1 sau #2
JNE TEST_X
SHL AH, 1 ; Se decaleaza stinga pentru stick-ul #2
SHL AH, 1
TEST_X: MOV AL, 1 ; Initializarea valorii de iesire
MOV DX, 201H ; Stabilirea adresei portului
MOV BX, 0 ; si pastrarea valorii de executie in BX
MOV CX, BX ; Stabileste limita maxima a ciclului la 64K
OUT DX, AL ; Testarea unei manete
AGAIN_X: IN AL, DX ; Citeste bitii unei manete
TEST AL, AH ; Testeaza bitul 0 superior
JE DELAY ; Salt daca bitul 0 este superior
INC BX ; Altfel incrementeaza BX si cicleaza din nou
LOOP AGAIN_X
MOV BX, -1 ; Seteaza X=-1 dacu nu exista raspuns
; Intirziere pentru maxim trei impulsuri de iesire
DELAY: MOV CX, 512
WAIT: LOOP WAIT
; Citirea valorii axei Y
MOV AH, STICK_Y
CMP [BP].STIK_NO, 2
JNE TEST_Y
SHL AH, 1
SHL AH, 1
TEST_Y: MOV SI, 0
MOV CX, SI
OUT DX, AL
AGAIN_Y: IN AL, DX
TEST AL, AH
JE DONE
INC SI
LOOP AGAIN_Y
MOV SI, -1
; Mutarea valorilor returnate din registre in parametrii VAR X si Y
DONE: LOS DI, [BP].XADDR ; Adresa lui X in DS:DI
MOV [DI], BX ; Valoarea lui X din BX in DS:DI
LOS DI, [BP].YADDR ; Adresa lui Y in DS:DI
MOV [DI], SI ; Valoarea lui Y din SI in DS:DI
; Acesta este totul ... Acum se sterge stiva si se revine in apelant
POP DS
MOV SP, BP
POP BP
RET 10
STICK ENDP
CODE ENDS
END
StrPlate
; S T R P L A T E - Boilerplate string external function
; STRPLATE se apeleaza folosind conventiile pentru proceduri EXTERNAL :
:
; FUNCTION STRPLATE (Source: STRING): STRING;
EXTERNAL;
PHYSLEN EQU 255
ONSTACK STRUC
OLDBP DW ? ; Valoarea BP a apelantului
RETADDR DW ? ; Adresa de revenire
PARMPTR DD ? ; Pointer catre parametrul sir
FUNCPTR DD ? ; Pointer catre zona cuvint a rezultatului functiei
ONSTACK ENDS
CODE SEGMENT BYTE PUBLIC
ASSUME CS:CODE
PUBLIC STRPLATE
STRPLATE PROC NEAR ; Apel indepartat daca procedura este intr-un unit
PUSH BP ; Salvarea valorii BP anterioare in stiva
MOV BP, SP ; SP devine noua valoare a lui BP
; Intre cele doua linii intrerupte se introduce
; functia proprie de operarea asupra sirului
; Spre exemplu, operatia de copiere a parametrului in rezultatul functiei :
PUSH DS ; Salvare DS aplelant
LDS SI, [BP].PARMPTR ; Mutare adresa parametru in DS:DI
LES DI, [BP].FUNCPTR ; Mutare adresa rezultat functie in ES:DI
MOV CX, PHYSLEN + 1 ; Numarul octetilor de mutat
CLD ; Setare indicator directie autoincrementare
REPZ MOVSB ; Executarea mutarii blocului
POP DS ; Restaurarea valorii DS al apelantului
MOV SP, BP ; Restaurarea pointerului stivei apelantului
POP BP ; Restaurarea pointerului de baza apelant
RET FUNCPTR - RETADDR - 2 ; Stergerea stivei si revenire
STRPLATE ENDP
CODE ENDS
END
Button
; B U T T O N - Functia returneaza starea butoanelor joystick-ului
; Declararea procedurii :
;
; FUNTION BUTTON (StickNumber, ButtonNumber: INTEGER): BOOLEAN;
EXTERNAL;
; StckNumber spacifica care din joystick se citeste, iar ButtonNumber indica
; care din butoanele joystick-ului se citeste. Daca butonul specificat este
; actionat, BUTTON returneaza valoarea TRUE.
; Informatia se obtine prin citirea portului o201 de I/O. Primii patru biti
; superiori reprezinta starea celor patru butoane (cite doi pantru cele doua
; joystick-uri posibile). Bitul inferior reprezinta un buton apasat.
; Structura bitilor returnati de portul $201 este :
; |7 6 5 4 3 2 1 0|
; | | | |
; | | | |_______________ Buton #1, joystick #1
; | | |_________________ Buton #2, joystick #1
; | |___________________ Buton #1, joystick #2
; |_____ _______ ______ ______ Buton #2, joystick #
; Retineti faptul ca valoarea returnata de functie este transmita codului
; rutinei in registrul AL.
ONSTACK STRUC
OLDBP DW ? ; Virful stivei
RETADDR DD ? ; Adresa indepartata de revenire
BTN_NO DW ? ; Numarul butonului
STIK_NO DW ? ; Numarul joystick-ului
ONSTACK ENDS
CODE SEGMENT BYTE PUBLIC
ASSUME CS:CODE
PUBLIC BUTTON
BUTTON PROC FAR
PUSH BP ; Salvarea in stiva a valorii anterioare a lui BP
MOV BP, SP ; SP devine noul BP
; Cea mai mare parte a rutinei stabileste masca de testare pentru
; fiecare din cei patru biti testati.
MOV BL, 010H ; Se incepe cu bitul 4
CMP [BP].STIK_NO, 2 ; Se testeaza ptr. joystick-ul 2 ?
JNE WHICH ; Daca nu, se trece la WHICH
SHL BL, 1 ; altfel se deplaseaza cu 2 spre stinga
SHL BL, 1 ; astfel ca sa se ajunga pe bitul 6
WHICH: CMP [BP].BTN_NO, 2 ; Se testeaza butonul 2 ?
JNE READEN ; Daca nu, masca e corecta; citeste portul
SHL BL, 1 ; altfel, deplaseaza un bit la stg ptr btn 2
; Masca bitului este acum corecta. Bitii butonului sint cititi din portul
; $201 si testati impreuna cu masca. De notat faptul ca bitii cititi din
; port trebuie sa fie inversati astfel incit indicatorul Z sa fie setat in
; loc sa fie sters biyul butonului activ.
READEN: MOV DX, 0201h ; Setarea adresei portului citit
IN AL, DX ; Citirea bitilor butoanelor din portul $201
NOT AL ; Inversare biti pentru sensul corespunzator
; al indicatorului Z dupa testare
TEST AL, BL ; Se verifica daca bitul este "superior"
JNZ PUSHED ; Daca este asa, butonul este apasat;
MOV AL, 0 ; Altfel muta FALSE in AL
JMP DONE ; si se merge la iesire
PUSHED: MOV AL, 1 ; Buton apasat; muta TRUE in AL
DONE: MOV SP, BP ; Restaurare SP & BP anterior
POP SP
RET 6
BUTTON ENDP
CODE ENDS
END
GameTest
(* >>> GameTest <<< -------- ----- ------ ------- *)
(* Nume fisier : GAMETEST.PAS *)
(* Program demonstrativ - cod masina pentru joystick. *)
(* -------- ----- ------ ----- ----- -------------- *)
PROGRAM GameTest;
USE CRT, Gamebord;
VAR
X, Y: INTEGER;
BEGIN
ClrScr; X := 0; Y := 0;
GoToXY (2, 9); WriteLn ('Axa X Axa Y');
WHILE NOT KeyPressed DO
BEGIN
GoToXY (1, 5);
IF Button (2, 1) THEN WriteLn ('Buton 1 apasat')
ELSE WriteLn ('Nimic pe 1 ....');
IF Button (2, 2) THEN WriteLn ('Buton 2 apasat')
ELSE WriteLn ('Nimic pe 2 ....');
Stick (2, X, Y); GoToXY (1, 10); WriteLn (X:5, ' ', Y:5)
END
END.
GameBord
(* >>> GameBord <<< -------- ----- ------ -------- *)
(* Nume fisier : GAMEBORD.PAS *)
(* Biblioteca contine rutine in limbaj de asamblare pentru *)
(* citirea oricarui din cele doua joystick-uri si a butoanelor*)
(* asociate lor. *)
(* -------- ----- ------ ----- ----- --------------- *)
UNIT GameBord;
INTERFACE
FUNCTION Button (StickNumber, ButtonNumber: INTEGER): BOOLEAN;
PROCEDURE Stick (StickNumber: INTEGER; VAR X, Y: INTEGER);
IMPLEMANTATION
FUNCTION Button (StickNumber, ButtonNumber: INTEGER): BOOLEAN; EXTERNAL;
PROCEDURE Stick (StickNumber: INTEGER; VAR X, Y: INTEGER; EXTERNAL;
END.
Gamer
; G A M E R - suportul in limbaj de asamblare pentru joystick
; GAMER este un simplu fisier sursa limbaj asamblare care contine rutinele
; STICK.ASM si BUTTON.ASM. Scopul lui GAMER este de a prezenta cum se pot
; combinar mai multe rutine in limbaj de asamblare intr-un singur modul cod
; masina.
CODE SEGMENT BYTE PUBLIC ; Segmentul este aliniat la octet
ASSUME CS:CODE
PUBLIC BUTTON, STICK ; Cele doua proceduri accesibile din modul
; B U T T O N - Functia returneaza starea butoanelor joystick-ului
; Antetul complet al procedurii :
; FUNTION BUTTON (StickNumber, ButtonNumber: INTEGER): BOOLEAN;
; StickNumber spacifica care din joystick se citeste, iar ButtonNumber indica
; care din butoanele joystick-ului se citeste. Daca butonul specificat este
; actionat, BUTTON returneaza valoarea TRUE.
; Informatia se obtine prin citirea portului $201 de I/O. Primii patru biti
; superiori reprezinta starea celor patru butoane (cite doi pantru cele doua
; joystick-uri posibile). Bitul inferior reprezinta un buton apasat.
; Structura bitilor returnati de portul $201 este :
; |7 6 5 4 3 2 1 0|
; | | | |
; | | | |_______________ Buton #1, joystick #1
; | | |_________________ Buton #2, joystick #1
; | |___________________ Buton #1, joystick #2
; |_____ _______ ______ ______ Buton #2, joystick #
; Retineti faptul ca valoarea returnata de functie este transmita codului
; rutinei in registrul AL.
ONSTACK1 STRUC
OLDBP DW ? ; Virful stivei
RETADDR DD ? ; Adresa indepartata de revenire
BTN_NO DW ? ; Numarul butonului
STIK_NO DW ? ; Numarul joystick-ului
ONSTACK1 ENDS
BUTTON PROC FAR
PUSH BP ; Slavarea in stiva a valorii anterioare a lui BP
MOV BP, SP ; SP devine noul BP
; Cea mai mare parte a rutinei stabileste masca de testare pentru
; fiecare din cei patru biti testati.
MOV BL, 010H ; Se incepe cu bitul 4
CMP [BP].STIK_NO, 2 ; Se testeaza ptr. joystick-ul 2 ?
JNE WHICH ; Daca nu, se trece la WHICH
SHL BL, 1 ; altfel se deplaseaza cu 2 spre stinga
SHL BL, 1 ; astfel ca sa se ajunga pe bitul 6
WHICH: CMP [BP].BTN_NO, 2 ; Se testeaza butonul 2 ?
JNE READEN ; Daca nu, masca e corecta; citeste portul
SHL BL, 1 ; altfel, deplaseaza un bit la stg ptr btn 2
; Masca bitului este acum corecta. Bitii butonului sint cititi din portul
; $201 si testati impreuna cu masca. De notat faptul ca bitii cititi din
; port trebuie sa fie inversati astfel incit indicatorul Z sa fie setat in
; loc sa fie sters bityul butonului activ.
READEN: MOV DX, 0201h ; Setarea adresei portului citit
IN AL, DX ; Citirea bitilor butoanelor din portul $201
NOT AL ; Inversare biti pentru sensul corespunzator
; al indicatorului Z dupa testare
TEST AL, BL ; Se verifica daca bitul este "superior"
JNZ PUSHED ; Daca este asa, butonul este apasat;
MOV AL, 0 ; Altfel muta FALSE in AL
JMP BDONE ; si se merge la iesire
PUSHED: MOV AL, 1 ; Buton apasat; muta TRUE in AL
BDONE: MOV SP, BP ; Restaurare SP & BP anterior
POP SP
RET 6
BUTTON ENDP
; S T I C K - intrare joystick, in limbaj de asamblare, pentru Turbo Pascal
; Antetul complet al procedurii este :
; PROCEDURE STICK (StickNumber: INTEGER; VAR X, Y: INTEGER);
; StickNumber specifica care din joystick-uri se citeste, iar X si Y sint
; parametrii ce returneaza intregi proportionali cu pozitia joystick-ului.
; Acesti intregi difera de la stick la stick in functie de rezistenta
; potentiometrelor folosite in stick, dar in mod obisnuit sint cuprinsi
; intre 3 si 150.
; Placa IBM standard pentru controlul jocului se compune din doua manete
; (one-shots), care transmit un impuls la portul $201 de I/O. Durata acestui
; impuls depinde de constanta RC a portiunii de rezistenta a potentiometrului
; joystick-ului.
; Pentru citirea unuia din cele doua joystick-uri, o valoare fictiva este
; scrisa in portul $201 de I/O. Portul $201 trebuie apoi testat continuu,
; incrementind un registru la fisecare eveniment. Atunci cind bitul care
; corespunde coordonatelor X sau Y ale joystick-ului isi modifica starea,
; valoarea din registru este returnata drept valoare a coordonatelor
; stick-ului care a fost manevrat.
; Configuratia de biti ai joystick-ului returnati portului $201 este :
; |7 6 5 4 3 2 1 0|
; | | | |______ coordonata X, joystick #1
; | | |________ coordonata Y, joystick #1
; | |__________ coordonata X, joystick #2
; |____________ coordonata Y, joystick #2
; Aceasta structura defineste planul parametrilor unui stick :
ONSTACK2 STRUC
OLDSP2 DW ? ; Virful stivei
RETADDR2 DD ? ; Adresa indepartata de revenire
YADDR2 DD ? ; Adresa indepartata a valorii Y
XADDR2 DD ? ; Adresa indepartata a valorii X
STIK_NO2 DW ? ; Numarul stic-ului
ONSTACK2 ENDS
STICK_X EQU 1
STICK_Y EQU 2
STICK PROC FAR
PUSH BP ; Salvarea BP al apelantului
MOV BP, SP ; Pointerul stivei devine noul BP
PUSH DS
; Citirea valorii axei X
MOV AH, STICK_X ; Mutarea bitilor de testat
CMP [BP].STIK_NO2, 2 ; Se verifica daca este stic-ul #1 sau #2
JNE TEST_X
SHL AH, 1 ; Se decaleaza stinga pentru stick-ul #2
SHL AH, 1
TEST_X: MOV AL, 1 ; Initializarea valorii de iesire
MOV DX, 201H ; Stabilirea adresei portului
MOV BX, 0 ; si pastrarea valorii de executie in BX
MOV CX, BX ; Stabileste limita maxima a ciclului la 64K
OUT DX, AL ; Testarea unei manete
AGAIN_X: IN AL, DX ; Citeste bitii unei manete
TEST AL, AH ; Testeaza bitul 0 superior
JE DELAY ; Salt daca bitul 0 este superior
INC BX ; Altfel incrementeaza BX si cicleaza din nou
LOOP AGAIN_X
MOV BX, -1 ; Seteaza X=-1 dacu nu exista raspuns
; Intirziere pentru maxim trei impulsuri de iesire
DELAY: MOV CX, 512
WAIT: LOOP WAIT
; Citirea valorii axei Y
MOV AH, STICK_Y
CMP [BP].STIK_NO2, 2
JNE TEST_Y
SHL AH, 1
SHL AH, 1
TEST_Y: MOV SI, 0
MOV CX, SI
OUT DX, AL
SAGAIN_Y: IN AL, DX
TEST AL, AH
JE DONE
INC SI
LOOP AGAIN_Y
MOV SI, -1
; Mutarea valorilor returnate din registre in parametrii VAR X si Y
DONE: LOS DI, [BP].XADDR2 ; Adresa lui X in DS:DI
MOV [DI], BX ; Valoarea lui X din BX in DS:DI
LOS DI, [BP].YADDR2 ; Adresa lui Y in DS:DI
MOV [DI], SI ; Valoarea lui Y din SI in DS:DI
; Acesta este totul ... Acum se sterge stiva si se revine in apelant
POP DS
MOV SP, BP
POP BP
RET 10
STICK ENDP
CODE ENDS
END
|
