Today
(* >>> Today <<< -------- ----- ------ ---- *)
(* Nume fisier : TODAY.PAS *)
(* Programul asigura afisarea pe ecran a mesajelor *)
(* citite din fisierul text MESSAGE.TXT. *)
(* -------- ----- ------ ----- ----- -------- *)
PROGRAM Today;
USES DOS, CRT;
FUNCTION DateString: STRING;
(* -------- ----- ------ ----- ----- ------------ *)
(* Functia converteste data calendaristica a sistemului *)
(* intr-un sir afisabil de forma : ziua., mm.dd.yyyy *)
(* -------- ----- ------ ----- ----- ------------ *)
CONST
days: ARRAY[0..6] OF STRING[3]=
('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
months: ARRAY[1..12] OF STRING[3]= ('Jan', 'Feb', 'Mar', 'Apr', 'May',
'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
VAR
year, month, day, weekday: WORD;
yearStr, monthStr, dayStr, WeekdayStr: STRING;
BEGIN
GetDate (year, month, day, weekday);
STR (year, yearStr);
STR (day, dayStr);
IF LENGTH (dayStr) = 1 THEN dayStr := ' ' + dayStr;
weekdayStr := days[weekday] + '.,';
monthStr := months[month] + '. ';
DateString := weekdayStr + monthStr + dayStr + ', ' + yearStr
END;
FUNCTION TimeString: STRING;
(* -------- ----- ------ ----- ----- ---------- *)
(* Functia converteste valorile numerice ale timpului *)
(* intr-un sir de forma : hh.mm. am/pm *)
(* -------- ----- ------ ----- ----- ---------- *)
VAR
hour, minute, second, hundredth: WORD;
ampm: STRING[2];
hourStr, minuteStr: STRING;
BEGIN
GetTime(hour, minute, second, hundredth);
IF hour > 11 THEN
BEGIN
ampm := 'pm';
IF hour > 12 THEN DEC(hour, 12)
END
ELSE
BEGIN
ampm := 'am';
IF hour = 0 THEN hour := 12
END;
STR(hour, hourStr); STR(minute, minuteStr);
IF LENGTH(hourStr) = 1 THEN hourStr := ' ' + hourStr;
IF LENGTH minuteStr) = 1 THEN minuteStr := '0' + minuteStr;
TimeString := hourStr + ':' + minuteStr + ' ' + ampm
END;
PROCEDURE TodaysMessage;
(* -------- ----- ------ ----- ----- ----------- *)
(* Procedura deschide fisierul cu mesaje si afiseaza pe *)
(* ecran linie cu linie continutul acestuia. *)
(* -------- ----- ------ ----- ----- ----------- *)
CONST
messageFileName= 'MESSAGE.TXT';
screenStop= 13;
dots= 71;
VAR
messageFile: TEXT;
messageLine: STRING;
screenLines: BYTE;
PROCEDURE LineOfChars (dispChar: CHAR; lineLength: BYTE);
(* --- Afiseaza o linie avind lineLength caractere dispChar. --- *)
VAR
i: INTEGER;
BEGIN
FOR i := 1 TO lineLength DO Write(dispChar);
WriteLn
END;
PROCEDURE WaitForEnter;
(* -------- ----- ------ ----- ----- ------- *)
(* Procedura afiseaza pe ecran mesajul si asteapta *)
(* apasarea tastei <Enter> pentru continuare. *)
(* -------- ----- ------ ----- ----- ------- *)
BEGIN
GoToXY (20, 25);
Write('Apasati tasta <Enter> pentru continuare.'); ReadLn
END;
BEGIN
LineOfChars('.', dots); WriteLn;
screenLines := 0;
ASSIGN(messageFile, messageFileName); RESET(messageFile);
WHILE NOT EOF(messageFile) DO
BEGIN
ReadLn(messageFile, messageLine); WriteLn(messageLine);
IF screenLines = screenSto 24224c21y p THEN
BEGIN
screenLines := 0
WaitForEnter
END
END;
CLOSE(messageFile); LineOfChars('.', dots); WaitForEnter
END;
BEGIN
ClrScr; WriteLn; Write('Today is ', DateString,', ');
WriteLn(' The time is ', TimeString, '.');
TodaysMessage
END.
Hours
(* >>> Hours <<< -------- ----- ------ *)
(* Nume fisier : HOURS.PAS *)
(* Programul creaza si intretine o baza de date *)
(* organizata cronologic, pentru pastrarea orelor *)
(* lucrate la un anumit proiect. *)
(* -------- ----- ------ ----- ----- ---- *)
PROGRAM Hours;
USES CRT, DOS, ChrnUnit;
CONST
fixedLineLength = 48;
VAR
accountFile: TEXT;
accountFileName: STRING;
openFile: BOOLEAN;
PROCEDURE LineOfChars (displayChar: CHAR; lineLength: BYTE);
(* -------- ----- ------ ----- ----- ----------- *)
(* Procedura afiseaza pe ecran o line de displayChar *)
(* caractere. Argumentul lineLength reprezinta numarul de *)
(* caractere din linie. *)
(* -------- ----- ------ ----- ----- ----------- *)
VAR
i: INTEGER;
BEGIN
FOR i := 1 TO lineLength DO
WRITE(displayChar);
WRITELN
END;
PROCEDURE AccountUpdate;
(* -------- ----- ------ ----- ----- --------- *)
(* Procedura inregistreaza intr-un fisier cont data, *)
(* timpul si un numar real reprezentind orele de lucru *)
(* facturate. Procedura include doua rutine locale : *)
(* GetFileName si InReal. *)
(* -------- ----- ------ ----- ----- --------- *)
VAR
inHours: REAL;
FUNCTION GetFileName: STRING;
(* ---- Extrage de la tastatura un nume de fisier sau o ;masca; --- *)
VAR
goodName, dirRequest: BOOLEAN;
inName: STRING;
periodPos: BYTE;
PROCEDURE Directory (mask: STRING);
(* --- Listeaza cu EXEC fisierele selectate --- *)
BEGIN
LineOfChars('.', 75);
EXEC('\COMMAND.COM', '/C DIR ' + mask + ' /W');
LineOfChars('.', 75)
END;
BEGIN
goodName := FALSE;
WHILE NOT goodName DO
BEGIN
WRITELN; WRITE(' Numele contului ? '); READLN (inName);
IF inName = '' THEN
Directory('*.HRS')
ELSE
BEGIN
dirRequest:=(POS('*', inName) <> 0) Or (POS('?', inName) <> 0);
IF dirRequest THEN
Directory(inName)
ELSE
BEGIN
goodName := TRUE;
periodPos := POS('.', inName);
IF periodPos <> 0 THEN
inName := COPY(inName, 1, periodPos - 1)
END
END
END;
GetFileName := inName + '.HRS'
END;
FUNCTION InReal(prompt: STRING): REAL;
(* -------- ----- ------ ----- ----- ------ *)
(* Functia citeste de la tastatura un numar real *)
(* si evita eroarea de executie daca nu s-a introdus *)
(* o data numerica corecta. *)
(* -------- ----- ------ ----- ----- ------ *)
VAR
trapReal: REAL;
goodInput: BOOLEAN;
saveX, saveY: BYTE;
BEGIN
REPEAT
WRITE(prompt);
saveX := WHEREX;
saveY := WHEREY;
READLN (trapReal);
goodInput := (IORESULT = 0);
IF NOT goodInput THEN BEGIN GOTOXY(saveX, saveY); CLREOL END
UNTIL goodInput;
InReal := trapReal
END;
BEGIN
accountFileName := GetFileName; openFile := TRUE;
ASSIGN(accountFile, accountFileName);
APPEND (accountFile);
IF IORESULT <> 0 THEN
BEGIN
REWRITE(accountFile);
IF IORESULT <> 0 THEN
BEGIN
WRITELN; WRITELN(' *** Fisierul nu poate fi deschis ***');
DELAY(5000); openFile := FALSE
END
END;
IF openFile THEN
BEGIN
inHours := InReal ('
WRITE(accountFile, DateString, ' ', TimeString, ' ');
WRITELN(accountFile, inHours:5:2);
CLOSE(accountFile)
END
END;
FUNCTION TotalAccount: REAL;
(* -------- ----- ------ ----- ----- --------- *)
(* Functia deschide din nou fisierul indicat pentru *)
(* a determina numarul total de ore inregistrate in mod *)
(* mod curent in contul specificat. *)
(* -------- ----- ------ ----- ----- --------- *)
CONST
chronInfoLength = 28;
VAR
hours, total: REAL;
chronLine: STRING[chronInfoLength];
BEGIN
total := 0.0; RESET(accountFile);
WHILE NOT EOF (accountFile) DO
BEGIN
READLN(accountFile, chronLine, hours);
total := total + hours
END;
CLOSE(accountFile); TotalAccount := total
END;
BEGIN
CLRSCR; WRITELN(' Data : ', DateString, ' Timp : ', TimeString);
LineOfChars ('_', fixedLineLength);
WRITELN; WRITELN(' Inregistrarea orelor contabilizate ');
LineOfChars ('_', fixedLineLength);
AccountUpdate;
LineOfChars ('_', fixedLineLength); WRITELN;
IF openFile THEN
BEGIN
WRITE (' Numarul total de ore din acest cont : ');
WRITELN (TotalAccount:6:2);
LineOfChars ('_', fixedLineLength)
END
END.
BillTime
(* >>> BillTime <<< -------- ----- ------ -- *)
(* Nume fisier : BILLTIME.PAS *)
(* Programul tipareste facturi sub forma de rapoarte *)
(* obtinute prin consultarea fisierelor create prin *)
(* programul Hours. *)
(* -------- ----- ------ ----- ----- --------- *)
PROGRAM BillTime;
USES CRT, DOS, PRINTER, ChrnUnit, InUnit, StrUnit;
CONST
lineLength = 55;
maxScreenColumn = 80;
VAR
accountFile: TEXT;
accountFileName: STRING;
PROCEDURE PrintBill;
(* -------- ----- ------ ----- ----- -------- *)
(* Procedura tipareste factura-raport obtinuta prin *)
(* consultarea fisierului de cont selectat. *)
(* -------- ----- ------ ----- ----- -------- *)
CONST
dateInfoLength = 20;
timeInfoLength = 9;
VAR
hours, hourlyRate, total, amountDue: REAL;
cents, totalDue: LONGINT;
dateLine: STRING[dateInfoLength];
timeLine: STRING[timeInfoLength];
clientName:STRING;
okToPrint: BOOLEAN;
FUNCTION GetFileName:STRING;
(* -------- ----- ------ ----- ----- -------------- *)
(* Functia extrage numele unui fiser de cont, si afiseaza *)
(* lista director daca este necesar. *)
(* -------- ----- ------ ----- ----- -------------- *)
VAR
goodName, dirRequest: BOOLEAN;
inName: STRING;
periodPos: BYTE;
PROCEDURE Directory (mask: STRING);
(* ----- Afisarea pe ecran a directorului. ----- *)
BEGIN
WRITELN(StringOfChars('.', 73));
EXEC('\COMMAND.COM','/C DIR ' + mask + ' /W');
WRITELN(StringOfChars('.', 73));
END;
BEGIN
goodName := FALSE;
WHILE NOT goodName DO
BEGIN
WRITELN; WRITE(' Numele contului ? '); READLN(inName);
IF inName = '' THEN
Directory('*.HRS')
ELSE
BEGIN
dirRequest := (POS('*', inName) <> 0) OR (POS('?', inName) <> 0);
IF dirRequest THEN
Directory(inName)
ELSE
BEGIN
goodName := TRUE;
periodPos := POS('.', inName);
IF periodPos <> 0 THEN
inName := COPY(inName, 1, periodPos - 1)
END
END
END;
GetFileName := inName
END;
PROCEDURE InvoiceHeading (VAR printerOn: BOOLEAN; client: STRING; rate: REAL);
(* ----- Tiparirea antetului facturii. ----- *)
VAR
rateString: STRING;
BEGIN
WRITE (LST, ' *** Facturarea orelor pentru :');
IF IORESULT = 0 THEN
BEGIN
printerOn := TRUE; WRITELN(LST, UpperCase (client), ' ***');
WRITELN(LST, StringOfChars (' ', 17), DateString); WRITELN(LST);
rateString := DollarDisplay (ROUND (rate * 100), 6);
WRITE(LST, ' Data Ore facturate ');
WRITELN(LST, '$', rateString, ' / ora');
WRITELN(LST, StringOfChars ('_', lineLength)); WRITELN(LST)
END
ELSE
BEGIN
printerOn := FALSE;
WRITELN(' *** Imprimanta nu este pregatita ***')
END
END;
PROCEDURE TotalLine;
(* ----- Tiparirea liniei finale a facturilor ---- *)
BEGIN
WRITELN(LST, StringOfChars ('_', lineLength)); WRITELN(LST);
WRITE(LST, ' TOTAL --> ');
WRITELN(LST, total:13:2, DollarDisplay (totalDue, 20));
CLOSE(accountFile)
END;
BEGIN
clientName := GetFileName;
accountFileName := clientName + '.HRS';
ASSIGN(accountFile, accountFileName);
RESET (accountFile);
IF IORESULT <> 0 THEN
BEGIN
WRITELN;
WRITELN(' *** Fisierul specificat nu poate fi deschis ***');
DELAY(5000)
END
ELSE
BEGIN
hourlyRate := InReal (' Tariful orar ? ');
WRITELN(StringOfChars ('-', lineLength)); WRITELN;
total := 0.0; totalDue := 0;
InvoiceHeading(okToPrint, clientName, hourlyRate);
IF okToPrint THEN
BEGIN
RESET(accountFile);
WHILE NOT EOF (accountFile) DO
BEGIN
READLN(accountFile, dateLine, timeLine, hours);
total := total + hours;
WRITE(LST, dateLine, hours:10:2);
amountDue := hours * hourlyRate;
cents := ROUND(amountDue *100);
totalDue := totalDue + cents;
WRITELN(LST, DollarDisplay (cents, 20))
END;
TotalLine
END
END
END;
BEGIN
CLRSCR;
WRITELN(' Data: ', DateString, ' Timp: ', TimeString);
WRITELN (StringOfChars ('_', lineLength));
WRITELN;
WRITELN(' Tiparirea facturii unui client');
WRITELN(StringOfChars ('_', lineLength));
PrintBill
END.
CliList
(* >>> CliList <<< -------- ----- ------ ------ *)
(* Nume fisier : CLILIST.PAS *)
(* Programul tipareste o lista cu toate fisierele .HRS *)
(* din directorul curent, impreuna cu numarul total de ore *)
(* facturate in fiecare cont, precum si starea fiecarui *)
(* cont : curent, recent sau inactiv. *)
(* -------- ----- ------ ----- ----- ------------ *)
PROGRAM CliList;
USES CRT, DOS, PRINTER, StrUnit;
CONST
maxFiles = 100;
TYPE
fileRange = 1..maxFiles;
clientArray = ARRAY [fileRange] OF STRING;
VAR
clientFiles: clientArray;
listLength,
i: BYTE;
dirString: STRING;
PROCEDURE GetFiles (VAR numberOfFiles: BYTE);
(* -------- ----- ------ ----- ----- ------------- *)
(* Procedura investigheaza directorul curent si creaza o *)
(* lista cu toate fisierele .HRS depunind numele clientilor *)
(* in tabloul clientFiles. De asemenea procedura determina *)
(* si numarul de fisere pe care-l retransmite apelantului. *)
(* -------- ----- ------ ----- ----- ------------- *)
CONST
fileName = 'HRSDIR.TXT';
VAR
dirFile: TEXT;
recordNumber,
extensionPos,
firstSpace: BYTE;
dirLine: STRING[40];
clientName: STRING;
BEGIN
EXEC('\COMMAND.COM', '/C DIR *.HRS > '+ fileName);
ASSIGN(dirFile, fileName); RESET (dirFile);
recordNumber := 0;
WHILE NOT EOF(dirFile) DO
BEGIN
READLN(dirFile, dirLine);
extensionPos := POS(' HRS ',dirLine);
IF extensionPos <> 0 THEN
BEGIN
INC(recordNumber);
firstSpace := POS(' ', dirLine);
clientName := COPY(dirLine, 1, firstSpace - 1);
clientFiles[recordNumber] := clientName
END
END;
CLOSE(dirFile);
numberOfFiles := recordNumber
END;
PROCEDURE SortClientFiles (sortLength: BYTE);
(* -------- ----- ------ ----- ----- -------- *)
(* Procedura utilizeaza algoritmul de sortare SHELL *)
(* pentru ordonarea alfabetica a listei clientilor. *)
(* -------- ----- ------ ----- ----- -------- *)
VAR
listJump, i, j: BYTE;
sortComplete: BOOLEAN;
saveName: STRING;
BEGIN
listJump :=1;
WHILE listJump <= sortLength DO listJump := listJump + 1;
WHILE listJump > 1 DO
BEGIN
listJump := (listJump - 1) DIV 2;
REPEAT
sortComplete := TRUE;
FOR j := 1 TO sortLength - listJump DO
BEGIN
i := j + listJump;
IF clientFiles[j] > clientFiles[i] THEN
BEGIN
saveName := clientFiles[j];
clientFiles[j] := clientFiles[i];
clientFiles[i] := saveName;
sortComplete := FALSE
END
END
UNTIL sortComplete
END
END;
PROCEDURE PrintClientList (printLength: BYTE);
(* -------- ----- ------ ----- ----- -------------- *)
(* Procedura tipareste lista sortata a numelor clientilor *)
(* impreuna cu totalul orelor facturate pentru fiecare cont *)
(* si starea acestui cont. *)
(* -------- ----- ------ ----- ----- -------------- *)
CONST
spaceBar = ' ';
escKey = #27;
formFeed = #12;
VAR
i, j: BYTE;
clientFile: STRING;
lastEntry: INTEGER;
inChar: CHAR;
FUNCTION TotalAccount (targetFileName: STRING; VAR lastDate: INTEGER): REAL;
(* -------- ----- ------ ----- ----- ------------- *)
(* Functia deschide fisierul de cont specificat, citeste *)
(* fiecare intrare si determina numarul total de ore curent *)
(* inregistrate in fisier. Acest total este furnizat ca *)
(* rezultat REAL al functiei. *)
(* -------- ----- ------ ----- ----- ------------- *)
CONST
yearColumn = 16;
yearLength = 4;
VAR
total,
hours: REAL;
targetFile: TEXT;
chronInfoString: STRING[29];
code: INTEGER;
BEGIN
total := 0.0;
ASSIGN(targetFile, targetFileName); RESET(targetFile);
WHILE NOT EOF (targetFile) DO
BEGIN
READLN(targetFile, chronInfoString, hours);
total := total + hours
END;
CLOSE (targetFile);
chronInfoString := COPY(chronInfoString, yearColumn, yearLength);
VAL (chronInfoString, lastDate, code);
TotalAccount := total
END;
FUNCTION ClientStatus (lastYear: INTEGER): STRING;
(* -------- ----- ------ ----- ----- ------------- *)
(* Functia furnizeaza un sir de asteriscuri reprezentind *)
(* starea contului astfel : *)
(* *** un cont activ; *)
(* ** un cont recent; *)
(* * un cont inactiv. *)
(* -------- ----- ------ ----- ----- ------------- *)
BEGIN
CASE lastYear OF
1990..1991: ClientStatus := '***';
1988..1989: ClientStatus := '**';
1980..1987: ClientStatus := '*';
ELSE ClientStatus := '';
END
END;
PROCEDURE PrintExplanations;
(* -------- ----- ------ ----- ----- ------- *)
(* Procedura tipareste semnificatia notatiilor din *)
(* coloana starea contului a raportului. *)
(* -------- ----- ------ ----- ----- ------- *)
BEGIN
WRITELN(LST); WRITELN(LST, StringOfChars ('-', 40));
WRITELN(LST); WRITELN(LST, ' *** Cont curent.');
WRITELN(LST, ' ** Cont recent.');
WRITELN(LST, ' * Cont inactiv.');
END;
BEGIN
WRITELN(' Apasati bara "spatiu" cind imprimanta este gata');
WRITELN(' sau "Esc" pentru iesire fara imprimare.');
REPEAT inChar := READKEY UNTIL (inChar = spaceBar) OR (inChar = escKey);
WRITELN;
IF inChar = ' ' THEN
BEGIN
WRITELN(LST, 'Nume client
WRITELN(LST, '____ ______ ___ _________ _____'); WRITELN(LST);
FOR i := 1 TO printLength DO
BEGIN
WRITE(LST, LeftAlign(InitialCap (clientFiles[i]), 18));
clientFile := clientFiles[i] + '.HRS';
WRITE(LST, TotalAccount(clientFile, lastEntry):7:2);
WRITELN(LST, Spaces (9), ClientStatus(lastEntry))
END;
PrintExplanations; WRITELN (LST,formFeed)
END
END;
BEGIN
CLRSCR;
WRITELN('Tiparirea listei cu fisierele clientilor');
WRITELN('_________ ______ __ _________ __________');
WRITELN;
GetFiles(listLength);
IF listLength > 0 THEN
BEGIN
SortClientFiles(listLength);
PrintClientList(listLength)
END
ELSE
BEGIN
WRITELN;
GETDIR(0, dirString);
WRITELN(' In directorul ', dirString,' nu exista ');
WRITELN('fisiere cu extensia .HRS')
END
END.
CliAddr
(* >>> CliAddr <<< -------- ----- ------ - *)
(* Nume fisier : CLIADDR.PAS *)
(* Programul creaza si intretine un fisier de date *)
(* continind adresele clientilor. *)
(* -------- ----- ------ ----- ----- ------- *)
PROGRAM CliAddr;
USES CRT, PRINTER, InUnit, StrUnit;
CONST
maxAddresses = 250;
addressFileName = 'ADDRLIST.TXT';
nameSort = '1';
refNoSort = '2';
TYPE
addressRecord = RECORD
name: STRING[30];
phone: STRING[20];
refNo: BYTE;
headOffice: BOOLEAN;
street: STRING[30];
city: STRING[20];
CASE
TRUE:
(state: STRING[2];
zip: STRING[5]);
FALSE:
(otherLoc,
country: STRING[15])
END;
indexRange = 1..maxAddresses;
AddressArray = ARRAY [indexRange] OF addressRecord;
VAR
done: BOOLEAN;
addresses: addressArray;
addressFile: TEXT;
currentRecord: BYTE;
PROCEDURE ReadAddresses;
(* -------- ----- ------ ----- ----- ----------- *)
(* Procedura deschide fisierul ADDRLIST.TXT si citeste *)
(* fiecare adresa de client pe care o memoreaza intr-un *)
(* element al tabloului de adrese. *)
(* -------- ----- ------ ----- ----- ----------- *)
VAR
officeCode,
usaCode: BYTE;
BEGIN
RESET (addressFile);
IF IORESULT = 0 THEN
BEGIN
WHILE NOT EOF (addressFile(c) AND (currentRecord < maxAddresses) DO
BEGIN
INC (currentRecord);
WITH addresses[currentRecord] DO
BEGIN
READLN(addressFile, name);
READLN(addressFile, officeCode, usaCode, refNo);
headOffice :=
BOOLEAN(officeCode);
READLN(addressFile, phone); READLN(addressFile, street);
READLN(addressFile, city);
IF
BEGIN
READLN(addressFile, state); READLN(addressFile, zip(c)
END
ELSE
BEGIN
READLN(addressFile, otherLoc);
READLN(addressFile, country(c)
END
END
END;
CLOSE(addressFile)
END
END;
PROCEDURE NewAddress;
(* -------- ----- ------ ----- ----- ------------- *)
(* Procedura dirijeaza dialogul de introducere pentru *)
(* inregistrarea unei noi adrese; totodata permite salvarea *)
(* sau abandonarea adresei introduse. *)
(* -------- ----- ------ ----- ----- ------------- *)
CONST
yesNo : SET OF CHAR = ['Y', 'N'];
VAR
usaForeign,
inRead,
okToSave : CHAR;
PROCEDURE GetStateAndZip;
(* ---- Extrage statul si codul postal pentru o adresa din SUA ---- *)
BEGIN
WITH addresses[currentRecord] DO
BEGIN
WRITE(' Statul : '); READLN(state);
WRITE(' Codul zip : '); READLN(zip)
END
END;
PROCEDURE GetCountryInfo;
(* ----- Extrage statul/provincia si
BEGIN
WITH addresses[currentRecord] DO
BEGIN
WRITE(' Statul sau provincia : '); READLN(otherLoc);
WRITE('
END
END;
PROCEDURE SaveAddress;
(* ---- Salvarea unei noi adrese in fisierul ADDRLIST.TXT ---- *)
BEGIN
IF currentRecord > 1 THEN APPEND(addressFile)
ELSE REWRITE(addressFile);
WITH addresses[currentRecord] DO
BEGIN
WRITELN(addressFile, name);
WRITELN(addressFile,
BYTE(headOffice), ' ', BYTE(
WRITELN(addressFile, phone); WRITELN(addressFile, street);
WRITELN(addressFile, city);
IF
BEGIN
WRITELN(addressFile, state); WRITELN(addressFile, zip)
END
ELSE
BEGIN
WRITELN(addressFile, otherLoc); WRITELN(addressFile, country)
END
END;
CLOSE (addressFile)
END;
BEGIN
WRITELN('Introducerea adresei unui client');
WRITELN('------------ ------- ---- ------'); WRITELN;
INC(currentRecord);
WITH addresses[currentRecord] DO
BEGIN
WRITE(' Numele clientului : '); READLN(name);
refNo := InByte(' Numarul de referinta : ');
WRITE(' Strada clientului : '); READLN(street);
WRITE(' Localitate : '); READLN(city);
usaForeign := InChar('SUA sau Extern (S E) : ', ['S', 'E']);
WRITELN(usaForeign);
END;
CASE addresses[currentRecord].usa OF
TRUE : GetStateAndZip;
FALSE: GetCountryInfo
END;
WITH addresses[currentRecord] DO
BEGIN
WRITE(' Numar telefon : '); READLN(phone);
InRead := InChar(' Antet oficiu (Y N) : ', yesNo);
headOffice := (InRead = 'Y');
WRITELN(InRead)
END;
WRITELN; WRITELN(StringOfChars ('-', 35)); WRITELN;
okToSave := InChar(' Salvati aceasta adresa (Y N) ? ', yesNo);
WRITELN(okToSave);
IF okToSave = 'Y' THEN
SaveAddress
ELSE
DEC (currentRecord);
CLRSCR
END;
PROCEDURE SortAddresses (sortBy: CHAR);
(* -------- ----- ------ ----- ----- -------- *)
(* Procedura foloseste un algoritm de sortare Shell *)
(* pentru aranjarea listei de adrese fie dupa numele *)
(* clientului fie dupa adresa lui; sortBy indica cheia *)
(* de sortare. *)
(* -------- ----- ------ ----- ----- -------- *)
VAR
listJump, i, j: BYTE;
sortComplete, sortTest: BOOLEAN;
saveRecord: addressRecord;
BEGIN
listJump := 1;
WHILE listJump <= currentRecord DO
listJump := listJump + 2;
WHILE listJump > 1 DO
BEGIN
listJump := (listJump - 1) DIV 2;
REPEAT
sortComplete := TRUE;
FOR j := 1 TO currentRecord - listJump DO
BEGIN
i := j + listJump;
IF sortBy = nameSort THEN
sortTest := addresses[j].name > addresses[i].name
ELSE
sortTest := addresses[j].refNo > addresses[i].refNo;
IF sortTest THEN
BEGIN
saveRecord := addresses[j]; addresses[j] := addresses[i];
addresses[i] := saveRecord; sortComplete := FALSE
END
END
UNTIL sortComplete
END
END;
PROCEDURE PrintList (addressDirectory: BOOLEAN);
(* -------- ----- ------ ----- ----- -------- *)
(* Procedura asigura listarea fie a adreselor fie a *)
(* numerelor de telefon; argumentul addressesDirectory *)
(* specifica tipul listei de imprimat. *)
(* -------- ----- ------ ----- ----- -------- *)
CONST
formFeed = #12;
VAR
SortSelection, inSpace: CHAR;
FUNCTION Continue: BOOLEAN;
(* -------- ----- ------ ----- ----- ------------ *)
(* Functia accepta un semnal de la utilizator pentru a *)
(* indica actiunea ce urmeaza, astfel : bara spatiu pentru *)
(* tiparirea listei; Escape pentru revenirea in meniu. *)
(* -------- ----- ------ ----- ----- ------------ *)
CONST
spaceBar = ' ';
escKey = #27;
prompt 1/2 '<Spatiu> tiparire; <Esc> revenire in meniu';
VAR
inKey: CHAR;
BEGIN
inKey :1/2 InChar (prompt, [spaceBar, escKey]);
Continue := (inKey = spaceBar)
END;
PROCEDURE PrintAddresses;
(* ---- Tiparirea listei cu adresele clientilor ----- *)
VAR
i: BYTE;
BEGIN
WRITELN(LST, ' Lista adreselor clientilor');
WRITELN(LST, ' ----- --------- ----------'); WRITELN(LST);
FOR i := 1 TO currentRecord DO
WITH addresses[i] DO
BEGIN
WRITE(LST, LeftAlign (name, 35), refNo);
IF headOffice THEN WRITELN (LST, ' X'(c) ELSE WRITELN(LST, ' B');
WRITELN(LST, street); WRITE(LST, city, ', ');
IF
ELSE WRITELN(LST, otherLoc, ' ', UpperCase (country));
WRITELN(LST, phone); WRITELN(LST); WRITELN(LST)
END
END;
PROCEDURE PrintPhone;
(* ---- Tiparirea listei cu telefoanele clientilor ----- *)
VAR
i: BYTE;
BEGIN
WRITELN(LST, ' Lista telefoanelor clientilor');
WRITELN(LST, ' ----- ------------ ----------'); WRITELN(LST);
WRITELN(LST, 'Nume', Spaces (29)¬ 'Nr.referinta', Spaces (7), 'Telefon');
WRITELN(LST);
FOR i :=1 TO currentRecord DO
WITH addresses[i] DO
BEGIN
WRITE(LST, LeftAlign (name, 35));
WRITE(LST, refNo:3, Spaces (15)); WRITELN(LST, phone)
END
END;
BEGIN
IF addressDirectory THEN
BEGIN
WRITELN('Tiparirea listei de adrese');
WRITELN('--------- ------ -- ------')
END
ELSE
BEGIN
WRITELN('Tiparirea listei de telefoane');
WRITELN('--------- ------ -- ---------')
END;
WRITELN; WRITELN('Sortare dupa :');
WRITELN(' 1. Nume');
WRITELN(' 2. Numar referinata'); WRITELN;
sortSelection :=
InChar(' Selectati 1 sau 2 --> ', [nameSort, refNoSort]);
WRITELN(sortSelection);
SortAddresses(sortSelection);
WRITELN; WRITELN(StringOfChars ('-', 50)); WRITELN;
IF Continue THEN
BEGIN
IF addressDirectory THEN PrintAddresses ELSE PrintPhone;
WRITELN(LST, formFeed)
END;
CLRSCR
END;
PROCEDURE Menu (VAR exitMenu: BOOLEAN);
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura afiseaza pe ecran in mode repetat meniul *)
(* principal si extrage optiunea utilizatorului. *)
(* -------- ----- ------ ----- ----- ---------- *)
VAR
choice,
discardCode: CHAR;
CONST
menuChars: SET OF CHAR = ['A', 'C', 'I', 'T'];
addresses = TRUE;
phones = FALSE;
PROCEDURE DisplayOption (optionString: STRING);
(* -------- ----- ------ ----- ----- ------------ *)
(* Procedura afiseaza pe ecran meniul cu optiuni; prima *)
(* litera a optiunii este afisata in video-invers. Aceasta *)
(* procedura foloseste rutina interna TEXTCOLOR. *)
(* -------- ----- ------ ----- ----- ------------ *)
BEGIN
TEXTCOLOR(LightBlue); WRITE (optionString[1]); TEXTCOLOR(LightGray);
WRITELN(COPY (optionString, 2, LENGTH (optionString) - 1))
END;
BEGIN
exitMenu := FALSE;
GOTOXY(20, 5); WRITELN('Managerul adreselor clientilor');
GOTOXY(20, 6); WRITELN('--------- --------- ----------');
GOTOXY(20, 7); DisplayOption('Adaugarea unei adrese.');
GOTOXY(20, 8); DisplayOption('Crearea directorului de adrese.');
GOTOXY(20, 9); DisplayOption('Imprimarea directorului de telefoane.');
GOTOXY(20, 10); DisplayOption('Terminare.'); GOTOXY(20, 12);
choice := InChar('** Optiuni meniu ( A C I T) --> ', menuChars); CLRSCR;
CASE choice OF
'A' : NewAddress;
'C' : IF currentRecord > 0 THEN PrintList (addresses);
'I' : IF currentRecord > 0 THEN PrintList (phones);
'T' : exitMenu := TRUE
END
END;
BEGIN
ASSIGN( addressFile, addressFileName);
currentRecord := 0; ClrScr;
ReadAddresses;
REPEAT Menu (done(c) UNTIL done
END.
CliMenu
(* >>> CliMenu <<< -------- ----- ------ ------ *)
(* Nume fisier : CLIMENU.PAS *)
(* Programul dirijeaza activitatile pe baza unui meniu. *)
(* El foloseste comanda EXEC pentru a lansa in executie *)
(* unul din urmatoarele programe executabile : HOURS.EXE, *)
(* BILLTIME.EXE, CLILIST.EXE si CLIADDR.EXE. *)
(* -------- ----- ------ ----- ----- ------------ *)
PROGRAM CliMenu;
USES CRT, DOS, StrUnit;
TYPE
activities= (updateClient, billClient, listClients, listAddresses, quit);
activityRecord= RECORD
fileName: STRING[8];
row, column: BYTE;
menuString: STRING[25]
END;
CONST
columnPos= 24;
optionDisplay= ' U B L P Q ';
nullChar= #10;
enter= #13;
bell= #7;
upArrow= #72;
leftArrow= #75;
rightArrow= #77;
downArrow= #80;
activity: ARRAY[activities] OF activityRecord=
((fileName: 'HOURS'; row: 8; column: columnPos;
menuString: 'Update a client file.'),
(fileName: 'BILLTIME'; row: 9; column: columnPos;
menuString: 'Bill a client file.'),
(fileName: 'CLILIST'; row: 10; column: columnPos;
menuString: 'List account and totals.'),
(fileName: 'CLIADDR'; row: 11; column: columnPos;
menuString: 'Print client addresses.'),
(fileName: ''; row: 12; column: columnPos;
menuString: 'Quit.'));
menuChars: SET OF CHAR= ['U', 'B', 'L', 'P', 'Q', nullChar, enter];
cursorScanCodes: SET OF CHAR= [upArrow, leftArrow, rightArrow, downArrow];
VAR
done: BOOLEAN;
currentSelection: activities;
PROCEDURE ReverseVideo (status: BOOLEAN);
(* -------- ----- ------ ----- ----- ----------- *)
(* Procedura afiseaza optiunile in video-normal sau in *)
(* video-invers, in functie de valoarea argumentului. *)
(* -------- ----- ------ ----- ----- ----------- *)
BEGIN
IF status THEN
BEGIN TextColor(Black); TextBackGround(White(c) END
ELSE
BEGIN TextColor(White); TextBackGround(Black(c) END
END;
PROCEDURE HighLightSelection;
(* -------- ----- ------ ----- ----- -------- *)
(* Marcheaza selectia curenta din meniu. Aceasta se *)
(* va afisa in video-invers, cu litere mari. *)
(* -------- ----- ------ ----- ----- -------- *)
BEGIN
ReverseVideo (TRUE);
WITH activity[currentSelection] DO
BEGIN
GoToXY(column, row); WriteLn(UpperCase (menuString))
END;
ReverseVideo(FALSE)
END;
PROCEDURE InitializeMenu;
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura asigura afisarea initiala a meniului pe *)
(* ecran, stabilind selectia curenta pe prima optiune(r) *)
(* -------- ----- ------ ----- ----- ---------- *)
VAR
option: activities;
BEGIN
ClrScr;
ReverseVideo(TRUE); GoToXY(columnPos - 8, 6);
WriteLn('*** Client-File Management activities ***'); ReverseVideo(FALSE);
FOR option := updateClient TO quit DO
WITH activity[option] DO
BEGIN GoToXY(column, row); WriteLn(menuString(c) END;
currentSelection := updateClient;
HighLightSelection;
GoToXY(columnPos - 12, 16); Write('(Use ');
ReverseVideo(TRUE); Write(#24, ' ', #25, ' ', #26, ' ', #27);
ReverseVideo(FALSE); Write(' or '); ReverseVideo (TRUE);
Write(optionDisplay); ReverseVideo(FALSE); Write(' to highlight on option');
GoToXY(columnPos - 12, 17);
Write('then press <Enter> to complete the selection.)')
END;
PROCEDURE GetSelection (VAR quitSignal: BOOLEAN);
(* ---- Accepta sa execute optiunea selectata ---- *)
CONST
firstChar= 'UBLPQ';
VAR
inChar: CHAR;
PROCEDURE Continue;
(* ---- Pastreaza informatia pe ecran ----- *)
VAR
inSpace: CHAR;
BEGIN
GoToXY(10, 25); Write('Press the space bar to return to the menu.');
REPEAT inSpace := ReadKey UNTIL inSpace = ' '
END;
PROCEDURE RemoveHighLight;
(* ----- Restaurarea optiunii deselectate ----- *)
BEGIN
WITH activity[currentSelection] DO
BEGIN GoToXY(column, row); WriteLn(menuString(c) END
END;
PROCEDURE SelectNextActivity;
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura marcheaza optiunea urmatoare din meniu, *)
(* raspunzind astfel la tasta sageata jos sau dreapta. *)
(* -------- ----- ------ ----- ----- ---------- *)
BEGIN
RemoveHighLight;
IF currentSelection = quit THEN currentSelection := updateClient
ELSE currentSelection := SUCC(currentSelection);
HighLightSelection
END;
PROCEDURE SelectPreviousActivity;
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura marcheaza optiunea anterioara din meniu, *)
(* raspunzind astfel la tasta sageata sus sau stinga. *)
(* -------- ----- ------ ----- ----- ---------- *)
BEGIN
RemoveHighLight;
IF currentSelection = updateClient THEN currentSelection := quit
ELSE currentSelection := PRED(currentSelection);
HighLightSelection
END;
BEGIN
quitSignal := FALSE;
REPEAT
inChar := UPCASE (ReadKey);
IF NOT (inChar IN menuChars) THEN Write (bell)
UNTIL (inChar IN menuChars);
CASE inChar OF
'U', 'B', 'L', 'P', 'Q':
BEGIN
RemoveHighLight;
currentSelection := activities(POS(inChar, firstChar) - 1);
HighLightSelection
END;
nullChar:
BEGIN
inChar := ReadKey;
IF inChar IN cursorScanCodes THEN
CASE inChar OF
upArrow, leftArrow: SelectPreviousActivity;
downArrow, rightArrow: SelectNextActivity
END
ELSE Write (bell)
END;
enter:
BEGIN
IF currentSelection = quit THEN quitSignal := TRUE
ELSE
BEGIN
WITH activity[currentSelection] DO
EXEC (fileName + '.EXE', '');
Continue; ClrScr;
InitializeMenu
END
END
END
END;
BEGIN
InitializeMenu;
REPEAT
GetSelection (done)
UNTIL done;
ClrScr
END.
PtrTest
(* >>> PtrTest <<< -------- ----- ------ - *)
(* Nume fisier : PTRTEST.PAS *)
(* Programul demonstreaza principiile de lucru cu *)
(* variabilele dinamice si cu listele inlantuite. *)
(* Programul creaza o lista inlantuita de articole. *)
(* Fiecare articol din lista contine trei cimpuri : *)
(* ;nextLetter; - pointer catre urmatorul articol; *)
(* ;prevLetter; - pointer catre articolul anterior; *)
(* ;alphChar; - contine un caracter (de la A la Z)*)
(* -------- ----- ------ ----- ----- ------- *)
PROGRAM PtrTest;
USES CRT;
TYPE
alphPtr = ^alphRecord;
alphRecord= RECORD
nextLetter,
prevLetter: alphPtr;
alphChar: CHAR
END;
VAR
firstLetter,
lastLetter,
newLetter,
oldLetter: alphPtr;
letter: CHAR;
PROCEDURE SetLetterPointers;
(* ---- Crearea listei dublu inlantuite ----- *)
BEGIN
letter := 'A'; NEW(newLetter); firstLetter := newLetter;
firstLetter^.prevLetter := NIL; firstLetter^.alphChar := letter;
oldLetter := firstLetter;
WHILE letter <> 'Z' DO
BEGIN
letter := SUCC (letter); NEW (newLetter);
newLetter^.alphChar := letter;
newLetter^.prevLetter := oldLetter;
oldLetter^.nextLetter := newLetter; oldLetter := newLetter
END;
lastLetter := newLetter;
lastLetter^.nextLetter := NIL
END;
PROCEDURE PrintForward;
(* -------- ----- ------ ------------- *)
(* Rutina parcurge, ;inainte;, lista inlantuita *)
(* si afiseaza ficare cimp alphChar. *)
(* -------- ----- ------ ------------- *)
VAR
nextPrintLetter: alphPtr;
BEGIN
nextPrintLetter := firstLetter;
WHILE nextPrintLetter^.nextLetter <> NIL DO
BEGIN
WRITE(nextPrintLetter^.alphChar,' ');
nextPrintLetter := nextPrintLetter^.nextLetter
END;
WriteLn(nextPrintLetter^.alphChar)
END;
PROCEDURE PrintBackward;
(* -------- ----- ------ ------------- *)
(* Rutina parcurge, inapoi, lista inlantuita si *)
(*afiseaza ficare cimp alphChar. *)
(* -------- ----- ------ ------------- *)
VAR
prevPrintLetter: alphPtr;
BEGIN
prevPrintLetter := lastLetter;
WHILE prevPrintLetter^.prevLetter <> NIL DO
BEGIN
WRITE(prevPrintLetter^.alphChar,' ');
prevPrintLetter := prevPrintLetter^.prevLetter
END;
WriteLn (prevPrintLetter^.alphChar)
END;
BEGIN
SetLetterPointers; ClrScr;
WriteLn(' Afisare de la A la Z :'); PrintForward;
WriteLn; WriteLn (' Afisare de la Z la A :'); PrintBackward;
WriteLn; Readln
END.
PtrAddr
(* >>> PtrAddr <<< -------- ----- ------ --- *)
(* Nume fisier : PTRADDR.PAS *)
(* PtrAddr este un program controlat prin meniu. *)
(* El permite adaugarea unei adrese noi, imprimarea *)
(* adreselor sau a telefoanelor clientilor din fisierul *)
(* ADDRLIST.TXT si exemplificarea lucrului cu pointeri. *)
(* -------- ----- ------ ----- ----- --------- *)
PROGRAM PtrAddr;
USES CRT, PRINTER, InUnit, StrUnit;
CONST
addressFileName= 'ADDRLIST.TXT';
numRecords : INTEGER = 0;
TYPE
addressPointer= ^addressRecord;
addressRecord= RECORD
nextName, prevName, nextRefNo, prevRefNo: addressPointer;
name: STRING[30];
phone: STRING[20];
refNo: BYTE;
headOffice: BOOLEAN;
street: STRING[30];
city: STRING[20];
CASE
TRUE : (state: STRING[2];
zip: STRING[6]);
FALSE: (otherLoc, country: STRING[15])
END;
CONST
firstName: addressPointer= NIL;
VAR
firstRefNo, lastName, lastRefNo, newRecord: addressPointer;
addressFile: TEXT;
done: BOOLEAN;
PROCEDURE SetPointers;
(* -------- ----- ------ ----- ----- -------- *)
(* Procedura stabileste pointerii listei inlantuite. *)
(* Aceasta seteaza cele patru cimpuri pointer ale unui *)
(* articol in fiecare nou articol de adresa citit din *)
(* fisierul ADDRLIST.TXT. *)
(* -------- ----- ------ ----- ----- -------- *)
VAR
current, previous: addressPointer;
locFound: BOOLEAN;
PROCEDURE FindNamePointers;
(* -------- ----- ------ ----- ----- -------- *)
(* Procedura stabileste pointerii pentru doua tipuri *)
(* de sortare : in ordine alfabetica si in ordine *)
(* invers alfabetica, dupa cimpul name. *)
(* -------- ----- ------ ----- ----- -------- *)
BEGIN
IF newRecord^.name < firstName^.name THEN
BEGIN
newRecord^.nextName := firstName; newRecord^.prevName := NIL;
firstName^.prevName := newRecord; firstName := newRecord
END
ELSE
BEGIN
locFound := FALSE; previous := firstName; current := firstName;
WHILE (NOT locFound) AND (current^.nextName <> NIL) DO
BEGIN
current := current^.nextName;
IF newRecord^.name < current^.name THEN
BEGIN
locFound := TRUE; previous^.nextName := newRecord;
newRecord^.prevName := previous;
newRecord^.nextName := current; current^.prevName := newRecord
END
ELSE previous := current
END;
IF (NOT locFound) THEN
BEGIN
newRecord^.prevName := current; current^.nextName := newRecord;
newRecord^.nextName := NIL; lastName := newRecord
END
END
END;
PROCEDURE FindRefNoPointers;
(* -------- ----- ------ ----- ----- --------- ----- ------ *)
(* Procedura stabileste pointerii pentru doua tipuri de sortare *)
(* numerica: crescatoare si descrescatoare dupa valorile din refNo.*)
(* -------- ----- ------ ----- ----- --------- ----- ------ *)
BEGIN
IF newRecord^.refNo < firstRefNo^. refNo THEN
BEGIN
newRecord^.nextRefNo := firstRefNo; newRecord^.prevRefNo := NIL;
firstRefNo^.prevRefNo := newRecord; firstRefNo := newRecord
END
ELSE
BEGIN
locFound := FALSE; previous := firstRefNo; current := firstRefNo;
WHILE (NOT locFound) AND (current^.nextRefNo <> NIL) DO
BEGIN
current := current^.nextRefNo;
IF newRecord^.refNo < current^.refNo THEN
BEGIN
locFound := TRUE; previous^.nextRefNo := newRecord;
newRecord^.prevRefNo := previous;
newRecord^.nextRefNo := current;
current^.prevRefNo := newRecord
END
ELSE previous := current
END;
IF (NOT locFound) THEN
BEGIN
newRecord^.prevRefNo := current; current^.nextRefNo := newRecord;
newRecord^.nextRefNo := NIL; lastRefNo := newRecord
END
END
END;
BEGIN
IF firstName = NIL THEN
BEGIN
firstName := newRecord; lastName := newRecord;
firstRefNo := newRecord; lastRefNo := newRecord;
WITH newRecord^ DO
BEGIN
nextName := NIL; prevName := NIL;
nextRefNo := NIL; prevRefNo := NIL
END
END
ELSE
BEGIN FindNamePointers; FindRefNoPointeró END
END;
PROCEDURE ReadAddresses;
(* -------- ----- ------ ----- ----- ---------------- *)
(* Procedura deschide fisierul ADDRLIST.TXT si creaza o noua *)
(* variabila dinamica pentru fiecare adresa din fisier. *)
(* -------- ----- ------ ----- ----- ---------------- *)
VAR
OfficeCode, usaCode: BYTE;
BEGIN
RESET (addressFile);
IF IORESULT = 0 THEN
BEGIN
WHILE NOT EOF(addressFile) DO
BEGIN
NEW(newRecord); INC(numRecords);
WITH newRecord^ DO
BEGIN
ReadLn(addressFile, name);
ReadLn(addressFile, officeCode, usaCode, refNo);
headOffice := BOOLEAN(officeCode);
ReadLn(addressFile, street); ReadLn(addressFile, city);
IF
BEGIN
ReadLn(addressFile, state); ReadLn(addressFile, zip))
END
ELSE
BEGIN
ReadLn(addressFile,otherLoc); ReadLn(addressFile, country)
END
END;
SetPointers
END;
CLOSE(addressFile);
END
END;
PROCEDURE NewAddress;
(* -------- ----- ------ ----- ----- ------ *)
(* Procedura dirijeaza dialogul de introducere a *)
(* datelor pentru o noua adresa de client si asigura *)
(* salvarea sau nu a adresei introduse. *)
(* -------- ----- ------ ----- ----- ------ *)
CONST
yesNo: SET OF CHAR = ['Y', 'N'];
VAR
UsaForeign, inHead, okToSave: CHAR;
inAddress: addressPointer;
PROCEDURE GetStateAndZip;
(* ---- Extrage codul statului si
codul postal (adrese
BEGIN
WITH inAddress^ DO
BEGIN
Write(' Statul : '); ReadLn(state);
Write(' Codul postal : '); ReadLn(zip)
END
END;
PROCEDURE GetCountryInfo;
(* ----- Extrage statul/provincia si localitatea (adrese externe) --- *)
BEGIN
WITH inAddress^ DO
BEGIN
Write(' Statul sau provincia : '); ReadLn (otherLoc);
Write(' Localitatea : '); ReadLn (country)
END
END;
PROCEDURE SaveAddress;
(* --- Slavarea articolulue introdus in fisierul ADDRLIST.TXT --- *)
BEGIN
IF numRecords > 1 THEN APPEND(addressFile)
ELSE REWRITE(addressFile);
WITH inAddress^ DO
BEGIN
WriteLn(addressFile, name);
WriteLn(addressFile, BYTE
(headOffice), ' ', BYTE(
WriteLn(addressFile, phone); WriteLn(addressFile, street);
WriteLn(addressFile, city);
IF
BEGIN WriteLn(addressFile, state); WriteLn(addressFile, zip) END
ELSE
BEGIN
WriteLn(addressFile, otherLoc); WriteLn(addressFile, country)
END
END;
CLOSE(addressFile)
END;
BEGIN
NEW(inAddress); WriteLn('Se introduce adresa unui nou client');
WriteLn('-- --------- ------ ---- --- ------'); WriteLn;
WITH inAddress^ DO
BEGIN
Write(' Numele clientului : '); ReadLn(name);
refNo := InByte(' Numarul de referinta : ');
Write(' Strada : '); ReadLn(street);
Write(' Localitate : '); ReadLn(city);
usaForeign := InChar('
WriteLn(usaForeign);
END;
CASE inAddress^.usa OF
TRUE: GetStateAndZip;
FALSE: GetCountryInfo
END;
WITH inAddress^ DO
BEGIN
Write(' Numar telefon : '); ReadLn (phone);
inHead := InChar(' Oficiu principal ? (Y N) : ', yesNo);
headOffice := (inHead = 'Y'); WriteLn (inHead)
END;
WriteLn; WriteLn(StringOfChars ('-', 30));
WriteLn; okToSave := InChar('Salvati acest articol ? (Y N) : ', yesNo);
IF okToSave = 'Y' THEN
BEGIN
INC(numRecords); SaveAddress;
newRecord := inAddress; SetPointers
END
ELSE
DISPOSE(inAddress);
ClrScr
END;
PROCEDURE PrintList (addressDirectory: BOOLEAN);
(* -------- ----- ------ ----- ----- ------------ *)
(* Procedura tipareste fie lista adreselor fie lista *)
(* telefoanelor; argumentul addressDirectory specifica *)
(* lista de tiparit, iar sortSelection specifica sortarea. *)
(* -------- ----- ------ ----- ----- ------------ *)
CONST
formFeed= #12;
nameAtoZ= '1';
nameZtoA= '2';
refNoAscend= '3';
refNoDescend= '4';
sortSet : SET OF CHAR 1/2 [nameAtoZ, nameZtoA, refNoAscend, refNoDescend];
VAR
sortSelection: CHAR;
firstAddress: addressPointer;
FUNCTION Continue: BOOLEAN;
(* -------- ----- ------ ----- ----- --------- *)
(* Functia asteapta indicatia utilizatorului pentru a *)
(* trece la actiune: bara spatiu pentru tiparire sau *)
(* Escape pentru revenire in program. *)
(* -------- ----- ------ ----- ----- --------- *)
CONST
spaceBar= ' ';
escKey= #27;
prompt= '<Spatiu> tiparire; <Escape> revenire in DOS.';
VAR
inKey: CHAR;
BEGIN
inKey := InChar(prompt, [spaceBar, escKey]);
Continue := (inKey = spaceBar); WriteLn
END;
PROCEDURE PrintAddresses (address: addressPointer; wichSort: CHAR);
(* -------- ----- ------ ----- ----- ------------- *)
(* Procedura tipareste lista adreselor. ;address¢ contine *)
(* pointerul articolului ce se tipareste primul. ;wichSort¢ *)
(* indica cheia si directia operatiei de sortare. *)
(* -------- ----- ------ ----- ----- ------------- *)
VAR i: BYTE;
BEGIN
WriteLn(LST, 'Lista adreselor clientilor');
WriteLn(LST, '----- --------- ----------'); WriteLn(LST);
WHILE address <> NIL DO
BEGIN
WITH address^ DO
BEGIN
Write(LST, LeftAlign(name, 35), refNo:3);
IF headOffice THEN WriteLn(LST, 'H') ELSE WriteLn(LST, 'B');
WriteLn(LST, street); Write(LST, city, ', ');
IF
ELSE WriteLn(LST, otherLoc, ' ', UpperCase(country));
WriteLn(LST, phone); WriteLn(LST)
END;
CASE wichSort OF
nameAtoZ : address := address^.nextName;
nameZtoA : address := address^.prevName;
refNoAscend : address := address^.nextRefNo;
refNoDescend : address := address^.prevRefNo
END
END
END;
PROCEDURE PrintPhones (address: addressPointer; wichSort: CHAR);
(* -------- ----- ------ ----- ----- ----------------- *)
(* Procedura tipareste lista telefoanelor. address contine *)
(* pointerul articolului ce se tipareste primul. wichSort *)
(* indica cheia si directia operatiei de sortare. *)
(* -------- ----- ------ ----- ----- ----------------- *)
VAR i: BYTE;
BEGIN
WriteLn(LST, 'Lista telefoanelor clientilor');
WriteLn(LST, '----- ------------ ----------'); WriteLn (LST);
WriteLn(LST, 'Client', Spaces(27), 'Nr.referinta', Spaces(7), 'Telefon');
WriteLn (LST);
WHILE address <> NIL DO
BEGIN
WITH address^ DO
BEGIN
Write(LST,LeftAlign(name,35));
Write(LST,refNo:3,Spaces(10));WriteLn(LST,phone)
END;
CASE wichSort OF
nameAtoZ : address := address^.nextName;
nameZtoA : address := address^.prevName;
refNoAscend : address := address^.nextRefNo;
refNoDescend : address := address^.prevRefNo
END
END
END;
BEGIN
WriteLn;
IF addressDirectory THEN
BEGIN
WriteLn('Tiparirea adreselor'); WriteLn('--------- ---------')
END
ELSE
BEGIN
WriteLn('Tiparirea telefoanelor'); WriteLn('--------- ------------')
END;
WriteLn('Sortare dupa :'); WriteLn;
WriteLn(' 1. Nume (de la A la Z);');
WriteLn(' 2. Nume (de la Z la A);');
WriteLn(' 3. Numar de referinta (crescator);');
WriteLn(' 4. Numar de referinta (descrescator).'); WriteLn;
sortSelection := InChar(' Selectati (1 2 3 4) ---> ', sortSet);
CASE sortSelection OF
nameAtoZ: firstAddress := firstName;
nameZtoA: firstAddress := lastName;
refNoAscend: firstAddress := firstRefNo;
refNoDescend: firstAddress := lastRefNo
END;
WriteLn(StringOfChars ('-', 30)); WriteLn;
IF Continue THEN
BEGIN
IF AddressDirectory THEN
PrintAddresses(firstAddress, sortSelection)
ELSE
PrintPhones(firstAddress, sortSelection);
WriteLn(LST, formFeed)
END
END;
PROCEDURE Menu (VAR exitMenu: BOOLEAN);
(* -------- ----- ------ ----- ----- --------- *)
(* Procedura afiseaza recursiv meniul principal pe *)
(* ecran, si extrage optiunea de meniu a utilizatorului *)
(* -------- ----- ------ ----- ----- --------- *)
VAR
Choice, discardCode: CHAR;
CONST
menuChars: SET OF CHAR = ['A', 'C', 'T', 'I'];
addresses= TRUE;
phones= FALSE;
PROCEDURE DisplayOption (optionString: STRING);
(* -------- ----- ------ ----- ----- ------ *)
(* Procedura afiseaza pe ecran optiunile meniului, *)
(* cu primul caracter afisat in video invers. *)
(* -------- ----- ------ ----- ----- ------ *)
BEGIN
TextColor(White); Write(optionString[1]); TextColor(LightGray);
WriteLn(COPY (optionString, 2, LENGTH (optionString) - 1))
END;
BEGIN
exitMenu := FALSE;
GoToXY(20, 5); WriteLn('Administratorul adreselor clientilor');
GoToXY(20, 6); WriteLn('----- ----- ----- --------- ----------');
GoToXY(20, 7); DisplayOption('Adaugarea unei adrese.');
GoToXY(20, 8); DisplayOption('Crearea directorului de adrese.');
GoToXY(20, 9); DisplayOption('Tiparirea telefoanelor.');
GoToXY(20, 10); DisplayOption('Iesire.'); GoToXY(20, 12);
choice := InChar('** Optiune meniu (A C T I) ---> ', menuChars);
ClrScr;
CASE choice OF
'A': NewAddress;
'C': IF numRecords > 0 THEN PrintList(addresses);
'T': IF numRecords > 0 THEN PrintList(phones);
'I': exitMenu := TRUE
END
END;
BEGIN
ASSIGN (addressFile, addressFileName);
ReadAddresses;
ClrScr;
REPEAT
Menu (done)
UNTIL done
END.
NumDemo
(* >>> NumDemo <<< ----- ----- --------- ----- -------- *)
(* Nume fisier : NUMDEMO.PAS *)
(* Programul demonstreaza lucrul cu o parte din *)
(* rutinele numerice standard din Turbo Pascal. *)
(* -------- ----- ------ ----- ----- ----- *)
PROGRAM NumDemo;
USES CRT, InUnit, StrUnit;
VAR
done: BOOLEAN;
arg : REAL;
PROCEDURE ExpLnDemo;
(* -------- ----- ------ ----------- *)
(* Procedura ExpLnDemo demonstreaza modul de *)
(* lucru cu functiile standard EXP si LN. *)
(* -------- ----- ------ ----------- *)
VAR
i: SHORTINT;
BEGIN
WRITELN(Spaces(6), 'n', Spaces(6),'EXP (n)', Spaces(4), 'LN (n)'); WRITELN;
FOR i:= -6 TO 7 DO
BEGIN
arg := i/2;
WRITE(arg:10:4, EXP(arg):10:4);
IF i <= 0 THEN WRITELN(' ~') ELSE WRITELN(LN(arg):10:4)
END
END;
PROCEDURE TrigDemo;
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura TrigDemo demonstreaza lucrul cu functiile *)
(* trigonometrice SIN, COS, ARCTAN
si cu
(* -------- ----- ------ ----- ----- ---------- *)
VAR
i: SHORTINT;
BEGIN
WRITE(Spaces (4), 'n', Spaces(7), 'SIN (n*PI)', Spaces(4), 'COS (n*PI)');
WRITELN(Spaces (2), 'ARCTAN (n)'); WRITELN;
FOR i:= -8 TO 8 DO
BEGIN
arg := PI * i / 8;
WRITE(i/8:7:4, SIN (arg):13:4, COS(arg):13:4);
WRITELN(ARCTAN(i/8):13:4)
END
END;
PROCEDURE IntDemo;
(* -------- ----- ------ ----- ----- -------- *)
(* Procedura IntDemo demonstreaza functiile intregi : *)
(* INT, ROUND si TRUNC, precum si cu functia FRAC. *)
(* -------- ----- ------ ----- ----- -------- *)
VAR
i: SHORTINT;
BEGIN
WRITE(' n', Spaces(6), 'INT (n)', Spaces(3), 'ROUND (n)');
WRITELN(Spaces(2), 'TRUNC (n)', Spaces (3), 'FRAC (n)'); WRITELN;
FOR i:= -10 TO 10 DO
BEGIN
arg := i / 4;
WRITE(arg:5:2, INT(arg):10:1, ROUND(arg):10);
WRITELN(TRUNC(arg):10, FRAC(arg):10:2)
END
END;
PROCEDURE ArithDemo;
(* -------- ----- ------ ----- ----- ------- *)
(* Procedura ArithDemo demonstreaza modul de lucru *)
(* al functiile : ABS, SQR si SQRT. *)
(* -------- ----- ------ ----- ----- ------- *)
VAR
i: SHORTINT;
BEGIN
WRITE(' n', Spaces(6), 'ABS (n)', Spaces(4), 'SQR (n)');
WRITELN(Spaces(2), 'SQRT (n)'); WRITELN;
FOR i:= -10 to 10 DO
BEGIN
WRITE (i:3, ABS(i):10, SQR(i):10);
IF i < 0 THEN WRITELN (' ~')
ELSE WRITELN(SQRT(i):12:4)
END
END;
PROCEDURE Menu (VAR exitMenu: BOOLEAN);
(* -------- ----- ------ ----- ----- --------- *)
(* Rutina afiseaza pe ecran un meniu si raspunde in *)
(* conformitate cu optiunea utilizatorului. Parametrul *)
(* VAR exitMenu transmite valoarea TRUE daca a fost *)
(* selectata optiunea Iesire. *)
(* -------- ----- ------ ----- ----- --------- *)
CONST
col = 25;
VAR
optiune : CHAR;
contSemnal: STRING;
BEGIN
CLRSCR; exitMenu := FALSE;
GOTOXY(col - 5,5); WRITELN('Functii numerice standard');
GOTOXY(col, 7); WRITELN('1, Exponentiale');
GOTOXY(col, 8); WRITELN('2, Trigonometrice');
GOTOXY(col, 9); WRITELN('3, Intregi');
GOTOXY(col,10); WRITELN('4, Aritmetice');
GOTOXY(col,11); WRITELN('5, Iesire'); GOTOXY(col-3, 13);
optiune:= InChar(' ** Optiune meniu : 1 - 5 *** ',['1'..'5']); CLRSCR;
CASE optiune OF
'1': ExpLnDemo;
'2': TrigDemo;
'3': IntDemo;
'4': ArithDemo;
'5': exitMenu := TRUE
END;
IF optiune <> '5' THEN
BEGIN
WRITELN;
contSemnal := InChar(' Apasati <spatiu> pentru continuare ',[' ']);
END;
CLRSCR
END;
BEGIN
REPEAT
Menu (done)
UNTIL done
END.
RandAddr
(* >>> RandAddr <<< -------- ----- ------ ------ *)
(* Nume fisier : RANDADDR.PAS *)
(* Programul simuleaza date pentru testarea algoritmilor *)
(* din PtrAddr. RandAddr creaza fisierul RANDTEST.TXT, care *)
(* contine liste de nume si numere de referinta generate *)
(* aleator si sortate dupa patru criterii diferite. *)
(* -------- ----- ------ ----- ----- ------------- *)
PROGRAM RandAddr;
USES CRT, RandUnit;
CONST
recsToCreate= 8;
numRecords: INTEGER = 0;
TYPE
addressPointer= ^addressRecord;
addressRecord= RECORD
nextName, prevName, nextRefNo, prevRefNo: addressPointer;
name: STRING[30];
phone: STRING[20];
refNo: BYTE;
headOffice: BOOLEAN;
street: STRING[30];
city: STRING[20];
CASE usa: BOOLEAN OF
TRUE: (state: STRING[2];
zip: STRING[5]);
FALSE: (otherLoc, country: STRING[13])
END;
CONST
firstName: addressPointer= NIL;
VAR
FirstRefNo, lastName, LastRefNo, newRecord: addressPointer;
PROCEDURE SetPointers;
(* -------- ----- ------ ----- ----- ----------- *)
(* Rutina stabileste pointerii listei inlantuite, adica *)
(* valorile pentru cele patru cimpuri de tip pointer din *)
(* fiecare nou articol generat. *)
(* -------- ----- ------ ----- ----- ----------- *)
VAR
current, previous: addressPointer;
locFound: BOOLEAN;
PROCEDURE FindNamePointers;
(* -------- ----- ------ ----- ----- -------- *)
(* Rutina stabileste poinerii pentru doua ordini de *)
(* sortare : alfabetica si invers alfabetica, pentru *)
(* datele simulate si inregistrate in cimpul ;name;. *)
(* -------- ----- ------ ----- ----- -------- *)
BEGIN
IF newRecord^.name < firstName^.name THEN
BEGIN
newRecord^.nextName := firstName; newRecord^.prevName := NIL;
firstName^.prevName := newRecord; firstName := newRecord
END
ELSE
BEGIN
locFound := FALSE; previous := firstName; current := firstName;
WHILE (NOT locFound) AND (current^.nextName <> NIL) DO
BEGIN
current := current^.nextName;
IF newRecord^.name < current^.name THEN
BEGIN
locFound := TRUE; previous^.nextName := newRecord;
newRecord^.prevName := previous;
newRecord^.nextName := current;
current^.prevName := newRecord
END
ELSE previous := current
END;
IF (NOT locFound) THEN
BEGIN
newRecord^.prevName := current; current^.nextName := newRecord;
newRecord^.nextName := NIL; lastName := newRecord
END
END
END;
PROCEDURE FindRefNoPointers;
(* -------- ----- ------ ----- ----- -------- *)
(* Procedura stabileste pointerii pentru doua tipuri *)
(* de sortare numerica : crescatoare si descrescatoare *)
(* dupa valorile generate aleator pentru cimpul refNo. *)
(* -------- ----- ------ ----- ----- -------- *)
BEGIN
IF newRecord^.refNo < firstRefNo^. refNo THEN
BEGIN
newRecord^.nextRefNo := firstRefNo; newRecord^.prevRefNo := NIL;
firstRefNo^.prevRefNo := newRecord; firstRefNo := newRecord
END
ELSE
BEGIN
locFound := FALSE; previous := firstRefNo; current := firstRefNo;
WHILE (NOT locFound) AND (current^.nextRefNo <> NIL) DO
BEGIN
current := current^.nextRefNo;
IF newRecord^.refNo < current^.refNo THEN
BEGIN
locFound := TRUE; previous^.nextRefNo := newRecord;
newRecord^.prevRefNo := previous;
newRecord^.nextRefNo := current;
current^.prevRefNo := newRecord
END
ELSE previous := current
END;
IF (NOT locFound) THEN
BEGIN
newRecord^.prevRefNo := current; current^.nextRefNo := newRecord;
newRecord^.nextRefNo := NIL; lastRefNo := newRecord
END
END
END;
BEGIN
IF firstName = NIL THEN
BEGIN
firstName := newRecord; lastName := newRecord;
firstRefNo := newRecord; lastRefNo := newRecord;
WITH newRecord^ DO
BEGIN
nextName := NIL; prevName := NIL;
nextRefNo := NIL; prevRefNo := NIL
END
END
ELSE BEGIN FindNamePointers; FindRefNoPointers END
END;
PROCEDURE CreateAddressPointers;
(* -------- ----- ------ ----- ----- ---------- *)
(* Rutina creaza date simulate pentru fiecare articol *)
(* dinamic nou; foloseste rutinele unit-ului RandUnit. *)
(* -------- ----- ------ ----- ----- ---------- *)
BEGIN
WriteLn (' Creaza si sorteaza ', recsToCreate, ' articole.');
REPEAT
NEW (newRecord); INC (numRecords); WriteLn ('Articolul : ',numRecords:3);
WITH newRecord^ DO
BEGIN
name := RandStr(10); refNo := RandInt(1, 255);
headOffice := RandBoolean; usa := RandBoolean;
phone := RandStr(10); street := RandStr(30); city := RandStr(20);
IF usa THEN
BEGIN state := RandStr(2); zip := RandStr(5) END
ELSE
BEGIN otherLoc := RandStr(15); country := RandStr(15) END
END;
SetPointers
UNTIL (numRecords = recsToCreate)
END;
PROCEDURE PrintList;
(* -------- ----- ------ ----- ----- ------------ *)
(* Rutina creaza patru liste sortate si le inregistreza *)
(* in fisierul RANDTEST.TXT. Listele contin doua coloane, *)
(* sirurile numelor si numerele de referinta simulate. *)
(* -------- ----- ------ ----- ----- ------------ *)
CONST
textFileName= 'RANDTEST.TXT';
TYPE
sortTypes= (nameAtoZ, nameZtoA, refNoAscend, refNoDescend);
VAR
nextRecord: addressPointer;
wichSort: sortTypes;
textFile: TEXT;
BEGIN
ASSIGN (textFile, textFileName); REWRITE (textFile);
WriteLn; WriteLn; WriteLn (' Se creaza fisierul ', textFileName, '.');
FOR wichSort := nameAtoZ TO refNoDescend DO
BEGIN
CASE wichSort OF
nameAtoZ: BEGIN
nextRecord := firstName;
WriteLn(textFile, 'Sortare dupa nume, A la Z :')
END;
nameZtoA: BEGIN
nextRecord := lastName;
WriteLn(textFile, 'Sortare dupa nume, Z la A :')
END;
refNoAscend: BEGIN
nextRecord := firstRefNo;
WriteLn(textFile, 'Sortare dupa nr.ref., ascendent:')
END;
refNoDescend: BEGIN
nextRecord := lastRefNo;
WriteLn(textFile, 'Sortare dupa nr.ref., descendent:')
END
END;
WriteLn (textFile);
WHILE nextRecord <> NIL DO
WITH nextRecord^ DO
BEGIN
WriteLn (textFile, name, ' ', refNo);
CASE wichSort OF
nameAtoZ: nextRecord := nextName;
nameZtoA: nextRecord := prevName;
refNoAscend: nextRecord := nextRefNo;
refNoDescend: nextRecord := prevRefNo
END
END; WriteLn(textFile); WriteLn(textFile);
END;
CLOSE (textFile)
END;
BEGIN
RANDOMIZE;
ClrScr;
CreateAddressPointers;
PrintList; ReadLn
END.
AddrCom
(* >>> AddrCom <<< -------- ----- ------ ------ *)
(* Nume fisier : ADDRCOM.PAS *)
(* AddrCom este o versiune in stil comanda a programului *)
(* PtrAddr. Programul tipareste lista adreselor sau lista *)
(* telefoanelor consultind fisierul ADDRLIST.TXT. *)
(* -------- ----- ------ ----- ----- ------------ *)
PROGRAM AddrCom;
USES CRT, PRINTER, InUnit, StrUnit;
CONST
addressFileName= 'ADDRLIST.TXT';
numRecords : INTEGER = 0;
TYPE
addressPointer= ^addressRecord;
addressRecord= RECORD
nextName, prevName, nextRefNo, prevRefNo: addressPointer;
name: STRING[30];
phone: STRING[20];
refNo: BYTE;
headOffice: BOOLEAN;
street: STRING[30];
city: STRING[20];
CASE usa: BOOLEAN OF
TRUE : (state: STRING[2];
zip: STRING[6]);
FALSE: (otherLoc, country: STRING[15])
END;
sortOptions= (nameAtoZ, nameZtoA, refNoAscend, refNoDescend);
argString= STRING[3];
CONST
firstName: addressPointer= NIL;
VAR
firstRefNo, lastName, lastRefNo, newRecord: addressPointer;
addressFile: TEXT;
args: argString;
PROCEDURE SetPointers;
(* -------- ----- ------ ----- ----- -------- *)
(* Procedura stabileste pointerii listei inlantuite. *)
(* Aceasta seteaza cele patru cimpuri pointer ale unui *)
(* articol in fiecare nou articol de adresa citit din *)
(* fisierul ADDRLIST.TXT. *)
(* -------- ----- ------ ----- ----- -------- *)
VAR
current, previous: addressPointer;
locFound: BOOLEAN;
PROCEDURE FindNamePointers;
(* -------- ----- ------ ----- ----- ------- *)
(* Procedura stabileste pointerii pentru sortarea *)
(* alfabetica si invers alfabetica, dupa cimpul name. *)
(* -------- ----- ------ ----- ----- ------- *)
BEGIN
IF newRecord^.name < firstName^.name THEN
BEGIN
newRecord^.nextName := firstName; newRecord^.prevName := NIL;
firstName^.prevName := newRecord; firstName := newRecord
END
ELSE
BEGIN
locFound := FALSE; previous := firstName; current := firstName;
WHILE (NOT locFound) AND (current^.nextName <> NIL) DO
BEGIN
current := current^.nextName;
IF newRecord^.name < current^.name THEN
BEGIN
locFound := TRUE; previous^.nextName := newRecord;
newRecord^.prevName := previous;
newRecord^.nextName := current;
current^.prevName := newRecord
END
ELSE previous := current
END;
IF (NOT locFound) THEN
BEGIN
newRecord^.prevName := current; current^.nextName := newRecord;
newRecord^.nextName := NIL; lastName := newRecord
END
END
END;
PROCEDURE FindRefNoPointers;
(* -------- ----- ------ ----- ----- -------- *)
(* Procedura stabileste pointerii pentru doua tipuri *)
(* de sortare numerica : crescatoare si descrescatoare *)
(* dupa valorile cimpului refNo. *)
(* -------- ----- ------ ----- ----- -------- *)
BEGIN
IF newRecord^.refNo < firstRefNo^. refNo THEN
BEGIN
newRecord^.nextRefNo := firstRefNo; newRecord^.prevRefNo := NIL;
firstRefNo^.prevRefNo := newRecord; firstRefNo := newRecord
END
ELSE
BEGIN
locFound := FALSE; previous := firstRefNo; current := firstRefNo;
WHILE (NOT locFound) AND (current^.nextRefNo <> NIL) DO
BEGIN
current := current^.nextRefNo;
IF newRecord^.refNo < current^.refNo THEN
BEGIN
locFound := TRUE; previous^.nextRefNo := newRecord;
newRecord^.prevRefNo := previous;
newRecord^.nextRefNo := current;
current^.prevRefNo := newRecord
END
ELSE previous := current
END;
IF (NOT locFound) THEN
BEGIN
newRecord^.prevRefNo := current; current^.nextRefNo := newRecord;
newRecord^.nextRefNo := NIL; lastRefNo := newRecord
END
END
END;
BEGIN
IF firstName = NIL THEN
BEGIN
firstName := newRecord; lastName := newRecord;
firstRefNo := newRecord; lastRefNo := newRecord;
WITH newRecord^ DO
BEGIN
nextName := NIL; prevName := NIL;
nextRefNo := NIL; prevRefNo := NIL
END
END
ELSE BEGIN FindNamePointers; FindRefNoPointers END
END;
PROCEDURE ReadAddresses;
(* -------- ----- ------ ----- ----- -------------- *)
(* Procedura deschide fisierul ADDRLIST.TXT si creaza o *)
(* noua variabila dinamica pentru fiecare adresa din fisier. *)
(* -------- ----- ------ ----- ----- -------------- *)
VAR
officeCode, usaCode: BYTE;
BEGIN
RESET (addressFile);
IF IORESULT = 0 THEN
BEGIN
WHILE NOT EOF(addressFile) DO
BEGIN
NEW(newRecord); INC(numRecords);
WITH newRecord^ DO
BEGIN
ReadLn(addressFile, name);
ReadLn(addressFile, officeCode, usaCode, refNo);
headOffice := BOOLEAN (officeCode);
usa := BOOLEAN(usaCode); ReadLn(addressFile, phone);
ReadLn(addressFile, street); ReadLn(addressFile, city);
IF usa THEN
BEGIN
ReadLn(addressFile, state); ReadLn(addressFile, zip)
END
ELSE
BEGIN
ReadLn(addressFile, otherLoc); ReadLn(addressFile, country)
END
END;
SetPointers
END; CLOSE (addressFile);
END
END;
PROCEDURE PrintList (addressDirectory: BOOLEAN; sortSelection: sortOptions);
(* -------- ----- ------ ----- ----- --------- *)
(* Procedura tipareste fie lista adreselor fie lista *)
(* telefoanelor; argumentul addressDirectory specifica *)
(* ce lista se tipareste, iar sortSelection specifica *)
(* tipul ordonarii. *)
(* -------- ----- ------ ----- ----- --------- *)
CONST
formFeed= #12;
VAR
firstAddress: addressPointer;
FUNCTION Continue: BOOLEAN;
(* -------- ----- ------ ----- ----- --------- *)
(* Functia asteapta indicatia utilizatorului pentru a *)
(* trece la actiune: bara spatiu pentru tiparire sau *)
(* Escape pentru revenire in program. *)
(* -------- ----- ------ ----- ----- --------- *)
CONST
spaceBar= ' ';
escKey= #27;
prompt= '<Spatiu> tiparire; <Escape> revenire in DOS.';
VAR
inKey: CHAR;
BEGIN
inKey := InChar(prompt, [spaceBar, escKey]);
Continue := (inKey = spaceBar);
WriteLn
END;
PROCEDURE PrintAddresses (address: addressPointer; wichSort: sortOptions);
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura tipareste lista adreselor. Argumentul *)
(* address contine pointerul articolului ce se tipareste *)
(* primul. Parametrul wichSort indica cheia si directia *)
(* operatiei de sortare. *)
(* -------- ----- ------ ----- ----- ---------- *)
VAR
i: BYTE;
BEGIN
WriteLn(LST, 'Lista adreselor clientilor');
WriteLn(LST, '----- --------- ----------'); WriteLn(LST);
WHILE address <> NIL DO
BEGIN
WITH address^ DO
BEGIN
Write(LST, LeftAlign(name, 35), refNo:3);
IF headOffice THEN WriteLn(LST, 'H')
ELSE WriteLn(LST, 'B');
WriteLn(LST, street); Write(LST, city, ', ');
IF usa THEN
WriteLn(LST, UpperCase(state), ' ', zip)
ELSE
WriteLn(LST, otherLoc, ' ', UpperCase(country));
WriteLn(LST, phone); WriteLn(LST)
END;
CASE wichSort OF
nameAtoZ : address := address^.nextName;
nameZtoA : address := address^.prevName;
refNoAscend : address := address^.nextRefNo;
refNoDescend : address := address^.prevRefNo
END
END
END;
PROCEDURE PrintPhones (address: addressPointer; wichSort: SortOptions);
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura tipareste lista telefoanelor. Argumentul *)
(* address contine pointerul articolului ce se tipareste *)
(* primul. Parametrul wichSort indica cheia si directia *)
(* operatiei de sortare. *)
(* -------- ----- ------ ----- ----- ---------- *)
VAR
i: BYTE;
BEGIN
WriteLn(LST, 'Lista telefoanelor clientilor');
WriteLn(LST, '----- ------------ ----------'); WriteLn (LST);
WriteLn(LST, 'Client', Spaces(27), 'Nr.referinta', Spaces(7), 'Telefon');
WriteLn(LST);
WHILE address <> NIL DO
BEGIN
WITH address^ DO
BEGIN
Write(LST, LeftAlign(name, 35));
Write(LST, refNo:3, Spaces(10)); WriteLn(LST, phone)
END;
CASE wichSort OF
nameAtoZ : address := address^.nextName;
nameZtoA : address := address^.prevName;
refNoAscend : address := address^.nextRefNo;
refNoDescend : address := address^.prevRefNo
END
END
END;
BEGIN
WriteLn;
IF addressDirectory THEN
BEGIN WriteLn('Tiparirea adreselor'); WriteLn('--------- ---------') END
ELSE
BEGIN
WriteLn('Tiparirea telefoanelor'); WriteLn('--------- ------------')
END;
CASE sortSelection OF
nameAtoZ: firstAddress := firstName;
nameZtoA: firstAddress := lastName;
refNoAscend: firstAddress := firstRefNo;
refNoDescend: firstAddress := lastRefNo
END;
IF Continue THEN
BEGIN
IF AddressDirectory THEN
PrintAddresses(firstAddress, sortSelection)
ELSE
PrintPhones(firstAddress, sortSelection);
WriteLn(LST, formFeed)
END
END;
PROCEDURE Explain;
(* -------- ----- ------ ----- ----- --------- ----- ------- *)
(* Procedura afiseaza instructiunile de utilizarea a programului. *)
(* -------- ----- ------ ----- ----- --------- ----- ------- *)
CONST indent= 13;
BEGIN
WriteLn; WriteLn; WriteLn; WriteLn(StringOfChars ('-', 64));
Write(' Programul ADDRCOM tipareste lista ');
WriteLn('adreselor sau telefoanelor');
WriteLn('clientilor din fisierul ADDRLIST.TXT.'); WriteLn;
Write(' In linia de comanda a programului ');
WriteLn('trebuie sa se includa trei');
WriteLn('argumente separate prin spatii :'); WriteLn;
WriteLn(' Primul argument :');
Write(Spaces(indent), '"a" sau "address" : ');
WriteLn('lista adreselor.');
Write(Spaces(indent), '"p" sau "phone" : ');
WriteLn('lista telefoanelor.'); WriteLn;
WriteLn(' Al doilea argument :');
Write(Spaces(indent), '"n" sau "names" : ');
WriteLn('sortarea dupa nume.');
Write(Spaces(indent), '"r" sau "ref" : ');
WriteLn('sortarea dupa nr. referinta.'); WriteLn;
WriteLn(' Al treilea argument :');
Write(Spaces (indent), '"a" sau "ascending" : ');
WriteLn('sortare crescatoare');
Write(Spaces(indent), '"d" sau "descending" : ');
WriteLn('sortare descrescatoare.'); WriteLn;
WriteLn(StringOfChars ('-', 64))
END;
FUNCTION CheckArguments(VAR userArgs: argString): BOOLEAN;
(* -------- ----- ------ ----- ----- ---------- *)
(* Functia citeste cele trei argumente furnizate de *)
(* catre utilizator si determina daca ele sint corecte. *)
(* Daca argumentele sint corecte functia returneaza TRUE,*)
(* iar caracterele argumentelor se vor gasi in userArgs. *)
(* -------- ----- ------ ----- ----- ---------- *)
TYPE
testSet= SET OF CHAR;
CONST
setArray: ARRAY[1..3] OF testSet1/2 (['A', 'P'], ['N', 'R'], ['A', 'D']);
VAR
ok: BOOLEAN;
i: BYTE;
temp: CHAR;
BEGIN
ok := TRUE; userArgs := '';
IF PARAMCOUNT = 3 THEN
FOR i := 1 TO 3 DO
BEGIN
temp := UPCASE(FirstChar (PARAMSTR(i)));
ok := ok AND (temp IN setArray[i]);
IF ok THEN userArgs := userArgs + temp
END
ELSE ok := FALSE;
CheckArguments := ok
END;
PROCEDURE DoCommand (arguments: argString);
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura prelucreaza cerintele utilizatorului prin *)
(* apelarea rutinelor de tiparire, transmitind acestora *)
(* instructiunile corecte pentru sortare. *)
(* -------- ----- ------ ----- ----- ---------- *)
VAR
printAddresses: BOOLEAN;
wichSort: sortOptions;
BEGIN
IF (Left(Arguments, 1) = 'A') THEN printAddresses := TRUE
ELSE printAddresses := FALSE;
IF (COPY(arguments, 2, 1) = 'N') THEN
BEGIN
IF (Right(arguments, 1) = 'A') THEN wichSort := nameAtoZ
ELSE wichSort := nameZtoA
END
ELSE
BEGIN
IF (Right(arguments, 1) = 'A') THEN wichSort := refNoAscend
ELSE wichSort := refNoDescend
END;
PrintList(printAddresses, wichSort)
END;
BEGIN
ClrScr;
IF CheckArguments (args) THEN
BEGIN
ASSIGN(addressFile, addressFileName);
ReadAddresses;
DoCommand(args)
END
ELSE
explain;
END.
CliChart
(* >>> CliChart <<< -------- ----- ------ - *)
(* Nume fisier : CLICHART.PAS *)
(* Programul pregateste o statistica care reprezinta *)
(* grafic orele inregistrate in fisierele .HRS gasite *)
(* in directorul curent. Statistica este memorata in *)
(* fisierul text HRSCHART.TXT. *)
(* -------- ----- ------ ----- ----- -------- *)
PROGRAM CliChart;
USES CRT, DOS, StrUnit;
CONST
maxClients = 100;
TYPE
clientRecord = RECORD
name: STRING;
totalHours: REAL
END;
VAR
clientFiles: ARRAY [1..maxClients] OF clientRecord;
listLength, i: BYTE;
chartFactor: REAL;
PROCEDURE GetFiles (VAR numberOfFiles: BYTE; VAR scaleFactor: REAL);
(* -------- ----- ------ ----- ----- ----------- *)
(* Procedura formeaza o lista cu toate fisierele .HRS *)
(* din directorul curent. Numele fisierelor si totalul *)
(* orelor din fiecare fisier sint memorate in articolele *)
(* clientFiles. De asemenea, procedura determina factorul *)
(* de scala ce va fi utilizat de program pentru grafica. *)
(* -------- ----- ------ ----- ----- ----------- *)
CONST
fileName = 'HRSDIR.TXT';
chartWidth = 40;
largestTotal: REAL = 0.0;
VAR
dirFile: TEXT;
recNum, extensionPos, firstSpace: BYTE;
dirLine: STRING[40];
clientName: STRING;
FUNCTION MaxReal (value1, value2: REAL): REAL;
(* -------- ----- ------ ----- ----- -------- *)
(* Functia determina care dintre cele doua argumente *)
(* receptionate este cel mai mare. *)
(* -------- ----- ------ ----- ----- -------- *)
VAR
temp: REAL;
BEGIN
IF value1 > value2 THEN temp := value1 ELSE temp := value2;
MaxReal := temp
END;
FUNCTION TotalAccount (targetFileName: STRING): REAL;
(* -------- ----- ------ ----- ----- ------ *)
(* Functia deschide un fisier .HRS, citeste toate *)
(* intrarile lui si determina numarul total de ore *)
(* inregistrate in fisier. *)
(* -------- ----- ------ ----- ----- ------ *)
VAR
total, hours: REAL;
targetFile: TEXT;
chronInfoString: STRING[29];
BEGIN
total := 0.0; ASSIGN(targetFile, targetFileName); RESET(targetFile);
WHILE NOT EOF (targetFile) DO
BEGIN
READLN(targetFile, chronInfoString, hours); total := total + hours
END;
CLOSE(targetFile);
TotalAccount := total
END;
BEGIN
EXEC('\COMMAND.COM', '/C DIR *.HRS > ' + fileName);
ASSIGN(dirFile, fileName); RESET(dirFile); recNum := 0;
WHILE NOT EOF(dirFile) DO
BEGIN
READLN(dirFile, dirLine); extensionPos := POS('.HRS', dirLine);
IF extensionPos <> 0 THEN
BEGIN
INC(recNum); firstSpace := POS(' ', dirLine);
clientName := LeftAlign(dirLine, firstSpace - 1);
WITH clientFiles[recNum] DO
BEGIN
name := clientName;
totalHours := TotalAccount (clientName + '.HRS');
largestTotal := MaxReal(largestTotal, totalHours)
END
END
END;
CLOSE(dirFile);
scaleFactor := chartWidth / largestTotal; numberOfFiles := recNum
END;
PROCEDURE SortClientFiles (sortLength: BYTE);
(* -------- ----- ------ ----- ----- ------------ *)
(* Procedura foloseste algoritmul Shell pentru sortarea *)
(* tabloului de articole, clientFiles, dupa cimpul nume. *)
(* -------- ----- ------ ----- ----- ------------ *)
VAR
listJump, i, j: BYTE;
sortComplete: BOOLEAN;
saveRecord: clientRecord;
BEGIN
listJump := 1;
WHILE listJump <= sortLength DO listJump := listJump + 2;
WHILE listJump > 1 DO
BEGIN
listJump := (listJump - 1) DIV 2;
REPEAT
sortComplete := TRUE;
FOR j := 1 TO sortLength - listJump DO
BEGIN
i := j + listJump;
IF clientFiles[j].name > clientFiles[i].name THEN
BEGIN
saveRecord := clientFiles[j];
clientFiles[j] := clientFiles[i];
clientFiles[i] := saveRecord; sortComplete := FALSE
END
END
UNTIL sortComplete
END
END;
PROCEDURE CreateChart (printLength: BYTE; scaleFactor: REAL);
(* -------- ----- ------ ----- ----- ------------ *)
(* Procedura creaza un fisier grafic numit HRSCHART.TXT. *)
(* Graficul contine o linie de text pentru fiecare articol *)
(* din tabloul clientFiles. *)
(* -------- ----- ------ ----- ----- ------------ *)
CONST
chartFileName = 'HRSCHART.HRS';
chartChar = '*';
VAR
i, j: BYTE;
inChar: CHAR;
chartFile: TEXT;
lengthOfChart: BYTE;
BEGIN
ASSIGN(chartFile, chartFileName); REWRITE(chartFile);
FOR i := 1 TO printLength DO
WITH clientFiles[i] DO
BEGIN
WRITE(chartFile, Left(InitialCap (name), 11));
WRITE(chartFile, totalHours:3:0);
lengthOfChart := ROUND(totalHours * scaleFactor);
WRITE(chartFile, ' ');
WRITELN(chartFile, StringOfChars(chartChar, lengthOfChart))
END;
CLOSE(chartFile)
END;
BEGIN
CLRSCR; WRITELN('Crearea statisticii fisierelor clientilor');
WRITELN('------- ----------- ---------- ----------'); WRITELN;
GetFiles(listLength, chartFactor);
SortClientFiles (listLength);
WRITELN('Crearea fisierului HRSCHART.TXT pe disc');
WRITELN(' Acesta este un fisier de tip ;text;');
WRITELN(' care poate fi citit cu un editor.'); WRITELN;
CreateChart(listLength, chartFactor)
END.
RandFile
(* >>> RandFile <<< -------- ----- ------ ---- *)
(* Nume fisier : RANDFILE.PAS *)
(* Programul RandFile ilustreaza folosirea rutinelor *)
(* standard SEEK, FILEPOS, FILESIZE, READ si WRITE pentru *)
(* fisiere cu tip (fisiere in acces direct). Programul *)
(* creaza fisierul reprezentat prin variabila fisier *)
(* randFileVar, inregistrind o succesiune de articole, *)
(* dupa care se executa cautarea aleatore si afisarea pe *)
(* ecran a articolului cerut. *)
(* -------- ----- ------ ----- ----- ----------- *)
PROGRAM RandFile;
CONST
randFileName = 'RANDFILE.DAT';
maxRecords = 26;
TYPE
fileRecordType = RECORD
ordChar: CHAR;
ordByte: BYTE
END;
VAR
randFileVar: FILE OF fileRecordType;
fileRecord: fileRecordType;
PROCEDURE FillFile;
(* -------- ----- ------ ----- ----- ----------- *)
(* Procedura FillFile memoreaza maxRecords articole in *)
(* fisierul cu tip reprezentat prin randFileVar. *)
(* -------- ----- ------ ----- ----- ----------- *)
CONST
letter: CHAR = 'A';
VAR
i: BYTE;
BEGIN
ASSIGN(randFileVar, randFileName); REWRITE(randFileVar);
FOR i := 1 TO maxRecords DO
BEGIN
WITH fileRecord DO BEGIN ordChar := letter; ordByte := i END;
WRITE(randFileVar, fileRecord);
letter := SUCC (letter)
END;
CLOSE(randFileVar)
END;
PROCEDURE RandRead;
(* -------- ----- ------ ----- ----- ----------- *)
(* Rutina citeste in acces direct articolele selectate *)
(* si afiseaza valorile cimpurilor. *)
(* -------- ----- ------ ----- ----- ----------- *)
CONST
doneRecord: fileRecordType = (ordChar: ' '; ordByte: 0);
maxRead = 5;
VAR
i, targetRecordNum: BYTE;
BEGIN
RESET(randFileVar); i := 0;
REPEAT
targetRecordNum := RANDOM(FILESIZE (randFileVar) - 1);
SEEK(randFileVar, targetRecordNum);
READ(randFileVar, fileRecord);
SEEK(randFileVar, targetRecordNum);
WITH fileRecord DO
IF ordChar <> ' ' THEN
BEGIN
WRITELN(' Articolul #', FILEPOS (randFileVar));
WRITELN(' cimpul Char: ', ordChar);
WRITELN(' cimpul Byte: ', ordByte);
WRITE(randFileVar, doneRecord); INC(i); WRITELN
END;
UNTIL i = maxRead;
CLOSE(randFileVar)
END;
BEGIN
RANDOMIZE;
FillFile;
RandRead;
READLN
END.
CliProf
(* >>> CliProf <<< -------- ----- ------ ---- *)
(* Nume Fisier : CLIPROF.PAS *)
(* Programul intretine o baza de date cu informatii *)
(* despre clienti. Baza de date este inregistrata in *)
(* fisierul PROFILE.DAT. Fisierul PROFILE.NDX serveste *)
(* pentru indexarea bazei de date. *)
(* Programul este controlat print-un meniu, permitind *)
(* adaugarea unui nou articol, afisarea unui articol sau *)
(* modificarea unui articol existent. *)
(* -------- ----- ------ ----- ----- ---------- *)
PROGRAM CliProf;
USES CRT, ChrnUnit, InUnit, StrUnit;
TYPE
nameString = STRING[30];
profileRecord = RECORD
name: nameString;
refNo: BYTE;
businessType: STRING[15];
recordDate: STRING[20];
contactPerson: STRING[20];
phoneNumber: STRING[15];
hoursLastYear: REAL
END;
indexRecord = RECORD
clientName: nameString;
recordNumber: INTEGER
END;
activities = (adaugare, listare, modificare, iesire);
activityRange = adaugare..iesire;
activityRecord = RECORD
row, column: BYTE;
menuString: STRING[35]
END;
CONST
maxRecords = 250;
columnPos = 24;
optionDisplay= ' A L M I ';
profileDone = 'PROFILE.DAT';
indexFileName= 'PROFILE.NDX';
activity: ARRAY[activityRange] OF activityRecord =
((row: 10; column: columnPos;
menuString: 'Adaugarea datelor unui nou client.'),
(row: 11; column: columnPos;
menuString: 'Listarea datelor unui client.'),
(row: 12; column: columnPos;
menuString: 'Modificarea datelor unui client.'),
(row: 13; column: columnPos;
menuString: 'Iesire din program'));
nullChar = #0;
enter = #13;
bell = #7;
upArrow = #72;
leftArrow = #75;
rightArrow = #77;
downArrow = #80;
menuChars: SET OF CHAR = ['A', 'L', 'M', 'I', nullChar, enter];
cursorScanCode: SET OF CHAR = [upArrow, downArrow, rightArrow, leftArrow];
VAR
profile : profileRecord;
index : ARRAY[1..maxRecords] OF indexRecord;
profileFile : FILE OF profileRecord;
indexFile : TEXT;
fileLength: INTEGER;
done, ready: BOOLEAN;
currentSelection: activities;
PROCEDURE ReverseVideo (status: BOOLEAN );
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura comuta starea afisarii ecranului in video *)
(* invers sau video normal in functie de valoarea de tip *)
(* boolean receptionata. *)
(* -------- ----- ------ ----- ----- ---------- *)
BEGIN
IF status THEN BEGIN TEXTCOLOR(Blue); TEXTBACKGROUND(LightGray) END
ELSE BEGIN TEXTCOLOR(White); TEXTBACKGROUND(Black) END
END;
PROCEDURE HighLightSelection;
(* -------- ----- ------ ----- ----- ----------- *)
(* Procedura supralumineaza selectia curenta. Selectia *)
(* si toate literele mari sint afisate in video-invers. *)
(* -------- ----- ------ ----- ----- ----------- *)
BEGIN
ReverseVideo (TRUE);
WITH activity[currentSelection] DO
BEGIN GOTOXY(column, row); WRITELN(UpperCase(menuString)) END;
ReverseVideo (FALSE); GOTOXY (60,17)
END;
PROCEDURE InitializeMenu;
(* -------- ----- ------ ----- ----- ------- *)
(* Procedura afiseaza meniul pe ecran si stabileste *)
(* currentSelection pe prima optiune a meniului. *)
(* -------- ----- ------ ----- ----- ------- *)
VAR
option: activities;
BEGIN
CLRSCR; ReverseVideo(TRUE);
GOTOXY(columnPos - 7, 6); WRITELN('*** Dispecerul bazei de date ***');
ReverseVideo(FALSE);
GOTOXY(columnPos - 12, 16); WRITE('(Folositi ');
ReverseVideo(TRUE); WRITE(#24, ' ', #25, ' ', #26, ' ', #27);
ReverseVideo(FALSE); WRITE(' sau '); ReverseVideo(TRUE);
WRITE(optionDisplay); ReverseVideo(FALSE);
WRITE(' pentru a marca o optiune,'); GOTOXY(columnPos - 10, 17);
WRITE('apoi apasati <Enter> pentru a termina selectia.)');
FOR option := adaugare TO iesire DO
WITH activity[option] DO
BEGIN GOTOXY(column, row); WRITELN(menuString) END;
GOTOXY(columnPos + 5, 2);
WRITE('In baza de date exista ', fileLength:3, ' articol');
IF fileLength = 1 THEN WRITELN ('.') ELSE WRITELN ('e.');
currentSelection := adaugare; HighLightSelection
END;
FUNCTION SearchIndex(targetName: nameString): INTEGER;
(* -------- ----- ------ ----- ----- ----------- *)
(* Functia utilizeaza un algoritm de cautare binara a *)
(* numelui clientului in tabela index. Daca numele este *)
(* in tabela, functia furnizeaza numarul articolului *)
(* corespunzator in baza de date. Altfeì functia da -1. *)
(* -------- ----- ------ ----- ----- ----------- *)
VAR
found, notThere: BOOLEAN;
first, last, midPoint, targetRecord: INTEGER;
BEGIN
found:= FALSE; notThere:= FALSE; first:= 1;
last:= fileLength; targetRecord:= -1;
REPEAT
midPoint := (first + last) DIV 2;
WITH index[midPoint] DO
BEGIN
IF clientName = targetName THEN
BEGIN found := TRUE; targetRecord := recordNumber END
ELSE
BEGIN
IF clientName < targetName THEN first := midPoint + 1
ELSE last := midPoint - 1
END
END; notThere := (last < first)
UNTIL (found OR notThere);
SearchIndex := targetRecord
END;
PROCEDURE SortIndex(sortLength: BYTE);
(* -------- ----- ------ ----- ----- -------------- *)
(* Procedura foloseste algoritmul de sortare Shell pentru *)
(* a ordona tabloul index dupa cimpul clientName. *)
(* -------- ----- ------ ----- ----- -------------- *)
VAR
listJump, i, j: BYTE;
sortComplete: BOOLEAN;
saveRecord: indexRecord;
BEGIN
listJump := 1;
WHILE listJump <= sortLength DÏ listJump := listJump + 2;
WHILE listJump > 1 DO
BEGIN
listJump := (listJump -1) DIV 2;
REPEAT
sortComplete := TRUE;
FOR j := 1 TO sortLength - listJump DO
BEGIN
i := j + listJump;
IF index[j].clientName > index[i].clientName THEN
BEGIN
saveRecord := index[j]; index[j] := index[i];
index[i] := saveRecord; sortComplete := FALSE
END
END
UNTIL sortComplete
END
END;
PROCEDURE AddClient;
(* -------- ----- ------ ----- ----- ----------- *)
(* Procedura dirijeaza dialogul pentru introducerea *)
(* datelor unui nou client. Daca utilizatorul confirma, *)
(* atunci articolul se adauga la sfirsitul bazei de date. *)
(* -------- ----- ------ ----- ----- ----------- *)
VAR
searchName: nameString;
okRecord: BOOLEAN;
answer: CHAR;
BEGIN
WRITELN ('Adaugarea datelor pentru un nou client');
WRITELN ('--------- ------- ------ -- --- ------'); WRITELN;
WITH profile DO
BEGIN
WRITE('Numele clientului : '); READLN (name);
searchName := LeftAlign (UpperCase (name), 30);
IF searchIndex (searchName) >= 0 THEN
BEGIN WRITELN; WRITELN ('Clientul deja este in baza de date'(c) END
ELSE
BEGIN
refNo := InByte('Numarul de referinta : ');
WRITE('Tipul afacerii : '); READLN(businessType);
WRITE('Persoana contactata : '); READLN(contactPerson);
WRITE('Numarul de telefon : '); READLN(phoneNumber);
hoursLastYear :=
InReal('Totalul orelor contabilizate in ultimul an : ');
recordDate := DateString; WRITELN; WRITELN;
answer := InChar('Salvati acest articol ? ', ['D', 'N']);
okRecord := (answer = 'D'); WRITELN (answer);
IF okRecord THEN
BEGIN
SEEK(profileFile, fileLength);
INC(fileLength);
WRITELN('Se salveaza articolul #',fileLength:3);
WRITE(profileFile, profile);
WITH index[fileLength] DO
BEGIN
clientName := searchName;
recordNumber := fileLength -1
END;
SortIndex(fileLength)
END
ELSE
WRITELN('S-a abandonat introducerea acestui articol ...')
END
END
END;
PROCEDURE GetClient (VAR wichRecord: INTEGER);
(* -------- ----- ------ ----- ----- ------------ *)
(* Procedura este apelata de rutinele DisplayClient si *)
(* ReviseClient. Ea solicita un nume, cauta numele in *)
(* indexul bazei de date, citeste articolul respectiv din *)
(* baza de date si afiseaza articolul pe ecran. GetClient *)
(* furnizeaza numarul articolului citit (wichRecord). *)
(* -------- ----- ------ ----- ----- ------------ *)
VAR
inName: nameString;
BEGIN
WRITE('Numele clientului : '); READLN(inName);
inName := LeftAlign(UpperCase(inName), 30);
wichRecord := SearchIndex(inName);
IF wichRecord >= 0 THEN
BEGIN
SEEK (profileFile, wichRecord);
READ (profileFile, profile);
CLRSCR; WRITELN; WRITELN;
WITH profile DO
BEGIN
WRITELN(name);
WRITELN(StringOfChars('-', LENGTH(name)));
WRITELN('Numarul de referinta: ', refNo);
WRITELN('Tipul afacerii: ', businessType);
WRITELN('Data articolului: ', recordDate);
WRITELN('Persoana contactata: ', contactPerson);
WRITELN('Numarul de telefon: ', phoneNumber);
WRITELN('Ore lucrate in ultimul an: ', hoursLastYear:7:2)
END
END
ELSE
BEGIN
WRITELN; WRITELN; WRITELN('Articolul nu este in baza de date.'); WRITELN
END
END;
PROCEDURE DisplayClient;
(* ---- Afisarea unue articoì pe ecran ---- *)
VAR
location: INTEGER;
BEGIN
WRITELN('Afisarea informatiilor despre un client.');
WRITELN('-------- ------------- ------ -- -------'); WRITELN;
GetClient (location)
END;
PROCEDURE ReviseClient;
(* -------- ----- ------ ----- ----- -------------- *)
(* Procedura dirijeaza utilizatorul in modificarea datelor *)
(* unui client. Daca utilizatorul confirma, rutina rescrie *)
(* articolul modificat in baza de date, PROFILE.DAT. *)
(* -------- ----- ------ ----- ----- -------------- *)
TYPE
changeType = (contact, phone, hours);
changeRange = contact..hours;
promptString = RECORD
question, inPrompt: STRING
END;
CONST
prompts : ARRAY[changeRange] OF promptString =
((question: 'Schimbati persoana contactata ? ';
inPrompt:'Noua persoana contactata : '),
(question: 'Schimbati numarul de telefon ? ';
inPrompt: 'Noul numar de telefon : '),
(question: 'Schimbati orele contabilizate in ultimul an ? ';
inPrompt: 'Noua valoare a orelor contabilizate : '));
VAR
currentChange: changeType;
location: INTEGER;
changed: BOOLEAN;
BEGIN
WRITELN('Modificarea datelor unui client.');
WRITELN('----------- ------- ---- -------'); WRITELN;
GetClient(location); changed := FALSE;
IF location >= 0 THEN
BEGIN
WRITELN;
FOR currentChange := contact TO hours DO
BEGIN
WITH prompts[currentChange] DO
IF InChar(question, ['D', 'N']) = 'D' THEN
BEGIN
WRITELN('Da');
WRITE(inPrompt);
WITH profile DO
CASE currentChange OF
contact: READLN(contactPerson);
phone: READLN(phoneNumber);
hours: hoursLastYear := InReal('')
END;
changed := TRUE
END
ELSE WRITELN('Nu')
END;
IF changed THEN
BEGIN
WRITELN;
IF InChar('Salvati articolul modificat ? ', ['D', 'N']) = 'D' THEN
BEGIN
WRITELN('Da'); WRITELN('Salvarea articolului modificat ...');
profile.recordDate := DateString;
SEEK(profileFile, location); WRITE(profileFile, profile)
END
ELSE
BEGIN
WRITELN('Nu'); WRITELN('Abandonarea modificarilor ...')
END
END
END
END;
PROCEDURE GetSelection (VAR quitSignal: BOOLEAN);
(* -------- ----- ------ ----- ----- ------------ *)
(* Procedura accepta o selectia de meniu de la tastatura *)
(* si apeleaza rutinele corespunzatoare. *)
(* -------- ----- ------ ----- ----- ------------ *)
CONST
options:ARRAY[1..4] OF activities=(adaugare, listare, modificare, iesire);
firstChars = 'ALMI';
VAR
inChar: CHAR;
PROCEDURE Continue;
(* -------- ----- ------ ----- ----- ------------ *)
(* Procedura indica utilizatorului sa apese bara spatiu *)
(* pentru a reveni in meniu la terminarea unei activitati. *)
(* -------- ----- ------ ----- ----- ------------ *)
VAR
inSpace: CHAR;
BEGIN
GOTOXY(10, 23); WRITE('Apasati bara spatiu pentru revenire in meniu ...');
REPEAT inSpace := READKEY UNTIL inSpace = ' '
END;
PROCEDURE RemoveHighLight;
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura restaureaza optiunea de meniu deselectata *)
(* pentru a fi afisata normal. *)
(* -------- ----- ------ ----- ----- ---------- *)
BEGIN
WITH activity[currentSelection] DO
BEGIN GOTOXY(column, row); WRITELN(menuString) END
END;
PROCEDURE SelectionNextActivity;
(* -------- ----- ------ ----- ----- --------- *)
(* Procedura marcheaza luminos urmatoarea optiune din *)
(* meniu, raspunzind tastei sageata sus. *)
(* -------- ----- ------ ----- ----- --------- *)
BEGIN
RemoveHighLight;
IF currentSelection = iesire THEN currentSelection := adaugare
ELSE currentSelection := SUCC(currentSelection);
HighLightSelection
END;
PROCEDURE SelectionPreviousActivity;
(* -------- ----- ------ ----- ----- ------- *)
(* Procedura marcheaza luminos optiunea anterioara, *)
(* raspunzind tastei sageata jos. *)
(* -------- ----- ------ ----- ----- ------- *)
BEGIN
RemoveHighLight;
IF currentSelection = adaugare THEN currentSelection := iesire
ELSE currentSelection := PRED(currentSelection);
HighLightSelection
END;
BEGIN
quitSignal := FALSE;
REPEAT
inChar :=UPCASE(READKEY);
IF NOT (inChar IN menuChars) THEN WRITE(bell)
UNTIL (inChar IN menuChars);
CASE inChar OF
'A', 'L', 'M', 'I':
BEGIN
RemoveHighLight;
currentSelection := options[POS(inChar, firstChars)];
HighLightSelection
END;
nullChar:
BEGIN
inChar := READKEY;
IF inChar IN cursorScanCode THEN
CASE inChar OF
upArrow, leftArrow: SelectionPreviousActivity;
downArrow, rightArrow: SelectionNextActivity
END
ELSE
WRITE (bell)
END;
enter:
BEGIN
IF currentSelection = iesire THEN quitSignal := TRUE
ELSE
BEGIN
CLRSCR;
CASE currentSelection OF
adaugare: BEGIN AddClient; Continue END;
listare:
IF fileLength > 0 THEN BEGIN DisplayClient; Continue END;
modificare:
IF fileLength > 0 THEN BEGIN ReviseClient; Continue END
END;
CLRSCR; InitializeMenu
END
END
END
END;
PROCEDURE OpenFiles (VAR filesOk: BOOLEAN);
(* -------- ----- ------ ----- ----- ------------- *)
(* Procedura deschide fisierul bazei de date si fisierul *)
(* index. Procedura retransmite valoarea booleana filesOk. *)
(* Valoarea rezultatului este fals daca baza de date exista *)
(* dar indexul nu poate fi localizat. In acest caz versiunea*)
(* curenta a programului nu poate continua. *)
(* -------- ----- ------ ----- ----- ------------- *)
VAR
i: INTEGER;
BEGIN
ASSIGN(profileFile, profileDone);
ASSIGN(indexFile, indexFileName); filesOk := TRUE;
{$I-ý RESET (profileFile);
IF IORESULT <> 0 THEN REWRITE(profileFile);
fileLength := FILESIZE(profileFile);
IF fileLength > 0 THEN
BEGIN
RESET(indexFile);
IF IORESULT = 0 THEN
BEGIN
FOR i :=1 TO fileLength DO
WITH index[i] DO READLN(indexFile, clientName, recordNumber);
CLOSE (indexFile)
END
ELSE
BEGIN
filesOk := FALSE;
WRITELN('PROFILE.DAT exista, dar PROFILE.NDX nu exista.');
WRITELN('... Nu pot continua.');
CLOSE(profileFile)
END
END
END;
PROCEDURE SaveIndex;
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura salveaza tabloul index intr-un fisier pe *)
(* disc, numit fisier index, la terminarea programului. *)
(* -------- ----- ------ ----- ----- ---------- *)
VAR
i: INTEGER;
BEGIN
REWRITE(indexFile);
FOR i := 1 TO fileLength DO
WITH index[i] DO WRITELN(indexFile, clientName, recordNumber);
CLOSE (indexFile)
END;
BEGIN
CLRSCR;
OpenFiles (ready);
IF ready THEN
BEGIN
InitializeMenu;
REPEAT
GetSelection(done)
UNTIL done;
CLRSCR;
CLOSE(profileFile);
IF fileLength > 0 THEN SaveIndex
END
END.
GraphDemo
(* >>> GRPHDEMO.PAS <<<----- ----- --------- ----- -----*)
(* Programul demonstreaza citeva din facilitatile *)
(* grafice posibile prin apelarea rutinelor din *)
(* unit-ul GRAPH intr-un program TURBO PASCAL 5.5 *)
(*-------- ----- ------ ----- ----- -------*)
PROGRAM GraphDemo;
USES CRT,GRAPH;
VAR
driverVar, modeVar: INTEGER;
PROCEDURE GraphTitle (inTitle: STRING);
(* -------- ----- ------ ----- ----- -------------- *)
(* Procedura scrie un titlu cu caractere SPECIALE, centrat *)
(* la partea superioara a ecranului. *)
(* -------- ----- ------ ----- ----- -------------- *)
BEGIN
SETTEXTJUSTIFY(CENTERTEXT, TOPTEXT);
SETTEXTSTYLE(TRIPLEXFONT, HORIZDIR, 4);
OUTTEXTXY GETMAXX DIV 2, 1, inTitle)
END;
PROCEDURE GraphContinue;
(* -------- ----- ------ ----- ----- --------- *)
(* Procedura scrie un mesaj la partea inferioara a *)
(* ecranului si asteapta pina la apasarea barei spatiu. *)
(* -------- ----- ------ ----- ----- --------- *)
CONST mesaj =' Tastati spatiu pentru continuare ...';
VAR inKey: CHAR;
BEGIN
SETTEXTJUSTIFY(CENTERTEXT, TOPTEXT);
SETTEXTSTYLE GOTHICFONT, HORIZDIR, 3);
OUTTEXTXY(GETMAXX DIV 2, GETMAXY - 40, mesaj);
REPEAT inKey := READKEY UNTIL inKey = ' ';
CLEARDEVICE
END;
PROCEDURE DrawSine;
(* -------- ----- ------ ----- ----- ------ *)
(* Procedura traseaza o sinusoida folosind functia *)
(* standard PUTPIXEL. *)
(* -------- ----- ------ ----- ----- ------ *)
CONST
maxLength= 200; maxHeight= 40;
VAR
centerX, centerY, startX, endX, i, plotHeight: INTEGER;
angle: REAL;
BEGIN
GraphTitle('Trasare sinusoida');
centerX := GETMAXX DIV 2; centerY := GETMAXY DIV 2;
startX := centerX - maxLength; endX := centerX + maxLength;
FOR i := startX TO endX DO
BEGIN
angle := ((i - centerX) / (maxLength / 2)) * PI;
plotHeight := centerY - TRUNC (maxHeight * SIN (angle));
PUTPIXEL(i, plotHeight, 1)
END;
LINE(startX - 10, centerY, endX +10, centerY);
LINE(centerX, centerY - maxHeight, centerX, centerY + maxHeight);
GraphContinue
END;
PROCEDURE DrawCircles;
(* ---- Desenare cercure cõ rutina CIRCLE ----- *)
VAR
Orientare, raza: INTEGER;
InitColor, color: WORD;
BEGIN
GraphTitle('Trasare cercuri');
initColor := GETCOLOR; color:=red;
FOR Orientare := -1 to 1 DO
BEGIN
SETCOLOR(color);
FOR raza := 1 TO 4 DO
CIRCLE(GETMAXX DIV 2 + orientare * 100, GETMAXY DIV 2,
raza * 30 + ABS (orientare) * 20);
color := SUCC(color)
END;
SETCOLOR(initColor);
GraphContinue
END;
PROCEDURE DrawPie;
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura traseaza un grafic cu sectoare circulare, *)
(* numite ;pie chart;, ilustrind lucrul cu rutinele *)
(* PIESLICE si SETFILLSTYLE. *)
(* -------- ----- ------ ----- ----- ---------- *)
CONST
articole = 5;
simpleDate : ARRAY[1..ARTICOLE] OF REAL 1/2 (7.5, 3.0, 4.5, 9.0, 6.0);
VAR
i, portiune, startUnghi, endUnghi: WORD;
total: REAL;
BEGIN
GraphTitle('Statistica de suprafata'); total := 0.0;
FOR i := 1 TO articole DÏ total := total + simpleDate[i]; startUnghi := 0;
FOR i := 1 TO articole DO
BEGIN
portiune := trunc (360.0 * (simpleDate[i] / total));
IF i = articole THEN endUnghi := 359
ELSE endUnghi := startUnghi + portiune;
SETFILLSTYLE(5 + i, 2);
PIESLICE(GETMAXX DIV 2, GETMAXY DIV 2,
startUnghi, endUnghi, 150); startUnghi := endUnghi
END;
GraphContinue
END;
PROCEDURE DrawBars;
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura traseaza un grafic cu paralelipipede, *)
(* ilustrind lucrul cu rutinele BAR3D si SETFILLSTYLE. *)
(* -------- ----- ------ ----- ----- ---------- *)
CONST
articole = 9;
simpleDate : ARRAY [1..articole, 1..2] OF BYTE 1/2
((19,10),(25,25),(37,10),(16,5)¬ (18,25),(35,43),(43,58),(32,55),(43,32));
VAR
x1, x2, y1, y2, y3, depth: INTEGER;
i: BYTE;
BEGIN
GraphTitle (§ Desenare paralelipipede '); x1 := 50; depth := 9;
FOR i := 1 TO articole DO
BEGIN
y1 := GETMAXY - 50; y2 := y1 - simpleDate[i,1];
y3 := y2 - simpleDate[i,2];
INC(x1, 50); x2 := x1 + 36;
SETFILLSTYLE(6,2); BAR3D(x1, y1, x2, y2, depth, FALSE);
SETFILLSTYLE(7,2); BAR3D(x1, y2, x2, y3, depth, TRUE)
END; GraphContinue
END;
PROCEDURE DrawShapes;
(* -------- ----- ------ ----- ----- ----------- *)
(* Procedura traseaza un dreptunghi, o elipsa si un *)
(* un trunghi ilustrind utilizarea procedurilor RECTANGLE,*)
(* ELLIPSE si DRAWPOLY. *)
(* -------- ----- ------ ----- ----- ----------- *)
CONST
poliPct : ARRAY [1..8] OF WORD 1/2 (200, 60, 50, 140, 250, 140, 200, 60);
VAR color: WORD;
BEGIN
GraphTitle('Diferite forme geometrice'); color := GETCOLOR;
SETCOLOR(2); RECTANGLE(30, 50, GETMAXX - 30, 350);
SETCOLOR(3); ELLIPSE(GETMAXX DIV 2 + 100, GETMAXY DIV 2, 0, 359, 100, 20);
SETCOLOR(4); DRAWPOLY (4, poliPct); SETCOLOR(14); CIRCLE(130, 200, 50);
SETCOLOR(color); GraphContinue
END;
BEGIN
driverVar := 0; INITGRAPH (driverVar, modeVar, ''); DrawSine;
DrawCircles; DrawPie; DrawBars; DrawShapes; CLOSEGRAPH
END.
LateCli
(* >>> LateCli <<< ----- ----- --------- ----- ---- *)
(* Nume fisier : LATECLI.PAS *)
(* Programul tipareste instiintari pentru *)
(* creditorii rau platnici. *)
(* -------- ----- ------ ----------- *)
PROGRAM LateCli;
USES CRT, PRINTER, InUnit, StrUnit, ChrnUnit;
CONST
company= 'Custom Solutions, Inc.';
formFeed= #12;
VAR
clientName: STRING;
invoiceDate: LONGINT;
invoiceAmount: REAL;
PROCEDURE InData;
(ª -------- ----- ------ ----- ----- ----- *)
(* Procedura extrage de la utilizator urmatoarele *)
(* informatii : numele clientului, data facturarii *)
(* si suma facturata. *)
(* -------- ----- ------ ----- ----- ----- *)
BEGIN
WriteLn('Tiparirea instiintarii pentru rau platnici');
WriteLn('--------- ------------ ------ --- --------'); WriteLn;
Write('Numele clientului : '); ReadLn(clientName);
invoiceDate := InDate('Data facturarii : ');
invoiceAmount := InReal('Suma facturata : '); WriteLn; WriteLn
END;
PROCEDURE Heading;
(ª ----- Tipareste partea comuna a instiintariloò ----- *)
BEGIN
WriteLn(LST);
WriteLn(LST, RightJustify ('Instiintare pentru intirzierea platilor', 30));
WriteLn(LST, RightJustify ('=========== ====== =========== ========', 30));
WriteLn(LST);WriteLn(LST, LeftAlign('Data instiintarii: ', 22), DateString);
WriteLn(LST); WriteLn (LST, LeftAlign('Catre: ', 22), clientName);
WriteLn(LST, LeftAlign('De la: ', 22), company); WriteLn (LST);
WriteLn(LST,LeftAlign('Data facturarii: ',22),ScalarToString(invoiceDate));
WriteLn(LST, LeftAlign('Suma facturata: ', 22),
DollarDisplay(ROUND(invoiceAmount * 100), 9));
WriteLn(LST, LeftAlign('Termen: ', 22), 'Plata completa in 30 zile.');
WriteLn; WriteLn;
END;
PROCEDURE Warning(daysOld: LONGINT);
(* -------- ----- ------ ----- ----- -------- *)
(* Rutina tipareste un mesaj de atentionare pentru *)
(* facturile al caror termen este depasit cu cel mult *)
(* 30 de zile. *)
(* -------- ----- ------ ----- ----- -------- *)
CONST
message: ARRAY[1..5] OF STRING =
('Plata pentru aceasta factura este intirziata cu ',
'zile. Pentru a evita orice intirziere in lucru la',
'proiectul dv., noi vom aprecia promptitudinea dv.',
'in aceasta problema. Daca nu primim suma pina la :',
'sintem obligati sa oprim lucru la proiectul dv.');
VAR
i: BYTE;
BEGIN
Heading; WriteLn(LST, message[1], daysOld - 30);
FOR i := 2 TO 4 DO WriteLn(LST, message[i]);
WriteLn(LST); WriteLn(LST, Spaces(10), ScalarToString(TodaysDate + 14));
WriteLn(LST); WriteLn(LST, message[5]); WriteLn(LST, formFeed)
END;
PROCEDURE Serious(daysOld: LONGINT);
(* -------- ----- ------ ----- ----- -------- *)
(* Rutina tipareste o instiintare in termeni mult mai *)
(* drastici la intirzierea platii cu peste 30 zile. *)
(* -------- ----- ------ ----- ----- -------- *)
CONST
message : ARRAY[1..4] OF STRING =
('Intirzierea pentru aceasta factura este de ',
'zile. Lucrul la proiectul dv. va fi oprit',
'imediat. Daca nu achitati factura pina la ',
'sintem obligati sa va actionam pe alte cai.');
VAR
i: BYTE;
BEGIN
Heading; WriteLn(LST, message[1], daysOld - 30);
FOR i := 2 TO 3 DÏ WriteLn (LST, message[i]);
WriteLn(LST); WriteLn(LST, Spaces(10), ScalarToString(TodaysDate + 7));
WriteLn(LST); WriteLn(LST, message[4]); WriteLn(LST, formFeed);
END;
PROCEDURE TakeAction;
(* -------- ----- ------ ----- ----- --------- *)
(* Rutina examineaza vechimea facturii si decide daca *)
(* se va tipari sau nu o instiintare. *)
(* -------- ----- ------ ----- ----- --------- *)
VAR
age: LONGINT;
FUNCTION Continue: BOOLEAN;
(* -------- ----- ------ ----- ----- -------- *)
(* Functia accepta un semnal de la utilizator pentru *)
(* a cunoaste daca imprimanta este pregatita pentru *)
(* listare sau <ESC> pentru revenire in meniu. *)
(* -------- ----- ------ ----- ----- -------- *)
CONST
spaceBar= ' ';
escKey= #27;
prompt= '<Bara spatiu> pentru tiparire. <Escape> pentru terminare.';
VAR
inKey: CHAR;
BEGIN
inKey := InChar (prompt, [spaceBar, escKey]);
Continue := (inkey = spaceBar)
END;
BEGIN
age := TodaysDate - invoiceDate;
IF age < 60 THEN
BEGIN
WriteLn('*** Nu este necesara tiparirea instiintarii.');
WriteLn(' Factura are o vechime de ', age, ' zile.')
END
ELSE
IF Continue THEN
IF age > 90 THEN
Serious (age)
ELSE
Warning (age)
END;
BEGIN
ClrScr;
InData;
TakeAction
END.
ShowOff
(* >>> ShowOff <<< -------- ----- ------ -- *)
(* Nume fisier : SHOWOFF.PAS *)
(* Programul este destinat demonstrarii modului de *)
(* lucru al algoritmului "quick sort" pentru ordonarea *)
(* unei liste de date de tip sir generate aleator. *)
(* -------- ----- ------ ----- ----- -------- *)
PROGRAM ShowOff;
USES CRT, RandUnit;
CONST
listLength= 200;
TYPE
arrayType= ARRAY[1..listLength] OF STRING[7];
VAR
nameList: arrayType;
continue: STRING;
PROCEDURE PrintList;
(* -------- ----- ------ ----- ----- -------- *)
(* Rutina afiseaza tabelul cu cele 200 de siruri *)
(* generate aleator, atit inainte cit si dupa sortare. *)
(* -------- ----- ------ ----- ----- -------- *)
VAR
i, j: BYTE;
BEGIN
FOR i := 1 TO 20 DO
FOR j := 1 TO 10 DO
Write(nameList[(j -1) * 20 + i], ' ')
END;
PROCEDURE FillList;
(* -------- ----- ------ ----- ----- ---------- *)
(* Procedura asigura generarea aleatoare a sirurilor *)
(* tabelului, folosind functia RandStr din RandUnit. *)
(* -------- ----- ------ ----- ----- ---------- *)
VAR
i: BYTE;
BEGIN
FOR i := 1 TO listLength DO
nameList[i] := RandStr (7)
END;
PROCEDURE QuickSort(VAR stringList:arrayType; firstElement,lastElement:INTEGER);
(* -------- ----- ------ ----- ----- ------------ *)
(* Procedura reprezinta algoritmul recursiv de sortare. *)
(* Ea apeleaza in mod repetat rutina locala DivideList *)
(* pentru separarea listei de sortare in doua parti. *)
(* Dupa fiecare apel la DivideList, rutina QuickSort se *)
(* apeleaza pe sine insasi pentru a sorta cele doua parti *)
(* ale listei. *)
(* -------- ----- ------ ----- ----- ------------ *)
VAR newFirst, newLast: INTEGER;
PROCEDURE DivideList(VAR workList: arrayType;
VAR begin1, final1, begin2, final2: INTEGER);
(* -------- ----- ------ ----- ----- -------------- *)
(* Rutina imparte portiune curenta a listei in doua parti *)
(* si schimba intre ele perechile de elemente atunci cind *)
(* acestea nu sint in ordinea corespunzatoare. *)
(* -------- ----- ------ ----- ----- -------------- *)
VAR
referince, tempStr: STRING[7];
BEGIN
referince := workList[(begin2 + final2) DIV 2];
begin1 := begin2;
final1 := final2;
WHILE begin1 < final1 DO
BEGIN
WHILE workList[begin1] < referince DO
INC(begin1);
WHILE referince < workList[final1] DO
DEC(final1);
IF begin1 <= final1 THEN
BEGIN
tempStr := workList[begin1];
workList[begin1] := workList[final1];
workList[final1] := tempStr;
INC (begin1); DEC (final1)
END
END
END;
BEGIN
IF firstElement < lastElement THEN
BEGIN
DivideList(stringList, newFirst, newLast, firstElement, lastElement);
QuickSort(stringList, firstElement, newLast);
QuickSort(stringList, newFirst, lastElement)
END
END;
BEGIN
RANDOMIZE;
ClrScr; WriteLn(' Lista nesortata :'); WriteLn;
FillList;
PrintList;
QuickSort(nameList, 1, listLength);
WriteLn; Write('Tastati <Enter> pentru afisarea listei sortate.');
Readln(continue);
ClrScr; WriteLn(' Lista sortata :'); WriteLn;
PrintList; WriteLn; ReadLn
END.
ChrnUnit
(* >>> ChrnUnit <<< -------- ----- ------ - *)
(* Nume fisier : CHRNUNIT.PAS *)
(* Unit-ul ChrnUnit contine o colectie de rutine care *)
(* asigura prelucrare completa a datei si timpului. *)
(* -------- ----- ------ ----- ----- -------- *)
UNIT ChrnUnit;
INTERFACE
USES DOS, CRT;
FUNCTION ChronString(year, month, day, weekDay: WORD): STRING;
FUNCTION DateString: STRING;
FUNCTION TimeString: STRING;
FUNCTION DaysInMonth (month, year: WORD): BYTE;
FUNCTION DaysInYear(year: WORD): WORD;
FUNCTION ScalarDate(month, day, year: WORD): LONGINT;
FUNCTION InDate(prompt: STRING): LONGINT;
FUNCTION TodaysDate: LONGINT;
FUNCTION DayOfWeek(scDate: LONGINT): BYTE;
FUNCTION ScalarToString(scDate: LONGINT): STRING;
IMPLEMENTATION
FUNCTION ChronString (year, month, day, weekDay: WORD): STRING;
(* -------- ----- ------ ----- ----- ----- *)
(* Functia converteste cele patru valori numerice *)
(* transmise ca parametri intr-un sir de forma : *)
(* 'Ziua,ll. zz. aaaa'. *)
(* -------- ----- ------ ----- ----- ----- *)
CONST
days:ARRAY[0..6] OF STRING[3]=('Dum','Lun','Mrt','Mrc','Joi','Vin','Smb');
months: ARRAY[1..12] OF STRING[3] = ('Ian','Feb','Mar','Apr','Mai','Iun',
'Iul','Aug','Sep','Oct','Nov','Dec');
VAR
yearStr, monthStr, dayStr, weekdayStr: STRING;
BEGIN
STR(year, yearStr); STR(day, dayStr);
IF LENGTH(dayStr) = 1 THEN dayStr := ' ' + dayStr;
weekdayStr := days[weekday] + '.,'; monthStr := months[month] + '. ';
ChronString := weekdayStr + monthStr ; dayStr + ', ' + yearStr
END;
FUNCTION DateString;
(* -------- ----- ------ ----- ----- ----- *)
(* Functia converteste valorile numerice furnizate *)
(* de procedura interna GETDATE intr-un sir, de *)
(* forma : 'Ziua,ll. zz. aaaa'. *)
(* -------- ----- ------ ----- ----- ----- *)
VAR
year, month, day, weekday: WORD;
BEGIN
GETDATE(year, month, day, weekday);
DateString := ChronString (year, month, day, weekDay)
END;
FUNCTION TimeString;
(* -------- ----- ------ ----- ----- ----- *)
(* Functia converteste valorile numerice furnizate *)
(* procedura interna GETTIME intr-un sir de forma : *)
(* 'hh.mm am/pm'. *)
(* -------- ----- ------ ----- ----- ----- *)
VAR
hour, minute, second, hundredth: WORD;
ampm: STRING[2];
hourStr, minuteStr: STRING;
BEGIN
GETTIME(hour, minute, second, hundredth);
IF hour > 11 THEN
BEGIN
ampm := 'pm';
IF hour > 12 THEN DEC(hour, 12)
END
ELSE
BEGIN
ampm := 'am';
IF hour = 0 THEN hour := 12
END;
STR(hour, hourStr); STR (minute, minuteStr);
IF LENGTH (hourStr) = 1 THEN hourStr := ' ' + hourStr;
IF LENGTH (minuteStr) = 1 THEN minuteStr := '0' + minuteStr;
TimeString := hourStr + ':' + minuteStr + ' ' + ampm
END;
FUNCTION DaysInMonth(month, year: WORD): BYTE;
(* -------- ----- ------ ----- ----- ------ *)
(* Functia furnizeaza numarul de zile ale unei luni *)
(* -------- ----- ------ ----- ----- ------ *)
VAR temp: BYTE;
BEGIN
CASE month OF
1, 3, 5, 7, 8, 10, 12 : temp := 31;
4, 6, 9, 11 : temp := 30;
2 : IF (year MOD 4) = 0 THEN temp := 2¹ ELSE temp := 28
END;
DaysInMonth := temp
END;
FUNCTION DaysInYear (year: WORD): WORD;
(* -------- ----- ------ ----- ----- ----- *)
(* Functia furnizeaza numarul de zile ale unei an *)
(* -------- ----- ------ ----- ----- ----- *)
VAR temp: WORD;
BEGIN
IF (Year MOD 4) = 0 THEN temp := 364
ELSE temp := 365;
DaysInYear := temp
END;
FUNCTION ScalarDate(month, day, year: WORD): LONGINT;
(* -------- ----- ------ ----- ----- ------ *)
(* Functia returneaza scalarul echivalent datei *)
(* calendaristice receptionata. In acest sistem data *)
(* 01.01.1901 este ziua 1, iar ultima data corecta *)
(* este 31.12.1999, care este ziua 36139. *)
(* -------- ----- ------ ----- ----- ------ *)
VAR
temp: LONGINT;
i: BYTE;
BEGIN
temp := 0;
FOR i := 1 to (year - 1) DO INC(temp, DaysInYear (i));
FOR i := 1 TO (month - 1) DO INC(temp, DaysInMonth (i, year));
INC (temp, day);
ScalarDate := temp
END;
FUNCTION InDate (prompt: STRING): LONGINT;
(* -------- ----- ------ ----- ----- ----- *)
(* Functia citeste de la tastatura o data corecta *)
(* in format LL ZZ AA. Functia accepta ca separatori*)
(* caracterele '/', '-', '.' si ' ' intre elementele*)
(* unei date calendaristice. *)
(* -------- ----- ------ ----- ----- ----- *)
CONST
numChars = 4;
divisionChars : ARRAY[1..numChars] OF CHAR = ('/', '-', '.', ' ');
VAR
xSave, ySave, charIndex, firstDiv, secondDiv: BYTE;
month, day, year, monthCode, dayCode, yearCode: WORD;
inDateString, monthStr, dayStr, yearStr: STRING;
good: BOOLEAN;
targetChar: CHAR;
FUNCTION Pos2 (inChar: CHAR; inStr: STRING): BYTE;
(* -------- ----- ------ ----- ----- ----- *)
(* Functia cauta a doua pozitie a caracterului *)
(* inChar in sirul inStr. *)
(* -------- ----- ------ ----- ----- ----- *)
VAR
firstPos, secondPos: BYTE;
secondString: STRING;
BEGIN
firstPos := POS (inChar, inStr);
secondString := COPY(inStr, firstPos + 1, LENGTH(inStr) - firstPos);
secondPos := POS (inChar, secondString) + firstPos; Pos2 := secondPos
END;
BEGIN
REPEAT
Write (prompt); xSave := WhereX; ySave := WhereY; ReadLn (inDateString);
charIndex := 1;
REPEAT
targetChar := divisionChars[charIndex];
firstDiv := POS(targetChar, inDateString);
secondDiv := Pos2(targetChar, inDateString);
good := (firstDiv > 0) AND (secondDiv > 0);
IF (NOT good) THEN INC(charIndex)
UNTIL good OR (charIndex > numChars);
IF good THEN
BEGIN
monthStr := COPY(inDateString, 1, firstDiv - 1);
dayStr := COPY(inDateString, firstDiv + 1, secondDiv - firstDiv + 1);
yearStr := COPY(inDateString, secondDiv + 1,
LENGTH(inDateString) - secondDiv);
VAL(monthStr, month, monthCode);
VAL(dayStr, day, dayCode); VAL(yearStr, year, yearCode);
IF (monthCode + dayCode + yearCode = 0) THEN
BEGIN
IF year > 99 THEN year := year MOD 100;
good := (1 <= month) AND (month <= 12);
good := good AND (year > 0);
good := good AND (day <= DaysInMonth(month, year))
END
ELSE
good := FALSE
END;
IF NOT good THEN
BEGIN GoToXY(xSave, ySave); ClrEoì END
UNTIL good;
InDate:= ScalarDate(month, day, year)
END;
FUNCTION TodaysDate: LONGINT;
(* -------- ----- ------ ----- ----- ----- *)
(* Functia furnizeaza echivalentul scalar al datei *)
(* curente din calendarul sistemului. *)
(* -------- ----- ------ ----- ----- ----- *)
VAR
year, month, day, weekday: WORD;
BEGIN
GetDate(year, month, day, weekday);
TodaysDate := ScalarDate(month, day, (year MOD 100))
END;
FUNCTION DayOfWeek (scDate: LONGINT): BYTE;
(* -------- ----- ------ ----- ----- ----- *)
(* Functia furnizeaza un intreg cuprins intre 0 si *)
(* 6, reprezentind ziua din saptamina pentru data *)
(* scalara transmisa. 0 reprezinta ziua de Duminica.*)
(* -------- ----- ------ ----- ----- ----- *)
BEGIN
DayOfWeek := ((scDate + 1) MOD 7)
END;
FUNCTION ScalarToString(scDate: LONGINT): STRING;
(* -------- ----- ------ ----- ----- ----- *)
(* Functia converteste o data scalara intr-un sir *)
(* de forma : Ziua., Luna., ZZ, AAAA. *)
(* -------- ----- ------ ----- ----- ----- *)
VAR
remainder: LONGINT;
year, month, day, weekday: WORD;
BEGIN
remainder := scDate;
year := 1;
WHILE (remainder > DaysInYear(year)) DO
BEGIN DEC(remainder, DaysInYear (year)); INC(year) END;
month := 1;
WHILE (remainder > DaysInMonth(month, year)) DO
BEGIN DEC(remainder, DaysInMonth(month, year)); INC(month) END;
day := remainder; weekday := DayOfWeek (scDate);
ScalarToString := ChronString((year + 1900), month, day, weekday)
END;
END.
InUnit
(* >>> InUnit <<< -------- ----- ------ ---- *)
(* Nume fisier : INUNIT.PAS *)
(* Unit-ul contine rutine speciale pentru acceptarea *)
(* si validarea datelor introduse de la tastatura. *)
(* -------- ----- ------ ----- ----- --------- *)
UNIT InUnit;
INTERFACE
USES CRT;
TYPE
validSet = SET OF CHAR;
FUNCTION InReal(prompt: STRING): REAL;
FUNCTION InByte(prompt: STRING): BYTE;
FUNCTION InChar(prompt: STRING; goodChars: validSet): CHAR;
IMPLEMENTATION
FUNCTION InReal(prompt: STRING): REAL;
(* -------- ----- ------ ----- ----- ------------ *)
(* Functia afiseaza pe ecran prompterul de intrare si *)
(* extrage numarul real introdus. Daca introducerea *)
(* utilizatorului nu este corecta - spre exemplu, a tastat *)
(* caractere nenumerice - atunci InReal sterge caracterele *)
(* introduse si continua sa afiseze prompterul de intrare. *)
(* -------- ----- ------ ----- ----- ------------ *)
VAR
trapReal: REAL;
goodInput: BOOLEAN;
saveX, saveY: BYTE;
BEGIN
REPEAT
WRITE(prompt); saveX := WHEREX; saveY := WHEREY;
READLN(trapReal);
goodInput := (IORESULT = 0);
IF NOT goodInput THEN BEGIN GOTOXY(saveX, saveY); ClrEol END;
UNTIL goodInput; InReal := trapReal
END;
FUNCTION InByte(prompt: STRING): BYTE;
(* -------- ----- ------ ----- ----- ------------- *)
(* Functia afiseaza prompterul de intrare si extrage o *)
(* valoare BYTE de la tastatura. Daca introducerea contine *)
(* caractere nenumerice sau nu este in intervalul valorilor *)
(* de tip BYTE se sterge introducerea si continua afisarea *)
(* prompterului de intrare. *)
(* -------- ----- ------ ----- ----- ------------- *)
VAR
trapInteger: INTEGER;
goodInput: BOOLEAN;
saveX, saveY: BYTE;
BEGIN
REPEAT
WRITE (prompt); saveX := WHEREX; saveY := WHEREY;
READLN (trapInteger);
goodInput := (IORESULT=0) AND (trapInteger>=0) AND (trapInteger<=255);
IF NOT goodInput THEN BEGIN GOTOXY(saveX, saveY); CLREOL END
UNTIL goodInput; InByte := trapInteger
END;
FUNCTION InChar(prompt: STRING; goodChars: validSet): CHAR;
(* -------- ----- ------ ----- ----- -------------- *)
(* Functia accepta un singur caracter introdus de la *)
(* tastarura si valideaza introducerea numai daca s-a tastat *)
(* un caracter apartinind multimii stabilite : goodChars. *)
(* -------- ----- ------ ----- ----- -------------- *)
VAR
trapChar, codeDiscard: CHAR;
BEGIN
WRITE (prompt);
REPEAT
trapChar := UPCASE(READKEY);
IF trapChar = #0 THEN codeDiscard := READKEY
UNTIL trapChar IN goodChars;
InChar := trapChar
END;
END.
StrUnuit
(* >>> StrUnit <<< -------- ----- ------ *)
(* Nume fisier : STRUNIT.PAS *)
(* Unit-ul furnizeaza proceduri si functii pentru *)
(* prelucrarea speciala a sirurilor. *)
(* -------- ----- ------ ----- ----- ------ *)
UNIT StrUnit;
INTERFACE
CONST
maxScreenColumn = 80;
TYPE
screenRange = 1..maxScreenColumn;
screenLine = STRING[maxScreenColumn];
FUNCTION StringOfChars(displayChar: CHAR; lineLength: screenRange): screenLine;
FUNCTION RightJustify(inString: STRING; fieldLength: BYTE): STRING;
FUNCTION DollarDisplay(inAmount: LONGINT; width: BYTE): STRING;
FUNCTION UpperCase(inString: STRING): STRING;
FUNCTION LowerCase(inString: STRING): STRING;
FUNCTION InitialCap(inString: STRING): STRING;
FUNCTION Spaces(inLength: BYTE): STRING;
FUNCTION LeftAlign(inString: STRING; fieldLength: BYTE): STRING;
FUNCTION FirstChar(inString: STRING): CHAR;
FUNCTION Left(inString: STRING; numChars: BYTE): STRING;
FUNCTION Right(inString: STRING; numChars: BYTE): STRING;
IMPLEMENTATION
FUNCTION StringOfChars(displayChar: CHAR; lineLength: screenRange): screenLine;
(* -------- ----- ------ ----- ----- ---- *)
(* Functia construieste un sir cu caracterele *)
(* displayChar; lungimea sirului fiind lineLength. *)
(* -------- ----- ------ ----- ----- ---- *)
VAR
i: screenRange;
trap: screenLine;
BEGIN
trap := '';
FOR i:=1 TO lineLength DO
trap := trap + displayChar;
StringOfChars := trap
END;
FUNCTION RightJustify (inString: STRING; fieldLength: BYTE): STRING;
(* -------- ----- ------ ----- ----- --------- *)
(* Functia returneaza un sir de lungime fieldLength. *)
(* Valoarea inString este aliniata la dreapta in sirul *)
(* rezultat. *)
(* -------- ----- ------ ----- ----- --------- *)
BEGIN
WHILE LENGTH (inString) < fieldLength DO
inString := ' ' + inString;
RightJustify := inString
END;
FUNCTION DollarDisplay (inAmount: LONGINT; width: BYTE): STRING;
(* -------- ----- ------ ----- ----- -------- *)
(* Functia produce un sir de forma dolar-cent din *)
(* valoarea numerica inAmount (un intreg lung care *)
(* reprezinta centii). Sirul rezultat este aliniat la *)
(* dreapta in cimpul de lungime data. *)
(* -------- ----- ------ ----- ----- -------- *)
VAR
inString: STRING;
inLength, commaMarker, newPos: BYTE;
BEGIN
STR(inAmount, inString);
WHILE LENGTH(inString) < 3 DO
INSERT('0', inString, 1);
inLength := LENGTH(inString);
newPos := inLength;
commaMarker := 4;
WHILE (newPos > 3) DO
BEGIN
INSERT(',', inString, inLength - commaMarker);
INC(inLength);
INC(commaMarker, 4);
DEC(newPos, 3)
END;
INSERT('.', inString, inLength - 1);
INSERT('$', inString, 1);
DollarDisplay := RightJustify (inString, width)
END;
FUNCTION UpperCase(inString: STRING): STRING;
(* -------- ----- ------ ----- ----- ---- *)
(* Functia returneaza o versiune cu majuscule a *)
(* sirului receptionat ca argument. *)
(* -------- ----- ------ ----- ----- ---- *)
VAR
i: INTEGER;
outString: STRING;
BEGIN
outString := '';
FOR i:=1 TO LENGTH(inString) Do
outString := outString + UPCASE(inString[i]);
UpperCase := outString
END;
FUNCTION LowerCase (inString: STRING): STRING;
(* -------- ----- ------ ----- ----- ------ *)
(* Functia furnizeaza o versiune cu litere mici a *)
(* sirului receptionat ca argument. *)
(* -------- ----- ------ ----- ----- ------ *)
VAR
i: INTEGER;
targetChar, lowerChar: CHAR;
outString: STRING;
upperCaseLetters: SET OF CHAR;
BEGIN
upperCaseLetters := ['A'..'Z'];
outString := '';
FOR i := 1 TO LENGTH(inString) DO
BEGIN
targetChar := inString[i];
IF targetChar IN upperCaseLetters THEN
BEGIN
lowerChar := CHR(ORD(targetChar) + 32);
outString := outString + lowerChar
END
ELSE
outString := outString + targetChar
END;
LowerCase := outString
END;
FUNCTION InitialCap(inString: STRING): STRING;
(* -------- ----- ------ ----- ----- --------- *)
(* Functia transforma in majuscula litera initiala *)
(* a sirului transmis ca argument, iar celelalte litere *)
(* le converteste in litere mici. Foloseste functiile *)
(* UpperCase si LowerCase. *)
(* -------- ----- ------ ----- ----- --------- *)
VAR
firstLetter, remainingLetters: STRING;
BEGIN
firstLetter := UpperCase(inString[1]);
remainingLetters := LowerCase(COPY(inString, 2, LENGTH(inString) - 1));
InitialCap := firstLetter + remainingLetters
END;
FUNCTION Spaces(inLength: BYTE): STRING;
(* -------- ----- ------ ----- ----- -------- *)
(* Functia furnizeaza un sir de inLength blancuri. *)
(* -------- ----- ------ ----- ----- -------- *)
VAR
i: BYTE;
trapSpace: STRING;
BEGIN
trapSpace := '';
FOR i := 1 TO inLength DO
trapSpace := trapSpace + ' ';
Spaces := trapSpace
END;
FUNCTION LeftAlign(inString: STRING; fieldLength: BYTE): STRING;
(* -------- ----- ------ ----- ----- -------- *)
(* Functia alinie la stinga argumentul sir inString *)
(* in cimpul de lungime fieldLength. *)
(* -------- ----- ------ ----- ----- -------- *)
VAR
spacesToAdd: BYTE;
BEGIN
spacesToAdd := fieldLength - LENGTH(inString);
LeftAlign := inString + Spaces(spacesToAdd)
END;
FUNCTION FirstChar(inString: STRING): CHAR;
(* -------- ----- ------ ----- ----- ------ *)
(* Functia furnizeaza primul caracter al sirului *)
(* receptionat ca argument. *)
(* -------- ----- ------ ----- ----- ------ *)
BEGIN
FirstChar := inString[1]
END;
FUNCTION Left(inString: STRING; numChars: BYTE): STRING;
(* -------- ----- ------ ----- ----- ----- *)
(* Functia furnizeaza primele numChars caractere *)
(* din sirul receptionat ca argument. *)
(* -------- ----- ------ ----- ----- ----- *)
BEGIN
Left := COPY (inString, 1, numChars)
END;
FUNCTION Right (inString: STRING; numChars: BYTE): STRING;
(* -------- ----- ------ ----- ----- ------ *)
(* Functia furnizeaza ultimele numChars caractere *)
(* din sirul receptionat ca argument. *)
(* -------- ----- ------ ----- ----- ------ *)
VAR
index : BYTE;
BEGIN
IF numChars >= LENGTH (inString) THEN
Right := inString
ELSE
BEGIN
index := LENGTH(inString) - numChars +1;
Right := COPY(inString, index, numChars)
END
END;
END.
|
