Program Gabungan Push dan Pop

uses crt;

const garis ='---------------------------------------';

pesan ='Senarai Berantai Masih Kosong';

type simpul = ^data;

data   = record

nama : string;

alamat : string;

berikut : simpul;

end;

var

awal,akhir : simpul;

pilih : char;

cacah : integer;

function MENU : char;

var P : char;

begin

clrscr;

gotoxy(30,3); write('DAFTAR MENU PILIHAN');

gotoxy(20,5); write('1. MASUKKAN ANTRIAN');

gotoxy(20,7); write('2. ANTRIAN MASUK');

gotoxy(20,9); write('3. MENGHAPUS ANTRIAN DI TENGAH');

gotoxy(20,11); write('4. MENCETAK ISI ANTRIAN');

gotoxy(20,13); write('5. SELESAI');

repeat

gotoxy(48,20); write('':10);

gotoxy(30,20); write('Pilih salah satu: ');

P := upcase(readkey);

until P in ['1'..'5'];

MENU := P;

end;

function SIMPUL_BARU : simpul;

var

B : simpul;

begin

new(B);

with B^ do

begin

write('Nama  : '); readln(nama);

write('No. Antrian: '); readln(alamat);

berikut := nil;

end;

SIMPUL_BARU := B;

end;

 procedure TAMBAH_AWAL (N : integer);

var

baru : simpul;

begin

if N <> 0 then

begin

writeln('MENAMBAH SIMPUL BARU DI AWAL SENARAI BERANTAI');

writeln(copy(garis,1,45));

end;

writeln;

baru := SIMPUL_BARU;

if awal=nil then

awal:= baru

else

akhir^.berikut := baru;

akhir := baru;

end;

procedure HAPUS_PERTAMA;

begin

if awal <> nil then

begin

awal := awal^.berikut;

writeln('SIMPUL PERTAMA TELAH TERHAPUS');

end

else

writeln(pesan);

writeln; writeln('TEKAN <RETURN> UNTUK KEMBALI KE MENU UTAMA');

repeat until keypressed

end;

procedure HAPUS_TENGAH;

var posisi,i : integer;

bantu,bantu1 : simpul;

begin

if cacah=0 then

begin

writeln(pesan); writeln;

writeln('TEKAN <RETURN> UNTUK KEMBALI KE MENU UTAMA');

repeat until keypressed

end

else

begin

writeln('MENGHAPUS SIMPUL YANG ADA DI TENGAH');

writeln(copy(garis,1,35)); writeln;

writeln('SENARAI BERANTAI SEKARANG BERISI :',cacah:2,' SIMPUL');

repeat

gotoxy(37,5); write('':5);

gotoxy(1,5); write('Akan menghapus simpul nomor berapa: ');

readln(posisi);

until posisi in [1..cacah];

begin

bantu := awal;

for i:=1 to posisi-2 do

bantu:= bantu^.berikut;

bantu1 := bantu^.berikut;

bantu^.berikut := bantu1^.berikut;

bantu1^.berikut := nil;

dispose(bantu1);

end;

end;

end;

procedure BACA_SENARAI;

var bantu : simpul;

i     : integer;

begin

writeln('MEMBACA ISI SENARAI BERANTAI');

writeln('TEKAN <RETURN> UNTUK KEMBALI KE MENU UTAMA');

writeln(copy(garis,1,42)); writeln;

bantu := awal;

if bantu=nil then

writeln(pesan)

else

while bantu <> nil do

begin

writeln('Nama  : ',bantu^.nama);

writeln('No. Antrian: ',bantu^.alamat);

bantu := bantu^.berikut;

end;

repeat until keypressed

end;

{PROGRAM UTAMA}

begin

cacah := 0;

awal := nil;

repeat

pilih := MENU;

clrscr;

case pilih of

'1' : TAMBAH_AWAL(1);

'2' : HAPUS_PERTAMA;

'3' : HAPUS_TENGAH;

'4' : BACA_SENARAI;

end;

if pilih in ['1'] then inc(cacah)

else if (pilih in ['2','3']) and (cacah <> 0) then

dec(cacah)

until pilih='5'

end.

Contoh Program Single Linked List Circular

USES Crt;

TYPE Duma = ^data;

data = RECORD

nilai : char;

lagi : Duma;

end;

var jalan : duma;

kar,tom : char;

masuk : boolean;

{---------------------------------------------------------------------}

PROCEDURE Baca(jalan:duma);

var bantu:duma;

begin

bantu:=jalan;

while bantu<>nil do

begin

write(bantu^.nilai,' ');

bantu:=bantu^.lagi;

end;

writeln;

end;

{---------------------------------------------------------------------}

PROCEDURE Masdep(var jalan:duma;kar:char);

var baru:duma;

begin

new(baru);baru^.nilai:=kar;baru^.lagi:=nil;

if jalan=nil then jalan:=baru

else

begin

baru^.lagi:=jalan;

jalan:=baru;

end;

end;

{---------------------------------------------------------------------}

PROCEDURE bacamundur(jalan:duma);

var bantu,baru,lewat : duma;

begin

new(baru);baru^.lagi:=nil;

bantu:=jalan;

if bantu=nil then writeln('Link kosong !')

else

begin

repeat

new(lewat);{lewat^.lagi:=nil;}

lewat^.nilai:=bantu^.nilai;

lewat^.lagi:=baru;

baru:=lewat;

bantu:=bantu^.lagi;

until bantu=nil;

bantu:=baru;

while bantu^.lagi<>nil do

begin

writeln(bantu^.nilai);

bantu:=bantu^.lagi;

end;

end;

end;

{---------------------------------------------------------------------}

PROCEDURE hapus(jalan:duma;kar:char);

var bantu,baru,lewat : duma;

begin

new(baru);baru^.lagi:=nil;

bantu:=jalan;

if bantu=nil then writeln('Link kosong !')

else

begin

repeat

if bantu^.nilai<>kar then

begin

new(lewat);{lewat^.lagi:=nil;}

lewat^.nilai:=bantu^.nilai;

lewat^.lagi:=baru;

baru:=lewat;

end;

bantu:=bantu^.lagi;

until bantu=nil;

bantu:=baru;

while bantu^.lagi<>nil do

begin

writeln(bantu^.nilai);

bantu:=bantu^.lagi;

end;

end;

end;

{---------------------------------------------------------------------}

begin

clrscr;

new(jalan);

jalan^.lagi:=nil;

tom :='Y';

while upcase (tom)='Y' do

begin

repeat

masuk:=true;

write('Masukkan satu huruf, untuk berhenti [T]: ');

kar:=upcase(readkey);writeln(kar);

if kar='T' then masuk:=false;

if masuk=true then masdep(jalan,kar);

until kar='T';

writeln;

write('huruf yang akan dihapus adalah : ');kar:=upcase(readkey);

hapus(jalan,kar);

writeln;

write ('Lagi [Y/T] ? ');readln(tom);

readln;

end;

end.