MY FIRST PROGRAM(PASCAL)
Not much of a big deal though, but for starters this is my first good pascal code that actually runs well. gosh i love dev-pascal but it "Old fashioned sha" lol. anyways. just felt like showing my viewers. just few comments will be good.
expect more HACK and INTERESTING code from techcode.
WARNING: this code was originally written by me, do not duplicate or republish without permision
MY CODE:
//ARRAY IMPLEMENTATION OF ADT LIST
program ADT;
uses crt;
label 1;label 2;label 3;label 4;label 5;label 6;
const max = 1000;
type element_type = integer;
position_type = integer;
list_type = record
element: array [1..max] of element_type;
last: position_type;
end;
var
n,c,j,i: integer;
x: element_type;
p: position_type;
list: list_type;
menus, yn: char;
procedure insert(x: element_type; p: position_type; var l: list_type);
var q: position_type;
begin
if (l.last >= max - 1) then
writeln('Error, List is full')
else if (p < 1) or (p > l.last + 1) then
writeln('Error, position does not exist')
else
begin
for q:= l.last to p do
begin
l.element[q+1] := l.element[q];
l.element[p] := x;
l.last := l.last + 1;
end;
end;
end;
procedure delete(p: position_type; var l: list_type);
var q: position_type;
begin
if (p < 1) or (p > l.last + 1) then
writeln('Error, position does not exist')
else
begin
for q:= p to l.last do
l.element[q] := l.element[q+1];
l.last := l.last - 1;
end;
end;
procedure printlist(var l: list_type);
var q: position_type;
begin
j:=500;
if (l.last <= 0) then
writeln('list is empty')
else
for q:= 1 to l.last - 1 do
begin
writeln(j+q,'. ',l.element[q]);
end;
end;
function retrieve(p: position_type; l: list_type):element_type;
begin
if (p < 1) or (p > l.last + 1) then
begin
writeln('Error, position does not exist');
retrieve := l.last + 1
end
else
retrieve := l.element[p];
end;
function locate(x: element_type; l: list_type): position_type;
var q: position_type;
found: boolean;
begin
q:= 1;
found:= false;
while (q <= l.last) AND (found= false) do
begin
if l.element[q] = x then
begin
found:=true;
locate := q;
end
else
begin
q:=q+1;
if found = false then
locate:= l.last + 1
end;
end;
end;
procedure makenull(p:position_type; var l:list_type);
var q:position_type;
begin
if(p<1 or="" p="">l.last+1)then1>
writeln('ERROR POSITION DOESNT EXIST')
else
begin
for q:= 1 to l.last + 2 do
l.element[p]:= l.element[p];
l.last:= 0;
end
end;
begin
6:clrscr;
gotoxy(50,2);
writeln('CREATE NEW LIST');
writeln;
write('INPUT NUMBER OF ELEMENTS: '); readln(n);
if n > max then
begin
writeln('max exceeded');
readln;
goto 6;
end;
i := 1;
p := 1;
randomize;
for i:= 1 to n do
begin
x := random(100);
if x < 40 then
begin
x:=x+40;
insert(x,p,list);
end
else
insert(x,p,list);
p := p + 1;
end;
4:clrscr;
writeln('PRESENT LIST: ');
writeln;
printlist(list);
writeln;
writeln('-----------------------------------------------------------------------------------------------------------------------');
gotoxy(50,1);
writeln('MENU');
gotoxy(45,2);
writeln;
gotoxy(45,3);
writeln('CLICK: ');
gotoxy(45,4);
writeln('1. To DELETE');
gotoxy(45,5);
writeln('2. To LOCATE');
gotoxy(45,6);
write('3. To RETRIEVE');
gotoxy(45,7);
write('4. CREATE NEW LIST');
gotoxy(45,8);
write('5. To Exit');
menus:=readkey;
if menus = '1' then
goto 1
else if menus = '2' then
goto 2
else if menus = '3' then
goto 3
else if menus = '4' then
begin
makenull(p,list);
clrscr;
goto 6;
end
else if menus = '5' then
halt
else
goto 4;
readln;
1:clrscr;
writeln('PRESENT LIST: ');
printlist(list);
writeln;
writeln('-----------------------------------------------------------------------------------------------------------------------');
writeln;
write('INPUT POSITION TO DELETE FROM: ');
readln(p);
delete(p,list);
5:writeln('PRESENT LIST:');
printlist(list);
writeln('DELETE AGAIN? [y/n]');
yn := readkey;
if (yn = 'y') or (yn = 'Y') then
goto 1
else if (yn = 'n') or (yn = 'n') then
goto 4
else
goto 5;
readln;
2:
clrscr;
writeln('PRESENT LIST: ');
printlist(list);
writeln('-----------------------------------------------------------------------------------------------------------------------');
writeln;
write('INPUT ELEMENT TO LOCATE: ');
readln(x);
c:=locate(x,list);
writeln;
write('>>>> ' ,x, ' IS AT POSITION: ');
writeln(c);
writeln('LOCATE AGAIN? [y/n]');
yn := readkey;
if (yn = 'y') or (yn = 'Y') then
goto 2
else if (yn = 'n') or (yn = 'n') then
goto 4
else
goto 2;
readln;
readln;
3:clrscr;
writeln('PRESENT LIST: ');
printlist(list);
writeln('-----------------------------------------------------------------------------------------------------------------------');
writeln;
write('INPUT POSITION TO RETRIEVE: ');
readln(p);
c:=retrieve(p,list);
writeln;
write('ELEMENT AT POSITION [' ,p, '] IS: ');
writeln(c);
writeln('RETRIVE AGAIN? [y/n]');
yn := readkey;
if (yn = 'y') or (yn = 'Y') then
goto 3
else if (yn = 'n') or (yn = 'n') then
goto 4
else
goto 3;
readln;
readln;
writeln;
writeln('EXIT or MENU [E/M]');
yn:=readkey;
if (yn = 'm') or (yn = 'M') then
goto 4
else if (yn = 'e') or (yn = 'E') then
end.
expect more HACK and INTERESTING code from techcode.
WARNING: this code was originally written by me, do not duplicate or republish without permision
MY CODE:
//ARRAY IMPLEMENTATION OF ADT LIST
program ADT;
uses crt;
label 1;label 2;label 3;label 4;label 5;label 6;
const max = 1000;
type element_type = integer;
position_type = integer;
list_type = record
element: array [1..max] of element_type;
last: position_type;
end;
var
n,c,j,i: integer;
x: element_type;
p: position_type;
list: list_type;
menus, yn: char;
procedure insert(x: element_type; p: position_type; var l: list_type);
var q: position_type;
begin
if (l.last >= max - 1) then
writeln('Error, List is full')
else if (p < 1) or (p > l.last + 1) then
writeln('Error, position does not exist')
else
begin
for q:= l.last to p do
begin
l.element[q+1] := l.element[q];
l.element[p] := x;
l.last := l.last + 1;
end;
end;
end;
procedure delete(p: position_type; var l: list_type);
var q: position_type;
begin
if (p < 1) or (p > l.last + 1) then
writeln('Error, position does not exist')
else
begin
for q:= p to l.last do
l.element[q] := l.element[q+1];
l.last := l.last - 1;
end;
end;
procedure printlist(var l: list_type);
var q: position_type;
begin
j:=500;
if (l.last <= 0) then
writeln('list is empty')
else
for q:= 1 to l.last - 1 do
begin
writeln(j+q,'. ',l.element[q]);
end;
end;
function retrieve(p: position_type; l: list_type):element_type;
begin
if (p < 1) or (p > l.last + 1) then
begin
writeln('Error, position does not exist');
retrieve := l.last + 1
end
else
retrieve := l.element[p];
end;
function locate(x: element_type; l: list_type): position_type;
var q: position_type;
found: boolean;
begin
q:= 1;
found:= false;
while (q <= l.last) AND (found= false) do
begin
if l.element[q] = x then
begin
found:=true;
locate := q;
end
else
begin
q:=q+1;
if found = false then
locate:= l.last + 1
end;
end;
end;
procedure makenull(p:position_type; var l:list_type);
var q:position_type;
begin
if(p<1 or="" p="">l.last+1)then1>
writeln('ERROR POSITION DOESNT EXIST')
else
begin
for q:= 1 to l.last + 2 do
l.element[p]:= l.element[p];
l.last:= 0;
end
end;
begin
6:clrscr;
gotoxy(50,2);
writeln('CREATE NEW LIST');
writeln;
write('INPUT NUMBER OF ELEMENTS: '); readln(n);
if n > max then
begin
writeln('max exceeded');
readln;
goto 6;
end;
i := 1;
p := 1;
randomize;
for i:= 1 to n do
begin
x := random(100);
if x < 40 then
begin
x:=x+40;
insert(x,p,list);
end
else
insert(x,p,list);
p := p + 1;
end;
4:clrscr;
writeln('PRESENT LIST: ');
writeln;
printlist(list);
writeln;
writeln('-----------------------------------------------------------------------------------------------------------------------');
gotoxy(50,1);
writeln('MENU');
gotoxy(45,2);
writeln;
gotoxy(45,3);
writeln('CLICK: ');
gotoxy(45,4);
writeln('1. To DELETE');
gotoxy(45,5);
writeln('2. To LOCATE');
gotoxy(45,6);
write('3. To RETRIEVE');
gotoxy(45,7);
write('4. CREATE NEW LIST');
gotoxy(45,8);
write('5. To Exit');
menus:=readkey;
if menus = '1' then
goto 1
else if menus = '2' then
goto 2
else if menus = '3' then
goto 3
else if menus = '4' then
begin
makenull(p,list);
clrscr;
goto 6;
end
else if menus = '5' then
halt
else
goto 4;
readln;
1:clrscr;
writeln('PRESENT LIST: ');
printlist(list);
writeln;
writeln('-----------------------------------------------------------------------------------------------------------------------');
writeln;
write('INPUT POSITION TO DELETE FROM: ');
readln(p);
delete(p,list);
5:writeln('PRESENT LIST:');
printlist(list);
writeln('DELETE AGAIN? [y/n]');
yn := readkey;
if (yn = 'y') or (yn = 'Y') then
goto 1
else if (yn = 'n') or (yn = 'n') then
goto 4
else
goto 5;
readln;
2:
clrscr;
writeln('PRESENT LIST: ');
printlist(list);
writeln('-----------------------------------------------------------------------------------------------------------------------');
writeln;
write('INPUT ELEMENT TO LOCATE: ');
readln(x);
c:=locate(x,list);
writeln;
write('>>>> ' ,x, ' IS AT POSITION: ');
writeln(c);
writeln('LOCATE AGAIN? [y/n]');
yn := readkey;
if (yn = 'y') or (yn = 'Y') then
goto 2
else if (yn = 'n') or (yn = 'n') then
goto 4
else
goto 2;
readln;
readln;
3:clrscr;
writeln('PRESENT LIST: ');
printlist(list);
writeln('-----------------------------------------------------------------------------------------------------------------------');
writeln;
write('INPUT POSITION TO RETRIEVE: ');
readln(p);
c:=retrieve(p,list);
writeln;
write('ELEMENT AT POSITION [' ,p, '] IS: ');
writeln(c);
writeln('RETRIVE AGAIN? [y/n]');
yn := readkey;
if (yn = 'y') or (yn = 'Y') then
goto 3
else if (yn = 'n') or (yn = 'n') then
goto 4
else
goto 3;
readln;
readln;
writeln;
writeln('EXIT or MENU [E/M]');
yn:=readkey;
if (yn = 'm') or (yn = 'M') then
goto 4
else if (yn = 'e') or (yn = 'E') then
end.
Labels:
TechCode


No comments: