Senin, 16 Januari 2012

KUMPULAN PROGAM PASCAL

Daftar isi
Program baca berpasangan
Program ganjil genap
Program tumpukan
Antrian melingkar
Program hitung huruf
Program konversi bilangan
Program find kata dalam kalimat
Program cari suku fibonacci
Program deret 2000
Program krs mahasiswa
Program membaca data
Program preorder
Program segitiga pascal
Program random 
Program mencari bilangan terbesar
Program pemasukan huruf pada post order
Program menghitung jumlah node
Program tree dinamis
Program tukar vocal
Program untuk mengurutkan data dengan metode radix sort
Program tukar nilai
Program menghitung banyak vokal
Program banyak huruf dalam kalimat
Program contoh array
Program konversi bilangan
Program kasir
Program konversi bilangan hexadesimal ke desimal
Program kombinasi faktorial
Program mencari suku fibonacci
Program deret
Program mencari suku deret fibonacci
Program masuk pointer dari belakang
Program membalik isi Queue
Program queue dinamis
Program nilai mahasiswa
Program pointer single linked list
Program tree dinamis
Program single pointer
Program menghitung ip
Program menghitung koefisien persamaan regressi
Program menghitung jumlah ganjil genap dan reratanya
Program cacah data
Program mendeteksi bil prima
Program binary search tree
Program konversi bilangan desimal ke biner
Program koversi nilai
Program konversi bilangan desimal ke biner
Program faktorial
Program menggabung 2 array dan hasilnya menaik
Program menggabung 2 array dan hasilnya menurun
program masuk pointer dari belakang
Program membalik isi queue
Program queue statis
Program pangkat
Program post order
Program tree dinamis dengan type character2
Program romawi
Program mahasiswa
Program mencari rata2
Program untuk menghitung jumlah suku ke data
Program kalkulator
Program tulisan
Program menghitung luas
Program menghitung volume luas permukaan bola
Program nilai maximum minimum
Program menentukan positif negative
Program antrian
Program exercises
Program titik1
Program gambar titik
Program gambar titik2
Program gambar titik3
Program dbllinklingkar
Program baris kolom
Program hapus node
Program matrik
Program pecahan
Program permutasi
Program pointer1
Program pointer2
Program pointer3
Program pointer4
Program pointer5
Program pointer6
Program segitiga pascal
Program segitiga pascal2
Program data mahasiswa
Program polynomial dengan menggunakan pointer
Program ackrement
Program pohon biner yang lebih besar ke kiri
Program sorting bubble
Program menampilkan nilai dengan if then else
Program menampilkan nilai dengan case
Program huruf
Program exponen3
Program Menu makanan

 ====================================================================

Program Baca_berpasangan;
Uses WinCrt;
Var
X,Y,Rx,Ry,Jx,Jy : real;
Nx,Ny,i : integer;
Begin
ClrScr;
Write('Masukkan Banyaknya X :');Readln(Nx);
Write('Masukkan Banyaknya Y :');Readln(Ny);
If Nx = Ny then
For i:=1 to Nx Do
begin
Write('Data X ke-',i,' = ');Readln(X);
Write('Data Y ke-',i,' = ');Readln(Y);
Jx:=Jx+X;
Jy:=Jy+Y;
end
else if Nx > Ny then
begin
For i:=1 to Ny Do
begin
Write('Data X ke-',i,' = ');Readln(X);
Write('Data Y ke-',i,' = ');Readln(Y);
Jx:=Jx+X;
Jy:=Jy+Y;
end;
i:=Ny+1;
Repeat
Write('Data X ke-',i,' = ');Readln(X);
Jx:=Jx+X;
i:=i+1;
until i>Nx;
end
else if Nx < Ny then
begin
For i:=1 to Nx Do
begin
Write('Data X ke-',i,' = ');Readln(X);
Write('Data Y ke-',i,' = ');Readln(Y);
Jx:=Jx+X;
Jy:=Jy+Y;
end;
i:=Nx+1;
Repeat
Write('Data Y ke-',i,' = ');Readln(Y);
Jy:=Jy+Y;
i:=i+1;
until i>Ny;
end;
Rx:=Jx/Nx;
Ry:=Jy/Ny;
writeln('Rata-rata dari data X = ',Rx:6:2);
writeln('Rata-rata dari data Y = ',Ry:6:2);
end.
=======================================================================


=======================================================================
Program ganjil_genap;
uses wincrt;
var
bil, i,g1,g2,j1,j2,n: integer;
rt1,rt2:real;
begin
write('Masukkan Banyaknya Data ' );readln(n);
for i := 1 to n do
begin
write('Bilangan ke:',i ,' ');readln(bil);
if bil mod 2 = 0 then
j1:=j1 +1;
g1:=g1+bil;
if bil mod 2 =1 then
j2:=j2+1;
g2:=g2+bil;
end;
rt1:=g1/j1;
rt2:=g2/j2;
writeln('Jumlah bil. Ganjil=' ,j2);
writeln('Jumlah bil. Genap=' ,j1);
writeln('Rerata Ganjil=' ,rt2:4:2);
writeln('Rerata Genap=' ,rt1:4:2);
 end.
=======================================================================



=======================================================================
Program Tumpukan
uses wincrt;
const MaxElemen=5;
type Tumpukan =record
isi:array[1..MaxElemen] of integer;
atas: 0..MaxElemen
end;
type isi=array[0..maxelemen] of integer;
const isilama1:isi=(3,7,2,6,4,8);
isibaru1:isi=(4,8,3,6,5,1);
var
Nilailama,Nilaibaru:isi;
T:tumpukan;
{---------------------------------------------------------------------}
Procedure Ganti_NilaiStack(T:tumpukan;Nilailama,Nilaibaru:isi);
var
penuh,habis: boolean;
x,i:integer;
{---------------------------------------------------------------------}
procedure push( var T:tumpukan; var penuh:boolean;x:integer);
begin
if T.atas = maxElemen then penuh:=true
else
begin
penuh :=false;
T.isi[T.atas]:=x;
T.atas:=T.atas+1;
end;
end;
{---------------------------------------------------------------------}
procedure pop(var T:tumpukan;var habis:boolean; var x:integer);
begin
if T.atas =0 then habis:=true
else
begin
habis:=false;
T.atas:=T.atas-1;
x:=T.isi[T.atas];
end;
end;
{---------------------------------------------------------------------}
begin
clrscr;
write('Nilai Lama Sebelum Masuk Tumpukan : ');
for i:=0 to maxelemen do
write(isilama1[i]);
writeln;
write('Nilai Baru Sebelum Masuk Tumpukan : ');
for i:=0 to maxelemen do
write(isibaru1[i]);
6
writeln;
penuh:=false;
while penuh=false do
begin
push(T,penuh,Nilailama[T.atas]);
end;
write('Isi Tumpukan Lama : ');
while T.atas<>0 do
begin
pop(T,habis,x);
write(x);
end;
writeln;penuh:=false;
while penuh=false do
begin
push(T,penuh,Nilaibaru[T.atas]);
end;
write('Isi Tumpukan Baru : ');
while T.atas<>0 do
begin
pop(T,habis,x);
write(x);
end;
end;
{---------------------------------------------------------------------}
begin
Nilailama:=isilama1;Nilaibaru:=isibaru1;
Ganti_NilaiStack(T,Nilailama,Nilaibaru);
readkey;
end.
 =======================================================================




========================================================================
program antrian melingkar;
uses wincrt;
type lingkar=array[1..10] of char;
type ling=record
nilai:lingkar;
dep:integer;
bel:integer;
isi:integer;
end;
var n:integer;
antrian:ling;
{---------------------------------------------------------------------}
procedure push(var antrian:ling;x:char);
7
begin
if antrian.isi=n then write('antrian penuh')
else
begin
if antrian.bel=n then antrian.bel:=1
else antrian.bel:=antrian.bel+1;
antrian.nilai[antrian.bel]:=x;
antrian.isi:=antrian.isi+1;
end;
end;
{---------------------------------------------------------------------}
procedure pop(var antrian:ling;var x:char);
begin
if antrian.isi=0 then write('antrian kosong')
else
begin
antrian.dep:=antrian.dep+1;
if antrian.dep=n+1 then antrian.dep:=1;
x:=antrian.nilai[antrian.dep];
antrian.nilai[antrian.dep]:=' ';
antrian.isi:=antrian.isi-1;
end;
end;
{---------------------------------------------------------------------}
var i,ingin:integer;
x:char;
begin
n:=5;
i:=0;
repeat
i:=i+1;
write('antrian ke - ',i,' = ');readln(x);
push(antrian,x);
until i=n;
for i:=1 to antrian.bel do write(antrian.nilai[i],' ');
readln;
repeat
write('Anda ingin 0. Udah, 1. Push, 2. pop');readln(ingin);
if ingin<>0 then
case ingin of
1: begin
write('nilai yang akan masuk : ');readln(x);
push(antrian,x);
for i:=1 to n do
write(antrian.nilai[i],' ');
writeln;
end;
2: begin
x:=' ';
pop(antrian,x);
writeln('Data keluar = ',x);
for i:=1 to n do
write(antrian.nilai[i],' ');
8
writeln;
end;
end
until ingin=0;
end.
Hasilnya adalah:
Program Hitung_Huruf;
Uses WinCrt;
Var
Teks : string;
banyak : array['A'..'Z'] of byte;
i : byte;
begin
Write('Masukkan Suatu Kalimat :');
Readln(Teks);
for i:=1 to length(teks) do
banyak[upcase(teks[i])]:=banyak[upcase(teks[i])]+1;
for i:=1 to 26 do
if (banyak[upcase(chr(64+i))]<>0) then
writeln(upcase(chr(64+i)),' banyaknya
=',banyak[upcase(chr(64+i))]);
end.
Hasilnya adalah:
Program Konversi_Bilangan;
Uses WinCrt;
Var
des,desi : integer;
Bin,temp : String;
Begin
Write('Masukkan Suatu Bilangan Desimal :');Readln(des);
desi:=des;
bin:='';
repeat
str(des mod 2, temp);
bin:=temp+bin;
9
des:=des div 2;
writeln(des:4,bin:20);
until des=0;
writeln('(',desi,') desimal =',bin,' (Biner)');
end.
 =====================================================================



======================================================================
Program find kata dalam kalimat;
uses wincrt;
var kalimat,kata:string;
i,j,k,sama:integer;
begin
write('Masukkan sebuah kalimat : ');readln(kalimat);
write('Masukkan sebuah kata : ');readln(kata);
k:=0;
if length(kata)<= length(kalimat) then
repeat
begin
i:=k+1;
while upcase(kalimat[i])<>upcase(kata[1]) do
i:=i+1;
k:=i;
sama:=1;
for j:=2 to length(kata) do
if upcase(kalimat[i+j-1])=upcase(kata[j]) then
sama:=sama+1;
if sama=length(kata) then
begin
write(kata,' adalah substring dari ',kalimat);
k:=length(kalimat)
end;
end;
until k>=length(kalimat);
if sama < length(kata) then
write(kata,' adalah bukan substring dari ',kalimat);
end.
10
Hasilnya adalah:
program cari_suku_fibonacci;
uses wincrt;
var x:array[1..50] of integer;
i,n:integer;
begin
x[1]:=1;
x[2]:=1;
write('Anda mencari suku ke : ');readln(n);
write(x[1],' ');
write(x[2],' ');
for i:=3 to n do
begin
x[i]:=x[i-1]+x[i-2];
write(x[i],' ');
end;
writeln;
writeln('Suku ke ',i,' = ',x[i]);
end.
Hasilnya adalah:
Program deret
uses wincrt;
var
i,t :integer;
a :real;
begin
i:=1; t:=-2; a:=0;
while i<= 10 do
begin
if i mod 2 = 1 then
begin
t:=t+3;
write('+1/',t);
a:=a+(1/t);
end;
else
if i mod 2 = 0 then
begin
t:=t+2;
write('-1/',t);
11
a:=a-(1/t);
end;
i:=i+1;
end;
write(a);
end.
 ========================================================================



========================================================================
program krs_mahasiswa;
uses wincrt;
type
siswa=record
nim:string[5];
nama:string[15];
krs:array[1..4,1..5] of integer;
end;
type kuliah=array[1..20] of siswa;
var kul:kuliah;
{--------------------------------------------------------------------}
function huruf(bobot:integer):char;
begin
case bobot of
0:huruf:='E';
1:huruf:='D';
2:huruf:='C';
3:huruf:='B';
4:huruf:='A';
end;
end;
{--------------------------------------------------------------------}
procedure khs(n:integer;kul:kuliah);
var jumsks,usaha,i,j:integer;
ipnya:real;
begin
for i:=1 to n do
begin
Writeln('Nim : ',kul[i].nim);
Writeln('Nama : ',kul[i].nama);
writeln;
writeln('Kode sks nilai');
jumsks:=0;usaha:=0;
for j:=1 to 2 do
begin
writeln(kul[i].krs[1,j]:3,' ',kul[i].krs[2,j]:3,'
',huruf(kul[i].krs[4,j]):5);
jumsks:=jumsks+kul[i].krs[2,j];
usaha:=usaha + kul[i].krs[2,j]*kul[i].krs[4,j];
end;
if jumsks<>0 then
ipnya:=usaha/jumsks;
writeln;
writeln('IP = ',ipnya:0:2);
readkey;
12
end;
end;
{--------------------------------------------------------------------}
function bobot(nilai:integer):integer;
begin
if nilai<40 then bobot:=0
else
if (nilai>=40) and (nilai<55) then bobot:=1
else
if (nilai>=55) and (nilai<65) then bobot:=2
else
if (nilai>=65) and (nilai<76) then bobot:=3
else
bobot:=4;
end;
{--------------------------------------------------------------------}
procedure masukdata(var kul:kuliah;var n:integer);
var i,j:integer;
begin
clrscr;
write('Banyak mahasiswa = ');readln(n);
for i:=1 to n do
begin
write('Nim : ');readln(kul[i].nim);
write('Nama : ');readln(kul[i].nama);
writeln;
for j:=1 to 2 do
begin
write('Kode : ');readln(kul[i].krs[1,j]);
write('Sks : ');readln(kul[i].krs[2,j]);
write('Nilai : ');readln(kul[i].krs[3,j]);
writeln('Bobot : ',bobot(kul[i].krs[3,j]));
kul[i].krs[4,j]:=bobot(kul[i].krs[3,j]);
writeln('huruf : ',huruf(bobot(kul[i].krs[3,j])));
writeln;
end;
end;
end;
var n:integer;
begin
masukdata(kul,n);
readkey;
khs(n,kul);
 end.
 ======================================================================



 ======================================================================
{Program membaca data dimana data yang sama tidak dapat diterima}
Program Masuk_Data_Sama;
Uses WinCrt;
Type
Larik = array [1..50] of integer;
Var
i,n,b,k : integer;
ada : boolean;
x : Larik;
Begin
clrscr;
Write('Masukkan Bilangan : ');Readln(n);
k:=1;
Repeat
Write('Masukkan Data : ');Readln(b);
ada:=False;
for i:=1 to k do
if b=x[i] then
Begin
ada:=True; i:=k;
end;
if not(ada) then
Begin
x[k]:=b; k:=k+1;
end
14
else
Writeln('Data Sudah ada...');
until k>n;
for i:=1 to n do
writeln(x[i]);
end.
Hasilnya adalah:
{program preorder}
uses wincrt;
type
ptr=^Simpul;
simpul=record
data:integer;
kanan,kiri:ptr;
end;
{--------------------------------------------------------------------}
procedure Init(var p:ptr);
begin
p:=nil;
end;
{--------------------------------------------------------------------}
procedure masukdata(var p:ptr; d:integer);
begin
if p=nil then
begin
new(p);
p^.data:=d;
p^.kiri:=nil;
p^.kanan:=nil;
end
else
if p^.data < d then
masukdata(p^.kanan,d)
else
masukdata(p^.kiri,d);
end;
{--------------------------------------------------------------------}
procedure preorder(p:ptr);
15
begin
if p<>nil then
begin
writeln(p^.data);
preorder(p^.kiri);
preorder(p^.kanan);
end;
end;
{--------------------------------------------------------------------}
var
pohon:ptr;
dt :integer;
begin
init(pohon);
repeat
write('Data masuk ke :');readln(dt);
if dt >= 0 then
masukdata(pohon,dt);
until dt<0;
preorder(pohon);
end.
 =====================================================================


=====================================================================
 Program Segitiga pascal
uses wincrt;
type pas=array[1..20,1..20] of longint;
var pascal:pas;
i,j,n:integer;
begin
pascal[1,1]:=1;
write('banyak level : ');readln(n);{:=10;}
for i:=2 to n do
begin
pascal[i,1]:=1;
pascal[i,i]:=1;
for j:=2 to i-1 do
pascal[i,j]:=pascal[i-1,j-1]+pascal[i-1,j];
end;
16
{write(pascal[2,1],' ');
writeln;}
for i:=1 to n do
begin
for j:=1 to i do
write(pascal[i,j],' ');
writeln;
end;
end.
====================================================================



=====================================================================
Program random_10;
uses WinCrt;
var a,j,i,k : integer;
ada : boolean;
b : array[1..10] of integer;
begin
Randomize;
k:=1;
repeat
A := Random(10)+1;
ada:=False;
for i:=1 to k do
if A=B[i] then Begin ada:=True; i:=k; end;
if not(ada) then
Begin
B[k]:=A;
write(b[k]:4);
k:=k+1;
end;
until k=6;{KeyPressed;}
end.
=====================================================================




=====================================================================
Program mencari bilangan terbesar;
uses wincrt;
var
dafbil:array[1..100] of integer;
terbesar :integer;
terkecil :integer;
i,n :integer;
begin
write('Masukkan cacah bilangan =');readln(n);
{terbesar:=-999;
terkecil:=999;- -->ini hanya berlaku apabila nilai bilangan
antara -999 s/d 999}
{terbesar:=dafbil[1];
terkecil:=dafbil[1];--> akan menyebabkan yang terkecil selalu
0(nol) apabila nilai semua bilangan lebih besar dari 0(nol)}
for i:= 1 to n do
begin
write('Bilangan ke ',i,' = ');readln(dafbil[i]);
end;
terbesar:=dafbil[1];
terkecil:=dafbil[1];
for i:= 2 to n do
if dafbil[i] > terbesar then
terbesar:=dafbil[i]
{for i:= 2 to n do}
else
if dafbil[i] < terkecil then
terkecil:=dafbil[i];
writeln('Bilangan terbesar =',terbesar);
writeln('Bilangan terkecil =',terkecil);
end.
======================================================================



======================================================================
Program Pemasukan Huruf pada post order;
uses wincrt;
type
ptr=^Simpul;
simpul=record
data:char;
kanan,kiri:ptr;
end;
{--------------------------------------------------------------------}
procedure Init(var p:ptr);
begin
p:=nil;
end;
{--------------------------------------------------------------------}
procedure masukdata(var p:ptr; dt:char);
begin
if p=nil then
begin
new(p);
p^.data:=dt;
p^.kiri:=nil;
p^.kanan:=nil;
end
else
if p^.data < dt then
masukdata(p^.kanan,dt)
else
masukdata(p^.kiri,dt);
end;
{--------------------------------------------------------------------}
procedure postorder(p:ptr);
begin
if p<>nil then
begin
postorder(p^.kiri);
postorder(p^.kanan);
writeln(p^.data);
end;
end;
{--------------------------------------------------------------------}
var
pohon:ptr;
dt :char;
begin
init(pohon);
repeat
write('Data masuk ke :');readln(dt);
if dt <>#13 then
masukdata(pohon,dt);
until dt=#13;
writeln;
postorder(pohon);
end.
====================================================================



======================================================================
Program Menghitung Jumlah Node/Simpul pd sebuah Pohon Biner dgn post;
order }
uses wincrt;
type
ptr=^Simpul;
simpul=record
data:integer;
kanan,kiri:ptr;
end;
{--------------------------------------------------------------------}
procedure Init(var p:ptr);
begin
p:=nil;
end;
{--------------------------------------------------------------------}
procedure masukdata(var p:ptr; d:integer);
begin
if p=nil then
begin
new(p);
p^.data:=d;
p^.kiri:=nil;
p^.kanan:=nil;
end
else
if p^.data < d then
masukdata(p^.kanan,d)
else
20
masukdata(p^.kiri,d);
end;
{--------------------------------------------------------------------}
procedure postorder(p:ptr;var ka:integer);
begin
if p<>nil then
begin
postorder(p^.kiri,ka);
postorder(p^.kanan,ka);
writeln(p^.data);
end;
end;
{====================Procedure Hitung Sebelah Kiri===================}
procedure hitungnode(p:ptr;var ka:integer);
begin
if p<>nil then
begin
inc(ka);
hitungnode(p^.kiri,ka);
hitungnode(p^.kanan,ka);
end;
end;
{=============================Program Utama ==========================}
var
pohon,p,T:ptr;
dt,jum,k,ki,ka :integer;
begin
init(pohon);
repeat
write('Data masuk ke :');readln(dt);
if dt <> 0 then
masukdata(pohon,dt);
until dt=0;
writeln;
ki:=0;
hitungnode(pohon^.kiri,ki);
writeln('banyak Simpul sebelah kiri =',ki);
ka:=0;
hitungnode(pohon^.kanan,ka);
writeln('banyak Simpul sebelah kanan=',ka);
writeln('Jumlah simpul = ',ki+ka+1);
end.
========================================================================



========================================================================
Program Tree Dinamis;
uses wincrt;
Type pohon=^node;
node=record
data:integer;
kiri,kanan:pohon;
end;
var T:pohon;
info:integer;
{--------------------------------------------------------------------}
Procedure Buat_BST(info :integer;var T:pohon);
var
b:pohon;
begin
if T=nil then
begin
new(b);b^.data:=info;b^.kiri:=nil;b^.kanan:=nil;
T:=b;
end
else
begin
if T^.data<info then
Buat_Bst(info,T^.kanan);
if T^.data>info then
Buat_Bst(info,T^.kiri);
end;
end;
{--------------------------------------------------------------------}
Procedure Baca_BST_pre(b:pohon);
begin
if (b<>nil) then
begin
write(b^.data);
Baca_BST_pre(b^.kiri);
Baca_BST_pre(b^.kanan);
end;
end;
{--------------------------------------------------------------------}
Procedure Baca_BST_in(b:pohon);
22
begin
if (b<>nil) then
begin
Baca_BST_in(b^.kiri);
write(b^.data);
Baca_BST_in(b^.kanan);
end;
end;
{--------------------------------------------------------------------}
Procedure Baca_BST_post(b:pohon);
begin
if (b<>nil) then
begin
Baca_BST_post(b^.kiri);
Baca_BST_post(b^.kanan);
write(b^.data);
end;
end;
{--------------------------------------------------------------------}
begin
clrscr;
new(T);T^.kiri:=nil;T^.kanan:=nil;
writeln('Memasukkan data ke dalam tree');
repeat
write('Nilai data : ');readln(info);
if info<>0 then Buat_BST(info,T);
until info=0;
writeln;
readln;
writeln('Pembacaan secara Pre order');
baca_BST_pre(T);
writeln;
readln;
writeln('Pembacaan secara In order');
baca_BST_in(T);
writeln;
readln;
writeln('Pembacaan secara Post order');
baca_BST_post(T);
end.
=====================================================================



=====================================================================
Program tukar_Vokal;
uses wincrt;
var
i,k,v,a: integer;
s:string;
begin
clrscr;
write('Masukkan Satu Kalimat ');readln(s);
for i:= 1 to length(s) do
case s[i] of
'a':s[i]:='u';
'i':s[i]:='e';
'e':s[i]:='a';
'o':s[i]:='i';
'u':s[i]:='o';
'b':s[i]:='n';
'k':s[i]:='b';
'n':s[i]:='k';
end;
begin
writeln('Kode datanya adalah=',s )
end;
end.
======================================================================



======================================================================
PROGRAM UNTUK MENGURUTKAN DATA DENGAN METODE RADIX SORT
Uses WinCrt;
Type
Pointer = ^TypeData;
TypeData = Record
Nilai : integer;
Berikutnya : Pointer;
End;
Pointer2 = Array[0..9] Of Pointer;
Var
List : Pointer;
Q : Pointer2;
{====================================================================}
{===================== MASUK DATA DARI DEPAN ========================}
{====================================================================}
Procedure Masuk_Depan(Var L : Pointer; X : Integer);
Var
Baru : Pointer;
Begin
New(Baru);
Baru^.Nilai := X;
Baru^.Berikutnya := Nil;
If L = Nil Then L := Baru
Else
Begin
Baru^.Berikutnya := L;
L :=Baru;
End;
End;
{====================================================================}
{======================= PROCEDURE INITIALIZATION ===================}
{====================================================================}
Procedure Initialization(Var Q : Pointer2);
Var
i : byte;
Begin
For i := 0 To 9 Do Q[i] := Nil;
End;
{====================================================================}
{=============== SUSUN DATA UNTUK TIAP MACAM DALAM ARRAY ============}
{====================================================================}
Procedure Susun(L : Pointer;Var Q1 : Pointer2);
Var
Bantu,Baru : Pointer;
i : Byte;
Begin
Bantu := L;
While Bantu <> Nil Do
Begin
New(Baru);
Baru^.Berikutnya := Nil;
Baru^.Nilai := Bantu^.Nilai;
Masuk_Depan(Q1[Baru^.Nilai],Baru^.Nilai);
Bantu := Bantu^.Berikutnya;
End;
End;
25
{====================================================================}
{=================== PROCEDURE CONCATINATION DATA ===================}
{====================================================================}
Procedure Concatination(L : Pointer2; Var Q1 : Pointer);
Var
Bantu,Baru : Pointer;
i : Byte;
Begin
For i := 0 To 9 Do
Begin
If L[i] <> Nil Then
Begin
Baru := L[i];
If Q1 = Nil Then Q1 := Baru
Else
Begin
Bantu := Q1;
While Bantu^.Berikutnya <> Nil Do
Bantu := Bantu^.Berikutnya;
Bantu^.Berikutnya := Baru
End;
End;
End;
End;
{====================================================================}
{========================= PROCEDURE CETAK DATA =====================}
{====================================================================}
Procedure Cetak(L : Pointer);
Var
Bantu : Pointer;
Begin
Bantu := L;
While Bantu <> Nil Do
Begin
Write(Bantu^.Nilai:3);
Bantu := Bantu^.Berikutnya;
End;
End;
{====================================================================}
{======================= PROCEDURE CETAK DATA =======================}
{====================================================================}
Procedure Cetak_Susunan(L : Pointer2);
Var
Bantu,Baru : Pointer2;
i : Byte;
Begin
For i := 0 to 9 do
Begin
Write(' Q[',i,'] =');
If L[i] <> Nil Then
Begin
Bantu[i] := L[i];
While Bantu[i] <> Nil Do
Begin
Write(Bantu[i]^.Nilai:3);
Bantu[i] := Bantu[i]^.Berikutnya;
End;
26
End;
Writeln;
End;
End;
{====================================================================}
{========================== PROGRAM UTAMA ===========================}
{====================================================================}
Var
Bil,N : Byte;
Begin
New(List);
List:=Nil;
Initialization(Q);
Randomize;
Repeat
Bil:=Random(10);
Masuk_Depan(List,Bil);
N:=N+1;
Until N=20;
Writeln;
Writeln(' Mengurutkan Data Dengan Metode RADIX SORT');
Writeln;
Writeln(' DATA SEBELUM DIURUTKAN ....');
Cetak(List);
Writeln;
Susun(List,Q);
writeln;
Writeln(' HASIL PENGELOMPOKAN ...');
Cetak_Susunan(Q);
Writeln;
List:=Nil;
Concatination(Q,List);
Writeln(' HASIL PENGURUTAN SETELAH DIKELOMPOKKAN');
Cetak(List);
writeln;
End.
Hasilnya adalah:
27
Program tukar_nilai;
uses wincrt;
procedure tukar(var px,py:integer;t:integer);
begin
t:=px;
px:=py;
py:=t;
writeln('px = ',px,' py = ',py,' t = ',t);
end;
var x,y,t : integer;
begin
x:=7; y:=5; t:=2;
writeln('x = ',x,' y = ',y,' t = ',t);
tukar(x,y,t);
writeln('x = ',x,' y = ',y,' t = ',t);
end.
======================================================================



=======================================================================
Program Menghitung_Banyak_Vokal ;
uses wincrt;
var
nama :string;
i,vok :integer;
BEGIN
clrscr;
vok:=0;
write('Banyak Vokal dalam kalimat berikut =');readln(nama);
for i:=1 to length(nama) do
case nama[i] of
'A','a','U','u','I','i','E','e','O','o':vok:=vok+1;
end;
writeln('Jumlah Vokalnya :',vok);
READLN;
END.
Hasilnya adalah:
28
program banyak_huruf_dalam_kalimat;
uses wincrt;
var n:array[1..26] of integer;
i,j:integer;
kata : String;
begin
for i:=1 to 26 do n[i]:=0;
write('Ketikkan sebuah kalimat : ');readln(kata);
for i:=1 to length(kata) do
for j:=1 to 26 do
if ord(upcase(kata[i]))=64+j then
inc(n[j]);
for i:=1 to 13 do
writeln(chr(64+2*i-1),' = ',n[2*i-1],' ',chr(64+2*i),' =
',n[2*i]);
end.
======================================================================



=======================================================================
Program contoh_array;
uses wincrt;
var
x:array[1..10] of integer;
i,jum,n : integer;
begin
clrscr;
jum:=0;
write('Masukkan data =');readln(n);
for i:= 1 to n do
begin
write('Data ke-',i ,'=');readln(x[i]);
jum:=jum+x[i];
end;
writeln('Jumlah = ',jum);
end.
=======================================================================



=======================================================================
Program Konversi_Bilangan;
Uses WinCrt;
Var
des,desi : integer;
Heks,temp : String;
Begin
Write('Masukkan Suatu Bilangan Desimal :');Readln(des);
desi:=des;
Heks:='';
repeat
if (des mod 16 < 10) then Heks:=chr(48+ des mod 16)+Heks
else Heks:=chr(55+ des mod 16)+Heks;
des:=des div 16;
writeln(des:4,Heks:20);
until des=0;
writeln('(',desi,') desimal =',Heks,' (Heksadesimal)');
end.
======================================================================



======================================================================
Program Kasir;
uses wincrt;
var nama_barang : array[1..20] of string;
harga : array[1..20] of real;
banyak : array[1..20] of byte;
kata,grs :string;
x,y,i,j :byte;
Jum_Harga,Total_Harga,disc,Total_Bayar,uang :real;
begin
clrscr;
grs:='===============================================================';
kata:='Program Kasir';
x:=round((78-length(kata))/2);
gotoxy(x,2);writeln(kata);
x:=round((78-length(grs))/2);
gotoxy(x,3);write(grs);
{-----------------------------}
gotoxy(x,4);write('Data Belanja');
gotoxy(x,5);write(grs);
30
gotoxy(x,6);writeln('| No | Nama Barang | Harga Satuan |
Banyak | Jumlah Harga |');
gotoxy(x,7);write(grs);
{--------------------------------------------------------------------}
i:=0;
Total_Harga:=0;
repeat
i:=i+1;
gotoxy(x,7+i);write('| ',i);
gotoxy(x+5,7+i);write('|');
gotoxy(x+7,7+i);readln(Nama_barang[i]);
if Nama_Barang[i] <>'' then begin
gotoxy(x+25,7+i);write('|');
gotoxy(x+28,7+i);readln(Harga[i]);
gotoxy(x+28,7+i);writeln(Harga[i]:10:2);
gotoxy(x+41,7+i);write('|');
gotoxy(x+44,7+i);readln(Banyak[i]);
gotoxy(x+50,7+i);write('|');
Jum_Harga:=Harga[i]*Banyak[i];
gotoxy(x+53,7+i);writeln(Jum_Harga:10:2);
gotoxy(x+65,7+i);writeln('|');
Total_Harga:=Total_Harga+Jum_Harga ; end;
until nama_barang[i]='';
{--------------------------------------------------------------------}
disc:=0;
if (Total_Harga > 10000) and (Total_Harga <100000) then
disc:=0.05 * Total_Harga
else
if (Total_Harga >= 100000 ) then
disc:=0.1 *Total_Harga;
{--------------------------------------------------------------------}
kata:='Faktur Penjualan';
y:=round((78-length(kata))/2);
gotoxy(y,2);writeln(kata);
j:=i-1;
gotoxy(x,8+j);write(grs);
gotoxy(x,8+j+1);write('Total Belanja :');
gotoxy(x+53,8+j+1);write(Total_Harga:10:2);
gotoxy(x,8+j+2);write('Discount :');
gotoxy(x+53,8+j+2);write(disc:10:2);
gotoxy(x,8+j+3);write(grs);
gotoxy(x,8+j+4);write('Total Bayar setelah discount :');
Total_Bayar:=Total_Harga-disc;
gotoxy(x+53,8+j+4);write(Total_Bayar:10:2);
gotoxy(x,8+j+5);write('Uang diBayar');
gotoxy(x+53,8+j+5);readln(Uang);
gotoxy(x+53,8+j+5);writeln(Uang:10:2);
gotoxy(x,8+j+6);Write(grs);
gotoxy(x,8+j+7);write('Uang Kembali');
gotoxy(x+53,8+j+7);write(Uang-Total_Bayar:10:2);
end.
======================================================================



======================================================================
Program Konversi_Bilangan;
Uses WinCrt;
Var
des,desi : string;
i, z,j,jlh,jlh1,a,z1,a1,K : longint;
x,y : integer;
Begin
Write('Masukkan Bilangan Heksadesimal :');Readln(des);
desi:=des;
writeln(des);
jlh:=0;
K:=0;
for i:= length(des) downto 1 do
begin
if (des[i] in ['A','B','C','D','E','F']) THEN
begin
a:=ord(des[i])-55;
a1:=i-1;
if i= length(des) then z:=a
else
begin
z1:=1;
K:=K+1;
for j:=1 to K do
z1:=z1*16;
z:=z1*a;
writeln(z1);
end;
end
else
begin
val(des[i],x,y);
if i= length(des) then z:=x
else BEGIN
K:=K+1;
if x=0 then z:=0
else

begin
z1:=1;
for j:=1 to K do
z1:=z1*16;
z:=x*z1;
end;
end; END;
Jlh:=jlh+z
end;
writeln('(',desi,') Heksadesimal =',jlh,' (desimal)');
end.
=======================================================================



=======================================================================
program kombinasi_faktorial;
uses wincrt;
var
fn,fk,fn_k,Kombinasi:real;
i,n,k:integer;
begin
write('Masukkan bilangan n =');readln(n);
write('Masukkan bilangan k =');readln(k);
fn:=1;
fk:=1;
fn_k:=1;
for i:= 2 to n do{Menghitung n faktorial}
fn:=fn*i;
for i := 2 to k do{Menghitung k faktorial}
fk:=fk*i;
for i:= 2 to (n-k) do{ menghitung n-k faktorial}
fn_k:=fn_k*i;
kombinasi:=fn/(fk*fn_k);
writeln(n,' Kombinasi ',k, ' = ',Kombinasi:0:0);
end.
=======================================================================
Program cari_suku_fibonanci_1uses wincrt;
var x:array[1..50] of integer;
i,n:integer;
{--------------------------------------------------------------------}
function fibo(n:integer):integer;
begin
if (n=1) or (n=2) then
fibo:=1
else
fibo:=fibo(n-1)+fibo(n-2);
end;
{--------------------------------------------------------------------}
begin
write('Anda mencari suku ke : ');readln(n);
writeln('Suku ke ',n,' = ',fibo(n));
end.
=======================================================================
Program Deret;
uses wincrt;
Var
i:integer;
y,jum:real;
begin
clrscr;
jum:=0;
i:=0;
while jum <= 1.9999 do
begin
i:=i+1;
y:=1/exp((i-1)*ln(2));
jum:=Jum+y;
writeln(y:0:4);
end;
writeln('Jumlah deret 1.9999 diperoleh Jika Banyak suku = ',i);
end.
=======================================================================
Program mencari suku deret fibonacci;
uses wincrt;
var
x:array[1..100] of integer;
i,n:integer;
lagi:char;
function fibo(n:integer):integer;
begin
if (n = 1) or (n=2) then
fibo:=1
else
fibo:=fibo(n-1)+fibo(n-2);
end;
begin
repeat
write('Suku deret Fibonacci keberapa :');readln(n);
writeln('Suku ke ', n,' =', fibo(n));
write('Lagi ......[Y/T]');lagi:=upcase(readkey);
writeln(lagi);
until lagi <> 'Y';
end.
======================================================================
Program masuk pointer dari belakang;
uses wincrt;
type
ptr=^data;
data =record
nilai:char;
ekor:ptr;
end;
var
erwin,baru,B:ptr;
lagi,x,y :char;
{=============== Memasukkan Pointer baru kedalam Link List ===========}
begin
new(erwin);
erwin:=nil;
repeat
write('Masukkan data :');readln(x);
if x <> #13 then
begin
new(baru);
baru^.nilai:=x;
baru^.ekor:=nil;
if erwin=nil then
erwin:=baru
else
begin
b:=erwin;
while b^.ekor<>nil do
b:=b^.ekor;
b^.ekor:=baru;
b:=baru;
end;
{write('Lagi .......[Y/T] ');lagi:=upcase(readkey);
writeln(lagi); }
end;
until x=#13;{lagi <> 'Y';}
{================Menampilkan isi Link List Pointer ===================}
b:=erwin;
while (b<> nil) and (b^.nilai <> ' ') do
begin
write(b^.nilai,' ');
b:=b^.ekor;
end;
writeln;
{==============Menyisip data baru kedalam Link List Pointer ==========}
write('Masukkan data yang akan disisip :');readln(x);
write('Disisip setelah huruf apa ..? :');readln(y);
new(baru);
baru^.nilai:=x;
baru^.ekor:=nil;
b:=erwin;
while (b<> nil) and (b^.nilai <> ' ') do
begin
36
writeln(b^.nilai);readkey;
if b^.nilai <> y then
b:=b^.ekor
else
begin
baru^.ekor:=b^.ekor;
b^.ekor:=baru;
b:=b^.ekor;
end
end;
{==================Menampilkan isi Link List Pointer =================}
b:=erwin;
while (b<> nil) and (b^.nilai <> ' ') do
begin
write(b^.nilai,' ');
b:=b^.ekor;
end;
writeln;
end.
Hasilnya adalah:
{Program membalik isi Queue}
uses wincrt;
const max=5;
{---------------------------deklarasi queue--------------------------}
type
list=^node;
node=record
isi:integer;
next:list;
end;
queue=record
dep,bel:list;
end;
{---------------------------deklarasi stack--------------------------}
type
stack=record
37
isi:array[1..max] of integer;
top:0..max;
end;
{-------------------------deklarasi variabel-------------------------}
var q:queue;
s:stack;
h,i:integer;
{=========================Procedure-procedure untuk queue============}
Procedure init_Queue(var q:queue);
begin
q.dep:=nil;q.bel:=nil;
end;
{--------------------------------------------------------------------}
Procedure EnQueue(data:integer; var q:queue);
var b:list;
begin
new(b);b^.isi:=data;b^.next:=nil;
if q.bel=nil then begin
q.bel:=b;q.dep:=b;
end
else begin
q.bel^.next:=b;q.bel:=b;
end;
end;
{--------------------------------------------------------------------}
Procedure DeQueue(var q:queue; var h:integer);
var
b:list;
begin
if q.dep<>nil then begin
h:=q.dep^.isi;b:=q.dep;
q.dep:=b^.next;
if q.dep=nil then q.bel:=nil;
end;
end;
{--------------------------------------------------------------------}
procedure tampilQueue(q:queue);
begin
h:=0;
repeat
DeQueue(q,h);
write(h,' ');
until q.dep=nil;
end;
{=====================Procedure-procedure untuk stack================}
procedure initstack(var s:stack);
begin
s.top:=0;
end;
{--------------------------------------------------------------------}
procedure push(h:integer;var s:stack);
begin
if s.top<max then begin
inc(s.top);
s.isi[s.top]:=h;
end;
38
end;
{--------------------------------------------------------------------}
procedure pop(var h:integer;var s:stack);
begin
if s.top>0 then begin
h:=s.isi[s.top];
dec(s.top);
end;
end;
{========================Procedure membalik==========================}
procedure balik(var q:queue;var s:stack);
begin
repeat
dequeue(q,h);
push(h,s);
until q.dep=nil;
repeat
pop(h,s);
enqueue(h,q);
until s.top=0;
end;
{==========================Program utama==============================}
begin
clrscr;
init_Queue(q);initstack(s);
writeln('Masukkan data ke dalam queue');
for i:=1 to max do begin
write('Nilai data : ');readln(h);
EnQueue(h,Q);
end;
write('Isi Queue sebelum dibalik : ');
tampilqueue(q);
balik(q,s);
writeln;
write('Isi Queue sesudah dibalik : ');
tampilqueue(q);
end.
Hasilnya adalah:
39
{Program QUEUE DINAMIS }
uses wincrt;
Type
list=^node;
node=record
isi:char;
next:List;
end;
Queue=record
depan,belakang:List;
end;
{--------------------------------------------------------------------}
Procedure initQueue(var q:queue);
begin
q.depan:=nil; q.belakang:=nil;
end;
{--------------------------------------------------------------------}
Procedure EnQueue(data:char; var Q:queue);
var b:list;
begin
new(b); b^.isi:=data; b^.next:=nil;
if q.belakang=nil then begin
q.belakang:=b;q.depan:=b;
end else begin
q.belakang^.next:=b; q.belakang:=b;
end;
end;
{--------------------------------------------------------------------}
Procedure Dequeue(var q:queue; var hasil:char);
var b:list;
begin
if q.depan <> nil then begin
hasil:=q.depan^.isi; b:=q.depan;
q.depan:=b^.next; dispose(b);
if q.depan=nil then q.belakang:=nil;
end;
end;
{--------------------------------------------------------------------}
var x:char;
q:queue;
begin
clrscr;
initqueue(q);
writeln('Memasukkan data ke dalam queue');
repeat
write('Nilai data : ');x:=upcase(readkey);writeln(x);
if x<>#13 then EnQueue(x,Q);
until x=#13;
writeln;
readln;
writeln('Pengambilan data dari queue yang pertama kali');
while q.depan<>nil do
begin
40
deQueue(Q,x);writeln(x);
end;
readln;
writeln('Pengambilan data dari queue yang kedua kali');
while q.depan<>nil do
begin
deQueue(Q,x);writeln(x);
end;
end.
======================================================================



======================================================================
program nilai_mahasiswa;
uses wincrt;
const sks:array[1..8] of integer=(2,2,2,2,2,2,1,1);
type
siswa=record
nim:string[5];
nama:string[15];
Nihur:array[1..8] of char;
end;
type kuliah=array[1..2] of siswa;
var kul:kuliah;
{--------------------------------------------------------------------}
function bobot(huruf:char):integer;
begin
case upcase(huruf) of
'E':bobot:=0;
'D':bobot:=1;
'C':bobot:=2;
'B':bobot:=3;
'A':bobot:=4;
end;
end;
{--------------------------------------------------------------------}
41
procedure masuk(var kul:kuliah);
var i,j,bbt,jumus,jumsks:integer;
ip:real;
begin
jumsks:=0;
gotoxy(20,1);writeln('PENGOLAHAN NILAI PRA ILKOM 2003');
for i:=1 to 8 do
jumsks:=jumsks+sks[i];
gotoxy(1,3);writeln('No. No.Mhs Nama Mk1 Mk2 Mk3 Mk4
Mk5 Mk6 Mk7 Mk8 IP Ket');
for i:=1 to 19 do begin
jumus:=0;
gotoxy(1,3+i);writeln(i);
gotoxy(6,3+i);readln(kul[i].nim);
gotoxy(15,3+i);readln(kul[i].nama);
for j:=1 to 8 do begin
gotoxy(24+j*5,3+i);readln(kul[i].nihur[j]);
bbt:=bobot(kul[i].nihur[j]);
jumus:=jumus+bbt*sks[j];
end;
ip:=jumus/jumsks;
gotoxy(28+j*5,3+i);writeln(ip:0:2);
if ip>2.75 then begin
gotoxy(34+j*5,3+i);writeln('Lolos');
end
else begin
gotoxy(34+j*5,3+i);writeln('Gagal');
end;
end;
end;
{--------------------------------------------------------------------}
begin
masuk(kul);
end.
=====================================================================



======================================================================
PROGRAM POINTER SINGLE LINKED LIST MASUK DEPAN, BELAKANG DAN SISIP;
Uses WinCrt;
Type
Pointer = ^TypeData;
TypeData = Record
Nilai : integer;
Berikutnya : Pointer;
End;
Var
List : Pointer;
{====================================================================}
{====================== MASUK DATA DARI DEPAN========================}
{====================================================================}
Procedure Masuk_Depan(Var L : Pointer; X : Integer);
Var
Baru : Pointer;
Begin
New(Baru);
Baru^.Nilai := X;
Baru^.Berikutnya := Nil;
if L = Nil then L := Baru
else
Begin
Baru^.Berikutnya :=L;
L :=Baru;
End;
End;
{====================================================================}
{======================= SISIP DATA DI TENGAH =======================}
{====================================================================}
Procedure Sisip_Tengah(Var L : Pointer; X, Y : Integer);
Var
Baru,Bantu : Pointer;
Begin
Bantu := L;
While Bantu^.berikutnya <> Nil Do
Begin
If Bantu^.Nilai = X Then
Begin
New(Baru);
Baru^.Nilai := Y;
Baru^.Berikutnya := Bantu^.Berikutnya;
Bantu^.Berikutnya := Baru;
End;
Bantu := Bantu^.Berikutnya;
End;
End;
{====================================================================}
{===================== MASUK DATA DARI BELAKANG =====================}
{====================================================================}
Procedure Masuk_Belakang(Var L : Pointer; X : Integer);
43
Var
Baru,Bantu : Pointer;
Begin
New(Baru);
Baru^.Nilai := X;
Baru^.Berikutnya := Nil;
Bantu := L;
While Bantu^.Berikutnya <> Nil Do
Bantu := Bantu^.Berikutnya;
Bantu^.Berikutnya := Baru;
End;
{====================================================================}
{========================= HAPUS DATA DARI DEPAN=====================}
{====================================================================}
Procedure Hapus_Depan(Var L : Pointer);
Var
Baru : Pointer;
Begin
Baru := L;
if L = Nil then Writeln('List Kosong...')
else
Begin
L := L^.Berikutnya;
dispose(Baru);
End;
End;
{====================================================================}
{===================== HAPUS DATA DARI TENGAH =======================}
{====================================================================}
Procedure Hapus_Tengah(Var L : Pointer; X : Integer);
Var
Bantu,Hapus : Pointer;
Begin
Bantu := L;
if L = Nil then Writeln('List Kosong...')
else
Begin
Bantu := L;
New(Hapus);
While Bantu^.Berikutnya <> nil Do
Begin
if Bantu^.Berikutnya^.nilai = X then
begin
Hapus:=Bantu^.Berikutnya;
Bantu^.Berikutnya:=Hapus^.Berikutnya;
dispose(Hapus);
End
else
Bantu:=Bantu^.Berikutnya;
End;
End;
End;
44
{====================================================================}
{====================== HAPUS DATA DARI BELAKANG ====================}
{====================================================================}
Procedure Hapus_Belakang(Var L : Pointer);
Var
Baru,bantu : Pointer;
Begin
Bantu := L;
if Bantu = Nil then Writeln('List Kosong...')
else
Begin
While Bantu^.Berikutnya^.Berikutnya <> nil do
Bantu := Bantu^.berikutnya;
New(Baru);
Baru := Bantu^.Berikutnya;
Bantu^.Berikutnya:=nil;
dispose(Baru);
End;
End;
{====================================================================}
{======================= PROCEDURE CETAK DATA =======================}
{====================================================================}
Procedure Cetak(L : Pointer);
Var
Bantu : Pointer;
Begin
Bantu := L;
While Bantu <> Nil Do
Begin
Write(Bantu^.Nilai:3);
Bantu:=Bantu^.Berikutnya;
End;
End;
{====================================================================}
{============================ PROGRAM UTAMA =========================}
{====================================================================}
Var
Bil,Bil1 : integer;
JB : Char;
Begin
New(List);
List:=nil;
Jb := 'Y';
Writeln('MASUK DEPAN');
While UpCase(Jb)='Y' Do
Begin
Write('Masukkan Bilangan : '); Readln(Bil);
Masuk_Depan(List,Bil);
Write('Lagi[Y/T] ');Readln(Jb);
End;
Cetak(List);
Writeln;
45
Jb := 'Y';
Writeln('MASUK BELAKANG');
While UpCase(Jb)='Y' Do
Begin
Write('Masukkan Bilangan : '); Readln(Bil);
Masuk_Belakang(List,Bil);
Write('Lagi[Y/T] ');Readln(Jb);
End;
Cetak(List);
writeln;
Jb := 'Y';
Writeln('MASUK DEPAN');
While UpCase(Jb)='Y' Do
Begin
Write('Masukkan Bilangan : '); Readln(Bil);
Masuk_Depan(List,Bil);
Write('Lagi[Y/T] ');Readln(Jb);
End;
Cetak(List);
Writeln;
Writeln('SISIP TENGAH');
Write('Masukkan Bilangan Yg akan disisip : ');
Readln(Bil1);
Write('Disisip Setelah Bilangan : ');
Readln(Bil);
Sisip_Tengah(List,Bil,Bil1);
Cetak(List);
Writeln;
writeln('HAPUS DEPAN ');
Hapus_Depan(List);
Cetak(List);
Writeln;
writeln('HAPUS BELAKANG');
Hapus_Belakang(List);
Cetak(List);
Writeln;
Writeln('HAPUS TENGAH');
Write('Masukkan Bilangan Yg akan dihapus : ');
Readln(Bil);
Hapus_Tengah(List,Bil);
Cetak(List);
Writeln;
End.
======================================================================



======================================================================
Program Tree Dinamis;
uses wincrt;
Type pohon=^node;
node=record
data:integer;
kiri,kanan:pohon;
end;
var T:pohon;
info:integer;
{--------------------------------------------------------------------}
Procedure Buat_BST(info :integer;var T:pohon);
var
b,p,q:pohon;
begin
new(b);b^.data:=info;b^.kiri:=nil;b^.kanan:=nil;
if T=nil then T:=b
else
begin
p:=T;q:=T;
while (info<>p^.data) and (q<>nil) do
begin
p:=q;
if info<p^.data then q:=p^.kiri
else q:=p^.kanan;
end;
if q=nil then
if info<p^.data then p^.kiri:=b
else
47
p^.kanan:=b
else
writeln('Data sama');
end;
end;
{--------------------------------------------------------------------}
Procedure Baca_BST_pre(b:pohon);
begin
if (b<>nil) then
begin
write(b^.data);
Baca_BST_pre(b^.kiri);
Baca_BST_pre(b^.kanan);
end;
end;
{--------------------------------------------------------------------}
Procedure Baca_BST_in(b:pohon);
begin
if (b<>nil) then
begin
Baca_BST_in(b^.kiri);
write(b^.data);
Baca_BST_in(b^.kanan);
end;
end;
{--------------------------------------------------------------------}
Procedure Baca_BST_post(b:pohon);
begin
if (b<>nil) then
begin
Baca_BST_post(b^.kiri);
Baca_BST_post(b^.kanan);
write(b^.data);
end;
end;
{--------------------------------------------------------------------}
begin
clrscr;
new(T);T^.kiri:=nil;T^.kanan:=nil;
writeln('Memasukkan data ke dalam tree');
repeat
write('Nilai data : ');readln(info);
if info<>0 then Buat_BST(info,T);
until info=0;
writeln;
readln;
writeln('Pembacaan secara Pre order');
baca_BST_pre(T);
writeln;
readln;
writeln('Pembacaan secara In order');
baca_BST_in(T);
writeln;
readln;
writeln('Pembacaan secara Post order');
48
baca_BST_post(T);
end.
=======================================================================



=======================================================================
PROGRAM SINGLE_POINTER;
USES WinCrt;
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;
49
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;
repeat
masuk:=true;
write('Masukkan satu huruf, [T] untuk berhenti : ');
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);
readkey;
end.
=====================================================================



=====================================================================
Program menghitung_IP;
uses wincrt;
type
siswa=record
nim :string[5];
nama:string[15];
krs:array[1..5,1..4] of integer;
end;
type
kuliah=array[1..20] of siswa;
kd=string[5];
var
kul:kuliah;
kode:kd;
{===================fungsi untuk memeriksa nim yang sama==============}
function ceksama(kul:kuliah; kode:kd):boolean;
var i:integer;
begin
i:=1;
ceksama:=false;
while kul[i].nim<>'' do
51
begin
if kul[i].nim=kode then
begin
ceksama:=true;
exit;
end;
i:=i+1;
end;
end;
{=========fungsi untuk mengubah bobot nilai menjadi nilai huruf =====}
function huruf(bobot:integer):char;
begin
case bobot of
0:huruf:='E';
1:huruf:='D';
2:huruf:='C';
3:huruf:='B';
4:huruf:='A';
end;
end;
{=====================================================================}
procedure khs(n:integer;kul:kuliah);
var
jumsks,usaha,i,j:integer;
ipnya :real;
begin
for i:= 1 to n do
begin
writeln('Nim :',kul[i].nim);
writeln('Nama :',kul[i].nama);
writeln;
writeln('No. Kode sks nilai Bobot ');
jumsks:=0;
usaha:=0;
for j:= 1 to 5 do
if kul[i].krs[j,1]<>0 then
begin
writeln(j,'
',kul[i].krs[j,1]:5,kul[i].krs[j,2]:3,huruf(kul[i].krs[j,4]):5,kul[i].k
rs[j,4]:5);
jumsks:=jumsks+kul[i].krs[j,2];
usaha:=usaha+kul[i].krs[j,2]*kul[i].krs[j,4];
end;
if jumsks<>0 then
ipnya:=usaha/jumsks;
writeln;
writeln('IP = ',ipnya:0:2);
readkey;
writeln;
end;
end;
{=====================================================================}
52
function bobot(nilai:integer):integer;
begin
if nilai<40 then bobot:=0
else
if (nilai>=40) and (nilai <55) then bobot:=1
else
if (nilai>=55) and (nilai<65) then bobot:=2
else
if (nilai>65) and (nilai<76) then bobot:=3
else
bobot:=4;
end;
{=====================================================================}
procedure masukdata(var kul:kuliah; var n:integer);
var
i,j :integer;
kode:integer;
kodenim:kd;
ada:boolean;
begin
clrscr;
write('Banyaknya Mahasiswa = ');readln(n);
for i := 1 to n do
begin
repeat
write('Nim : ');readln(kodenim);
ada:=ceksama(kul,kodenim);
if ada=true then
writeln('Nim yang sama sudah ada !');
until ada=false;
kul[i].nim:=kodenim;
write('Nama : ');readln(kul[i].nama);
j:=0;
repeat
write('Kode : ');readln(kode);
if kode <> 0 then
begin
j:=j+1;
kul[i].krs[j,1]:=kode;
write('SKS : ');readln(kul[i].krs[j,2]);
write('Nilai : ');readln(kul[i].krs[j,3]);
writeln('Bobot : ',bobot(kul[i].krs[j,3]));
kul[i].krs[j,4]:=bobot(kul[i].krs[j,3]);
write('Huruf : ',huruf(bobot(kul[i].krs[j,3])));
writeln;
end;
until kode = 0;
writeln;
end;
end;
{=====================================================================}
var
53
n:integer;
begin
masukdata(kul,n);
readkey;
khs(n,kul);
end.
Program Menghitung Koefisien Persamaan Regressi
uses wincrt;
type data=array[1..100]of integer;
var
x,y :data;
N,d,j :Integer;
ratax,ratay :real;
SXY,SX,SX2,SY:real;
A,B :real;
{--------------------------------------------------------------------}
Procedure Regressi;
begin
N:=0;
repeat
write('Nilai data x= ');readln(d);
if d<>0 then begin
N:=N+1;
x[N]:=d;
write('Nilai data y = ');readln(y[N]);
end;
until d=0;
SXY:=0; SX:=0; SX2:=0; SY:=0;
for j:= 1 to N do
begin
SXY:=SXY+x[j]*y[j];
SX:=SX+x[j];
SY:=SY+y[j];
SX2:=SX2+x[j]*x[j];
end;
A:=((SX2-(SX)*SY))/N;
A:=A/(SX2-(SX*SX)/N);
ratay:=SY/N;
ratax:=SX/N;
B:=ratay-A*rataX;
writeln('N= ',N);
writeln('Jumlah x= ',SX:0:2);
writeln('Jumlah y= ',SY:0:2);
writeln('Jumlah x dikali y =',SXY:0:2);
writeln('Jumlah x kwadrat=',SX2:0:2);
writeln('Rata-rata x=',ratax:0:2);
54
writeln('Rata-rata y=',ratay:0:2);
writeln('Y= ', A:0:2,'X- ', B:0:2);
end;
begin
regressi;
end.
=======================================================================



=======================================================================
Program menghitung_jumlah_ganjil_genap_dan_reratanya;
uses wincrt;
var
data:array[1..100] of integer;
n,i:integer;
jumGanjil,nGanjil,JumGenap,nGenap:integer;
rataGenap,rataGanjil:real;
begin
jumGenap:=0;
nGenap:=0;
jumGanjil:=0;
nGanjil:=0;
write('Masukkan banyak data =');readln(n);
for i:= 1 to n do
begin
write('Data ke ',i,' =');readln(data[i]);
if data[i] mod 2 =0 then
begin
jumGenap:=jumGenap+data[i];
nGenap:=nGenap+1;
end
else
begin
jumGanjil:=JumGanjil+data[i];
nGanjil:=nGanjil+1;
end;
end;
rataGenap:=jumGenap/nGenap;
rataGanjil:=jumGanjil/nGanjil;
writeln('Cacah Genap = ',nGenap,' rata-rata Genap =
',rataGenap:0:2);
writeln('Cacah Ganjil = ',nGanjil,' rata-rata Ganjil =
',rataGanjil:0:2);
writeln('Jumlah Genap = ',jumGenap);
writeln('jumlah Ganjil = ',JumGanjil);
end.
========================================================================



=========================================================================
program cacah_data;
uses wincrt;
var
x:array[1..10] of integer;
i,n,jum,njum:integer;
rata:real;
begin
clrscr;
jum:=0;
write('Masukkan cacah data =');readln(n);
for i:= 1 to n do
begin
write('Masukkan data ke-',i, '=');readln(x[i]);
jum:=jum+x[i];
njum:=njum+1;
Rata:=jum/njum;
end;
writeln('Jumlah = ',jum);
writeln('Rata-rata = ',rata:0:2);
end.
=======================================================================



=======================================================================
program mendeteksi_bil_prima;
uses wincrt;
var
bil,i,x :word;
prima :boolean;
batas :integer;
lagi :char;
begin
repeat
clrscr;
write('Masukkan bilangan :');read(bil);
batas:=round(sqrt(bil))+1;
prima:=true;
if (bil=2 ) or (bil=3) then
prima:=true
else
for i:= 2 to batas do
if bil mod i = 0 then
prima:=false;
if prima = true then
writeln(bil,' Adalah prima')
else
writeln(bil,' Bukan prima');
write('Lagi......[Y/T]');lagi:=upcase(readkey);
writeln(lagi);
until lagi <> 'Y';
end.
=======================================================================



=======================================================================
PROGRAM BINARY SEARCH TREE;
Uses WinCrt;
Type
Pointer = ^TypeData;
TypeData = Record
Nilai : integer;
Kiri,Kanan : Pointer;
End;
Var
Tree : Pointer;
{=========================== MEMBENTUK TREE===========================}
Procedure Sisip_Tree(Var Tree : Pointer; Data : Integer);
Var
Baru : Pointer;
Begin
57
if Tree = Nil Then
Begin
New(Baru);
Baru^.Nilai := Data;
Baru^.Kanan := Nil;
Baru^.Kiri := Nil;
Tree := Baru;
End
Else if Data > Tree^.Nilai Then
Sisip_Tree(Tree^.Kanan,Data)
Else if Data < Tree^.Nilai Then
Sisip_Tree(Tree^.Kiri,Data)
Else Writeln('Data ',Data,' Sudah Ada.....');
End;
{=================== TELUSUR SECARA IN ORDER =========================}
Procedure In_Order(Tree : Pointer);
Begin
if Tree <> Nil Then
Begin
In_Order(Tree^.Kiri);
Write(Tree^.Nilai:3);
In_Order(Tree^.Kanan);
End;
End;
{==================== TELUSUR SECARA POST ORDER ======================}
Procedure Post_Order(Tree : Pointer;var k : integer);
Begin
if Tree <> Nil Then
Begin
Post_Order(Tree^.Kiri,k);
Post_Order(Tree^.Kanan,k);
Write(Tree^.Nilai:3);
k:=k+Tree^.Nilai; {===> HITUNG JUMLAH SEMUA NODE }
End;
End;
{== TELUSUR SECARA PRE ORDER ==}
Procedure Pre_Order(Tree : Pointer);
Begin
if Tree <> Nil Then
Begin
Write(Tree^.Nilai:3);
Pre_Order(Tree^.Kiri);
Pre_Order(Tree^.Kanan);
End;
End;
{================= HITUNG JUMLAH NODE SEBELAH KIRI ===================}
Function Jumlah_Kiri(Tree : Pointer) : integer;
Var
p : Pointer;
k : Integer;
Begin
k:=0;
58
p:=Tree;
While p <> nil do
Begin
k:=k+p^.Nilai;
p:=p^.kiri;
end;
Jumlah_Kiri:=k;
End;
{================= HITUNG JUMLAH NODE SEBELAH KANAN ==================}
Function Jumlah_Kanan(Tree : Pointer) : integer;
Var
p : Pointer;
k : Integer;
Begin
k:=0;
p:=Tree;
While p <> nil do
Begin
k:=k+p^.Nilai;
p:=p^.kanan;
end;
Jumlah_Kanan:=k;
End;
{=========== HITUNG SEMUA JUMLAH NODE SEBELAH KANAN DAN ==============}
{============ APABILA KANAN TELAH NIL MAKA KE NODE KIRI =============}
Function Jumlah_Kanan_Kiri(Tree : Pointer) : integer;
Var
p : Pointer;
k,l : Integer;
Begin
k:=0;
p:=Tree;
While p <> nil do
Begin
k:=k+p^.Nilai;
if p^.Kanan <> Nil then p:=p^.Kanan
else
p:=p^.Kiri;
end;
Jumlah_Kanan_Kiri:=k;
End;
{======================= PROGRAM UTAMA ==============================}
Var
Bil,i,Jum,JumNode : Integer;
Begin
New(Tree);
Tree := Nil;
Randomize;
Repeat
Bil:=Random(100);
Sisip_Tree(Tree,Bil);
write(Bil:4);
i:=i+1;
59
until i=10;
Writeln;
write('Cetak Secara IN ORDER');
Writeln;
In_Order(Tree);
Writeln;writeln;
write('Cetak Secara Post ORDER');
Writeln;
Post_Order(Tree,JumNode);
Writeln;writeln;
write('Cetak Secara PRE ORDER');
Writeln;
Pre_Order(Tree);
Writeln;Writeln;
Writeln('Jumlah seluruh Node sebelah kiri ');
Jum:=Jumlah_Kiri(Tree);
writeln('Nilai Jumlah = ',Jum);
writeln;
Writeln('Jumlah seluruh Node sebelah Kanan ');
Jum:=Jumlah_Kanan(Tree);
writeln('Nilai Jumlah = ',Jum);
writeln;
Writeln('Jlh Node Kanan semua kemudian Kiri satu node
sebelumnya');
Jum:=Jumlah_Kanan_Kiri(Tree);
writeln('Nilai Jumlah = ',Jum);
writeln;
Writeln('Jumlah Seluruh Node Pada Tree ');
writeln('Nilai Jumlah = ',JumNode);
end.
========================================================================



========================================================================
Program Konversi_Bilangan;
Uses WinCrt;
Var
des,desi : integer;
Bin : String;
Begin
Write('Masukkan Suatu Bilangan Desimal :');Readln(des);
desi:=des;
bin:='';
repeat
if(des mod 2 = 0) then bin:='0'+bin
else bin:='1' + bin;
des:=des div 2;
until des=0;
writeln('(',desi,') desimal =',bin,' (Biner)');
end.
=========================================================================



=========================================================================
Program Koversi_nilai;
uses wincrt;
var
nilai :integer;
lagi :char;
begin
repeat
clrscr;
Write('Masukkan nilai :');readln(nilai);
case nilai of
81..100 :writeln('A');
61..80 :writeln('B');
41..60 :writeln('C');
21..40 :writeln('D');
0..20 :writeln('E');
else
writeln('Salah nilai');
end;
write('Lagi.....[Y/T]');lagi:=upcase(readkey);
writeln(lagi);
until lagi <> 'Y';
end.
========================================================================



========================================================================
Program Konversi_Bilangan_Desimal_ke_Biner1;
uses wincrt;
var
des,rita :integer;
bin :string;
lagi :char;
begin
repeat
clrscr;
write('Masukkan bilangan Desimal =');read(des);
rita:=des;
bin:=' ';
repeat
if(des mod 2 =0) then
bin:='0'+bin
else
bin:='1'+bin;
des:=des div 2;
until des = 0;
writeln(' (',rita,') desimal =' ,bin,' (biner)');
write('Lagi ...... [Y/T]');lagi:=upcase(readkey);
writeln(lagi);
until lagi <> 'Y';
end.
=======================================================================



=======================================================================
program faktorial;
uses wincrt;
var
faktor :real;
i,n :integer;
begin
write('Masukkan bilangan n =');readln(n);
faktor:=1;
for i:= 2 to n do{Menghitung n faktorial}
faktor:=faktor*i;
writeln(n,' Faktorial = ',faktor:0:0);
end.
=======================================================================



=======================================================================

Program menggabung 2 Array dan hasilnya menaik;
uses wincrt;
const a:array[1..6] of integer =(2,5,8,11,14,17);
b:array[1..8] of integer =(4,5,7,9,11,12,30,45);
var gabung:array[1..14] of integer;
i,j,k,l,bel:integer;
begin
for i:=1 to 8 do gabung[i]:=b[i];
bel:=8;
for i:=1 to 6 do begin
j:=1;
while gabung[j]<= a[i] do inc(j);
inc(bel);k:=j;
for l:=bel downto k do
gabung[l]:=gabung[l-1];
gabung[k]:=a[i];
end;
for i:=1 to 14 do write(gabung[i],' ');
end.
=======================================================================
======================================================================
Program menggabung 2 Array dan hasilnya Menurun;
uses wincrt;
const a:array[1..6] of integer =(2,5,8,11,14,17);
b:array[1..8] of integer =(4,5,7,9,11,12,30,45);
var gabung:array[1..14] of integer;
i,j,k,l,bel:integer;
begin
j:=0;
for i:=8 downto 1 do begin
inc(j);
gabung[j]:=b[i];
end;
bel:=8;
for i:=1 to 6 do
begin
j:=1;
while a[i]<=gabung[j] do inc(j);
inc(bel);k:=j;
for l:=bel downto k do
gabung[l]:=gabung[l-1];
gabung[k]:=a[i];
end;
for i:=1 to 14 do write(gabung[i],' ');
end.
{45 30 17 14 12 11 11 9 8 7 5 5 4 2}
===================================================================



====================================================================
Program masuk pointer dari belakang;
uses wincrt;
type
ptr=^data;
data =record
nilai:char;
ekor:ptr;
end;
var
erwin,baru,B:ptr;
lagi,x :char;
{--------------------------------------------------------------------}
Procedure masbel(var erwin:ptr; x:char);
var
baru,b:ptr;
begin
new(baru);
baru^.nilai:=x;
baru^.ekor:=nil;
if erwin=nil then
erwin:=baru
else
begin
b:=erwin;
while b^.ekor<>nil do
b:=b^.ekor;
b^.ekor:=baru;
b:=baru;
end;
end;
{--------------------------------------------------------------------}
procedure masdep(var erwin:ptr; x:char);
var
baru:ptr;
begin
new(baru);
baru^.nilai:=x;
baru^.ekor:=nil;
if erwin=nil then
erwin:=baru
else
begin
baru^.ekor:=erwin;
erwin:=baru;
end;
end;
{--------------------------------------------------------------------}
procedure tampil(erwin:ptr);
var
b:ptr;
begin
b:=erwin;
64
while (b<> nil) and (b^.nilai <> ' ') do
begin
write(b^.nilai,' ');
b:=b^.ekor;
end;
writeln;
end;
{--------------------------------------------------------------------}
var
kata:char;
i,n :integer;
begin
new(erwin);
erwin:=nil;
repeat
write('Masukkan data : ');kata:=readkey;writeln(kata);
if kata<>#13 then
masbel(erwin,kata);
until kata=#13;
tampil(erwin);
writeln;
for i:= 1 to 3 do
begin
write('Masukkan dari belakang
:');kata:=readkey;writeln(kata);
masbel(erwin,kata);
end;
tampil(erwin);
writeln;
for i:= 1 to 3 do
begin
write('Masukkan dari depan :');kata:=readkey;writeln(kata);
masdep(erwin,kata);
end;
writeln;
tampil(erwin);
writeln;
end.
=======================================================================



========================================================================
Program membalik isi Queue;
uses wincrt;
const max=5;
{--------------------------deklarasi queue----------------------------}
type
list=^node;
node=record
isi:integer;
next:list;
end;
queue=record
dep,bel:list;
end;
{---------------------------deklarasi stack---------------------------}
type
stack=record
isi:array[1..max] of integer;
top:0..max;
end;
{----------------------------deklarasi variabel-----------------------}
var q:queue;
s:stack;
h,i:integer;
{=====================Procedure-procedure untuk queue=================}
Procedure init_Queue(var q:queue);
begin
q.dep:=nil;q.bel:=nil;
end;
{---------------------------------------------------------------------}
Procedure EnQueue(data:integer; var q:queue);
var b:list;
begin
new(b);b^.isi:=data;b^.next:=nil;
if q.bel=nil then begin
66
q.bel:=b;q.dep:=b;
end;
else begin
q.bel^.next:=b;q.bel:=b;
end;
end;
{---------------------------------------------------------------------}
Procedure DeQueue(var q:queue; var h:integer);
var
b:list;
begin
if q.dep<>nil then begin
h:=q.dep^.isi;b:=q.dep;
q.dep:=b^.next;
if q.dep=nil then q.bel:=nil;
end;
end;
{---------------------------------------------------------------------}
procedure tampilQueue(q:queue);
begin
h:=0;
repeat
DeQueue(q,h);
write(h,' ');
until q.dep=nil;
end;
{=====================Procedure-procedure untuk stack=================}
procedure initstack(var s:stack);
begin
s.top:=0;
end;
{---------------------------------------------------------------------}
procedure push(h:integer;var s:stack);
begin
if s.top<max then begin
inc(s.top);
s.isi[s.top]:=h;
end;
end;
{---------------------------------------------------------------------}
procedure pop(var h:integer;var s:stack);
begin
if s.top>0 then begin
h:=s.isi[s.top];
dec(s.top);
end;
end;
{=========================Procedure membalik==========================}
procedure balik(var q:queue;var s:stack);
begin
repeat
dequeue(q,h);
push(h,s);
until q.dep=nil;
67
repeat
pop(h,s);
enqueue(h,q);
until s.top=0;
end;
{==========================Program utama==============================}
begin
clrscr;
init_Queue(q);initstack(s);
writeln('Masukkan data ke dalam queue');
for i:=1 to max do begin
write('Nilai data : ');readln(h);
EnQueue(h,Q);
end;
write('Isi Queue sebelum dibalik : ');
tampilqueue(q);
balik(q,s);
writeln;
write('Isi Queue sesudah dibalik : ');
tampilqueue(q);
end.
=======================================================================



=======================================================================
Program Queue Statis;
uses wincrt;
const max=10;
type
queue=record
isi:array[1..max] of integer;
depan,belakang:0..max;
end;
Procedure init_Queue(var q:queue);
begin
q.depan:=1;q.belakang:=0;
end;
{--------------------------------------------------------------------}
procedure EnQueue(data:integer; var q:queue);
var sisip :boolean;
i,j,pos:integer;
begin
sisip:=false;
68
i:=q.depan;
while (q.isi[i]<>0) and (data>=q.isi[i]) do inc(i);
if data<q.isi[i] then
begin
pos:=i;
for j:=q.belakang downto pos do
q.isi[j+1]:=q.isi[j];
q.isi[pos]:=data;
inc(q.belakang);
end
else
if q.belakang<max then begin
inc(q.belakang);
q.isi[q.belakang]:=data;
end;
end;
{--------------------------------------------------------------------}
Procedure DeQueue(var q:queue; var hsl:integer);
var
i:integer;
begin
if q.belakang>0 then begin
hsl:=q.isi[q.depan];
dec(q.belakang);
for i:=1 to q.belakang do
q.isi[i]:=q.isi[i+1] ;
end;
end;
{--------------------------------------------------------------------}
var x:integer;
q:queue;
i:integer;
begin
clrscr;
init_Queue(q);
writeln('Memasukkan data ke dalam queue');
repeat
write('Nilai data : ');readln(x);
if x<>0 then EnQueue(x,Q);
until x=0;
writeln;
readln;
writeln('Pengambilan data dari queue !');
x:=0;
repeat
DeQueue(Q,x);writeln(x);
until q.belakang<1;
{readln;
69
x:=0;
writeln('Pengambilan data dari queue yang kedua kali');
repeat
DeQueue(Q,x);writeln(x);
until q.belakang=0;}
end.
Hasilnya adalah:
program pangkat;
Uses Wincrt;
Function Pkt(X :real;n : integer):real;
var t : real;
m : integer;
Begin
m:=abs(n);
if (x<>0) and (n=0) then pkt:=1
else if n >0 then
pkt:=x*pkt(x,n-1)
else if (n < 0) then pkt := 1/(x*pkt(x,m-1));
end;
var x : real;
n : integer;
begin
write('Bilangan yang dipangkatkan : ');readln(x);
write('Bilangan pangkat : ');readln(n);
writeln(x:5:2,' Pangkat ',n,' = ',Pkt(x,n):8:3);
end.
Hasilnya adalah:
70
{Program post order }
uses wincrt;
type
ptr=^Simpul;
simpul=record
data:integer;
kanan,kiri:ptr;
end;
procedure Init(var p:ptr);
begin
p:=nil;
end;
{--------------------------------------------------------------------}
procedure masukdata(var p:ptr; d:integer);
begin
if p=nil then
begin
new(p);
p^.data:=d;
p^.kiri:=nil;
p^.kanan:=nil;
end
else
if p^.data < d then
masukdata(p^.kanan,d)
else
masukdata(p^.kiri,d);
end;
{--------------------------------------------------------------------}
procedure postorder(p:ptr);
begin
if p<>nil then
begin
postorder(p^.kiri);
postorder(p^.kanan);
writeln(p^.data);
end;
end;
{--------------------------------------------------------------------}
var
pohon:ptr;
dt :integer;
begin
init(pohon);
repeat
write('Data masuk ke :');readln(dt);
if dt >= 0 then
masukdata(pohon,dt);
until dt<0;
writeln;
postorder(pohon);
end.
71
Hasilnya adalah:
{Program Tree Dinamis dengan TYPE CHARACTER }
uses wincrt;
Type pohon=^node;
node=record
data:char;
kiri,kanan:pohon;
end;
var T:pohon;
info:char;
{--------------------------------------------------------------------}
Procedure Buat_BST(info :char;var T:pohon);
var
b:pohon;
begin
if T=nil then
begin
new(b);b^.data:=info;b^.kiri:=nil;b^.kanan:=nil;
T:=b;
end
else
begin
if ord(T^.data)<ord(info) then
Buat_Bst(info,T^.kanan)
else
Buat_Bst(info,T^.kiri)
end;
end;
{--------------------------------------------------------------------}
Procedure Baca_BST_pre(b:pohon);
begin
if b<>nil then
begin
write(b^.data);
Baca_BST_pre(b^.kiri);
Baca_BST_pre(b^.kanan);
end;
end;
{--------------------------------------------------------------------}
Procedure Baca_BST_in(b:pohon);
begin
72
if b<>nil then
begin
Baca_BST_in(b^.kiri);
write(b^.data);
Baca_BST_in(b^.kanan);
end;
end;
{--------------------------------------------------------------------}
Procedure Baca_BST_post(b:pohon);
begin
if b<>nil then
begin
Baca_BST_post(b^.kiri);
Baca_BST_post(b^.kanan);
write(b^.data);
end;
end;
{--------------------------------------------------------------------}
begin
clrscr;
new(T);T^.kiri:=nil;T^.kanan:=nil;
writeln('Memasukkan data ke dalam tree');
repeat
write('Nilai data : ');info:=upcase(readkey);writeln(info);
if info<>#13 then Buat_BST(info,T);
until info=#13;
writeln;
readln;
writeln('Pembacaan secara Pre order');
baca_BST_pre(T);
writeln;
readln;
writeln('Pembacaan secara In order');
baca_BST_in(T);
writeln;
readln;
writeln('Pembacaan secara Post order');
baca_BST_post(T);
end.
Hasilnya adalah:
Program Romawi;
73
Uses WinCrt;
Const
Rom : array [1..13] of String =
('M','CM','D','CD','C','XC','L','XL','X','IX','V','IV','I');
Des : array [1..13] of integer =
(1000,900,500,400,100,90,50,40,10,9,5,4,1);
Var
Bil,i,Bil1 : Integer;
Roma : String;
Begin
Write('Masukkan Suatu Bilangan [1..3999] : ');
Readln(Bil);
Bil1 := Bil;
if (Bil > 0) and (Bil < 4000) then
Begin
For i:=1 to 13 do
Begin
while (Bil >= Des[i]) do
Begin
Bil := Bil - Des[i];
Roma := Roma + Rom[i]
End;
End;
Write('Desimal ',Bil1,' Romawinya ',Roma)
end
else
Writeln('Tidak Diketahui Simbol Romawinya.....');
End.
Hasilnya adalah:
{Program Mahasiswa}
uses wincrt;
const Nmaks=55;
Type
TypeMhs=Record
Nama:string[25];
IP :real;
end;
TypeArray=Array[1..Nmaks]of typemhs;
TypePtr=^TypeArray;
Var
P:TypePtr;
JumlahMHs,Indeks:Integer;
begin
new(P);
write('Masukkan Jumlah Mahasiswa : ');readln(jumlahMhs);
74
Indeks:=0;
repeat
indeks:=indeks+1;
write('Nama : ');readln(P^[indeks].nama);
write('IP : ');readln(P^[indeks].IP);
until indeks=jumlahMhs;
end.
Hasilnya adalah:
program mencari_rata2;
uses wincrt;
procedure Mean;
var
n,x,i,tot :integer;
Rata :real;
lagi :char;
begin
repeat
clrscr;
write('Masukkan bilangan :');readln(n);
tot:=0;
for i:=1 to n do
begin
write('Masukkan bilangan ke:',i,' ');readln(x);
tot:=tot+x;
end;
Rata:=tot/n;
Writeln('Rata-rata :',Rata:0:2);
writeln('Lagi....? [Y/T]');lagi:=upcase(readkey);
writeln(lagi);
until lagi <> 'Y';
end;
begin
Mean;
end.
Hasilnya adalah:
Program Untuk_menghitung_Jumlah_suku_ke_Data;
75
uses wincrt;
Var
n,i:integer;
y:real;
jum:real;
begin
clrscr;
write('Masukkan Banyak Data =');readln(n);
writeln;
jum:=0;
for i:= 1 to n do
begin
y:=1/exp((i-1)*ln(2));
if i mod 2=0 then y:=-y;
jum:=jum+y;
writeln(y:0:4);
writeln;
end;
writeln('Jumlah n=',n,' Suku deret = ',jum:0:4);
end.
Hasilnya adalah:
program kalkulator;
uses wincrt;
var n1,n2,p,h:real;
begin
writeln('Program Kalkulator');
writeln('==================');
write('Masukkan Nilai Pertama= ');readln(n1);
write('Masukkan Nilai Kedua= ');readln(n2);
writeln('Pilih Operasi:');
writeln('1 --> Perkalian');
writeln('2 --> Pembagian');
writeln('3 --> Penjumlahan');
writeln('4 --> Pengurangan');
write('Pilihan anda [1..4]= ');readln(p);
if p=1 then h:=n1*n2;
if p=2 then h:=n1/n2;
if p=3 then h:=n1+n2;
76
if p=4 then h:=n1-n2;
writeln('Hasil Operasinya Adalah= ',h:0:2);
readln;
end.
Hasilnya adalah:
program tulisan;
uses wincrt;
var t:string;
x,y,z:integer;
begin
write('Masukkan suatu kata= ');readln(t);
x:=length(t);
for y:=0 to x do
begin
for z:=1 to x-y do
write(' ',t[z]);
writeln;
end;
readln;
end.
Hasilnya adalah:
Program Menghitung_Luas;
uses wincrt;
Var P, L, Luas :Real;
Begin
writeln('Program Menghitung Luas Persegi Panjang');
writeln('=======================================');
write('Panjang = ');
77
readln(P);
write('Lebar = ');
readln(L);
writeln;
Luas:=P*L;
writeln('Jadi Luasnya=',Luas:0:2);
readln;
End.
Hasilnya adalah:
Program Menghitung_Volume_Luas_Permukaan_Bola;
uses wincrt;
Var Luas,R,V :Real;
Begin
writeln('Program Menghitung_Volume_Luas_Permukaan_Bola');
write('Jari-jari = '); {Masukan Nilai Jari2}
readln(R);
Luas:=4*pi*R*R;
V:=4/3*pi*R*R*R;
writeln('Jadi Volumenya = ',V:0:2);
writeln('Jadi Luasnya = ',Luas:0:2);
readln;
End.
Hasilnya adalah:
Program Nilai_Maximum_Minimum;
uses wincrt;
var a : array[1..100] of integer;
b,c : integer; jumlah:longint;
min,max : real;
begin
writeln('Mencari Nilai Maximum dan Minimum');
writeln('=================================');
write('Banyak Data yang akan diinput : ');read(b);
jumlah:=0;
for c:=1 to b do
begin
write('Masukkan data ke-',c,' = ');readln(a[c]);
jumlah:=jumlah+a[c];
78
end;
begin
max:=a[1];
min:=a[1];
for c:=2 to b do
if a[c]>max then max:=a[c]
else if a[c]<min then min:=a[c];{mencari nilai maximum dan
minimum}
writeln('');
writeln('Nilai Minimum = ',min:0:2);
writeln('Nilai Maximum = ',max:0:2);
readln;
end;
end.
Hasilnya adalah:
program menentukan_positif_negatif;
uses wincrt;
var pos,neg,data : integer;
Begin
Repeat
write('Data = ');readln(data);
if (data>0) then inc(pos);
if (data<0) then inc(neg);
until (data=0);
Writeln('Nilai Positifnya = ',pos);
Writeln('Nilai negatifnya = ',neg);
end.
Hasilnya adalah:
program antrian;
79
uses wincrt;
const max = 20;
type elemen = array[1..max] of char;
typequeue = record
isi : elemen;
depan,blk : integer;
end;
label ulang;
var
queue,q : typequeue;
d,jawab : char;
pil : integer;
selesai : boolean;
procedure buatQ(var q : typequeue);
begin
q.depan := max;
q.blk := max;
end;
function qkosong(q:typequeue):boolean;
begin
qkosong:= (q.depan = q.blk);
end;
function Qpenuh(q:typequeue):boolean;
var next : integer;
begin
if q.blk = max then next:=1
else
next := q.blk + 1;
qpenuh := (next=q.depan);
end;
procedure Enqueue(var q:typequeue; e:char);
begin
if not(qpenuh(q)) then
begin
if q.blk = max then q.blk :=1
else q.blk := q.blk+1;
q.isi[q.blk]:= e;
end;
end;
procedure Dequeue(var q:typequeue; var ed:char);
begin
if not(qkosong(q)) then
begin
if q.depan = max then q.depan :=1
else q.depan := q.depan+1;
ed := q.isi[q.depan];
end;
end;
procedure tampil(q: typequeue);
80
var i,awal : integer;
begin
CLRSCR;
writeln('Antrian Ke Data');
if q.depan = max then awal :=1
else awal := q.depan +1;
for i:=awal to q.blk do
writeln(i:3,' ':5,q.isi[i],' ');
READLN;
end;
procedure menu;
begin
clrscr;
writeln(' MENU');
writeln;
writeln;
writeln('(1) Tambah Data');
writeln('(2) Ambil Data');
writeln('(3) Tampil Data');
writeln('(0) Exit');
writeln;
end;
begin
ulang:
buatQ(q);
repeat
menu;
write('Masukkan pilihan (0-3) : '); readln(pil);
CLRSCR;
case pil of
1 : begin
if Qpenuh(q)= false then
begin
write('Masukkan karakter ke dalam antrian : ');
readln(d);
Enqueue(q,d);
TAMPIL(Q);
end else
writeln('Antrian sudah penuh silahkan ambil keluarkan
pada posisi paling depan');
end;
2 : begin
if qkosong(q)= false then
begin
Dequeue(q,d);
tampil(q);
end
else writeln('Antrian dalam kondisi kosong');
end;
3 : tampil(q);
0 : selesai := true;
end;
81
writeln;
write('Enter untuk kembali');
readln;
until selesai;
clrscr;
writeln;
write('Anda akan mencoba lagi [Y/T] : '); readln(jawab);
if upcase(jawab) = 'Y' then goto ulang;
clrscr;
writeln(' END');
end.
Hasilnya adalah:
program exercises;
uses wincrt;
var a,b,c : integer;
d : (red,blue,green);
x,y,z : real;
m,n : boolean;
p : char;
begin
a:=10;
b:=-15;
c:=7;
d:=red;
x:=1.52E1;
y:=0.3;
z:=-5.1E3;
m:=true;
n:=false;
p:='a';
writeln('EXERCISES 1');
writeln('(a) Hasil = ',(abs(b - 10)+ a mod (c - 1)));
writeln('(b) Hasil = ',(a + 103 div sqr(a - c)));
writeln('(c) Hasil = ',pred(a * 6 + b div 5));
writeln('(d) Hasil = ',succ(red) = blue);
writeln('(e) Hasil = ',(2 + a * b mod c + 1) < 2);
writeln('EXERCISES 2');
writeln('(a) Hasil = ',trunc(x * y + 1.0) - a);
writeln('(b) Hasil = ',x / y * 3.4 + z);
writeln('(c) Hasil = ',abs(sqr(sin(y ) + cos(y)) - 0.5));
writeln('(d) Hasil = ',round(x) div round(y + 1.6) + b);
writeln('(e) Hasil = ',exp(c - 4));
writeln('EXERCISES 3');
writeln('(a) Hasil = ',m and not n);
82
writeln('(b) Hasil = ',(a > b) and (b > c) or not (c = 7));
writeln('(c) Hasil = ',not odd(c) and m);
writeln('(d) Hasil = ',(x > 0.0) or (y > 0.0) and (z > 0.0));
writeln('(e) Hasil = ',chr(succ(ord(p))));
end.
Hasilnya adalah:
program titik1;
uses wincrt;
var i,j,n,sp : integer;
Begin
clrscr;
n := 5;
for i:=1 to n do
begin
if (i mod 2 = 1) then
begin
for j:=1 to ((n-i) div 2) do
write(' ');
for j:=1 to i do
write('*');
writeln;
end;
end;
readln;
end.
Hasilnya adalah:
program gambar_titik;
83
uses wincrt;
var i,j,n : integer;
begin
write('Masukan nilai n = ');readln(n);
writeln('Bentuk gambarnya');
i:=(2-(n mod 2));
repeat
for j:=1 to (n-i) div 2 do write(' ');
for j:=1 to (n-(2*((n-i) div 2))) do write('*');
writeln;
i:=i+2;
until (i>n)
end.
Hasilnya adalah:
program gambar_titik2;
uses wincrt;
var i,j,n : integer;
begin
write('Masukan nilai n = ');readln(n);
writeln('Bentuk gambarnya');
i:=(2-(n mod 2));
repeat
for j:=1 to (abs(n-i) div 2) do write(' ');
for j:=1 to (n-(2*(abs(n-i) div 2))) do write('*');
writeln;
I:=i+2;
until (i>(n*2))
end.
Hasilnya adalah:
program gambar_titik3;
84
uses wincrt;
var n,i,ii,j,x,sp : integer;
begin
n:=5;
if (n mod 2 = 1) then
ii:=1
else
ii:=2;
i:=1;
repeat
sp:=abs((n-i)) div 2;
for j:=1 to sp do
begin
write(' ');
end;
for x:=1 to i+(2*(n-i)) do
begin
write('*');
end;
writeln;readln;
i:=i+2;
until (i>=(2*n));
end.
Hasilnya adalah:
Program DblLinkLingkar;
uses wincrt;
type
Point = ^node;
node = record
isi : integer;
next: point;
prev: point;
end;
var
P : point;
Procedure TamDepan( var A : point ; nilai : integer);
var
baru : point;
begin
new(baru);
baru^.isi := nilai;
baru^.prev:= nil;
baru^.next:= nil;
if A = nil then
begin
A := baru;
85
A^.next := A;
A^.prev := A;
end
else
begin
baru^.next := A;
baru^.prev := A^.prev;
A^.prev^.next := baru;
A^.prev := baru;
A := baru;
end;
end;
Procedure TamBelakang( var A : point ; nilai : integer);
var
baru : point;
begin
new(baru);
baru^.isi := nilai;
baru^.prev:= nil;
baru^.next:= nil;
if A = nil then
begin
A := baru;
A^.next := A;
A^.prev := A;
end
else
begin
baru^.next := A;
baru^.prev := A^.prev;
A^.prev^.next := baru;
A^.prev := baru;
end;
end;
{**********************************************************
* Procedure menampilkan isi Link list *
**********************************************************}
Procedure Tampil(A : point);
var
bantu : point;
begin
bantu := A;
repeat
write(bantu^.isi,',');
bantu:=bantu^.next;
until bantu = A;
end;
Procedure InsertDepan(var A:point);
var
i, jum, data : integer;
begin
write('Jumlah data :');readln(jum);
86
for i:=1 to jum do
begin
write('Nilai data ke-[',i,'] :');readln(data);
TamDepan(A,data);
end;
end;
Procedure InsertBelakang(var A:point);
var
i, jum, data : integer;
begin
write('Jumlah data :');readln(jum);
for i:=1 to jum do
begin
write('Nilai data ke-[',i,'] :');readln(data);
TamBelakang(A,data);
end;
end;
begin
writeln('Menambah data depan');
InsertDepan(P);
write('Hasilnya -->');
tampil(P);
writeln;
writeln('Menambah data belakang');
InsertBelakang(P);
write('Hasilnya Akhir -->');
Tampil(P);
end.
Hasilnya adalah:
program baris_kolom;
uses wincrt;
procedure gb(brs,kol : integer);
var i,j : integer;
begin
for i:=1 to brs do
begin
for j:=1 to kol do
begin
if((i=1) or (i=brs) or (j=1) or (j=kol)) then write('*')
87
else write(' ');
end;
writeln;
end;
end;
var x,y : integer;
begin
write('Banyak baris = ');readln(y);
write('Banyak kolom = ');readln(x);
writeln('Bentuknya :');
gb(y,x);
end.
Hasilnya adalah:
Program Hapus_Node;
uses wincrt;
type
point = ^node;
node = record
isi : integer;
next : point;
end;
var
P : point;
{**************************************************************
* Procedure tambah node pada linked list *
**************************************************************}
Procedure InsertDepan(var A : point; nilai : integer);
var
baru : point;
begin
new(baru);
baru^.isi := nilai;
baru^.next := nil;
if A = nil then
A := baru
else
begin
baru^.next := A;
A := baru;
88
end;
end;
{**************************************************************
* Procedure tambah node pada linked list *
**************************************************************}
Procedure InsertBelakang(var A : point; nilai : integer);
var
baru, bantu : point;
begin
new(baru);
baru^.isi := nilai;
baru^.next := nil;
if A = nil then
A := baru
else
begin
bantu := A;
while bantu^.next<>nil do
bantu := bantu^.next;
baru^.next := bantu^.next;
bantu^.next := baru;
end;
end;
{**************************************************************
* Procedure mencetak linked list *
**************************************************************}
Procedure Cetak(A : point);
var
bantu : point;
begin
write('Isi linked list --> :');
bantu := A;
while bantu <> nil do
begin
write(bantu^.isi);
if bantu^.next<>nil then write(',');
bantu := bantu^.next;
end;
writeln('');
end;
{**************************************************************
* Procedure menambah node pada linked list *
**************************************************************}
Procedure InsertD(var A : point);
var
i, jum, nilai :integer;
begin
write('Jumlah Data :');readln(jum);
for i:=1 to jum do
begin
89
gotoXY(1,15);write('Data ke[',i,'] :');readln(nilai);
InsertDepan(A, nilai);
end;
end;
{**************************************************************
* Procedure menambah node pada linked list *
**************************************************************}
Procedure InsertB(var A : point);
var
i, jum, nilai :integer;
begin
write('Jumlah Data :');readln(jum);
for i:=1 to jum do
begin
gotoXY(1,15);write('Data ke[',i,'] :');readln(nilai);
InsertBelakang(A, nilai);
end;
end;
{**************************************************************
* Procedure menghapus node pada linked list *
**************************************************************}
Procedure Hapus(var A : point; nilai : integer);
var
bantu, hapus : point;
begin
bantu := A;
hapus := A;
while bantu <> nil do
begin
if nilai = bantu^.isi then
begin
bantu:=hapus^.next;
dispose(hapus);
hapus := bantu;
A:=bantu;
end
else
begin
hapus:=hapus^.next;
if (bantu^.next<>nil) and (nilai = hapus^.isi) then
begin
bantu^.next:=hapus^.next;
dispose(hapus);
hapus:=bantu;
end
else
bantu:=bantu^.next;
end;
end;
end;
{**************************************************************
90
* Procedure menghapus node *
**************************************************************}
Procedure HapusNode(var A : point );
var
nilai :integer;
begin
writeln('');
write('Node yang akan dihapus :');readln(nilai);
Hapus(A, nilai);
writeln('Node sudah dihapus..')
end;
{**************************************************************
* Program Utama *
**************************************************************}
Procedure Judul;
const
garis = '===========================================';
begin
writeln(garis);
writeln('| MENU UTAMA |');
writeln(garis);
writeln('| 1. Tambah depan |');
writeln('| 2. Tambah belakang |');
writeln('| 3. Menampilkan linked list |');
writeln('| 4. Menghapus node pada linked list |');
writeln('| 5. Membuat linked list secara random |');
writeln('| 6. Menghapus linked list |');
writeln(garis);
end;
{**************************************************************
* Procedure linked list secara random *
**************************************************************}
Procedure linkedRandom;
var
i,n,m : integer;
begin
write('Jumlah elemen yang diinginkan :');readln(n);
write('range yang diinginkan :');readln(m);
for i:=1 to n do
insertDepan(P,random(m));
end;
{**************************************************************
* Procedure menu *
**************************************************************}
Procedure Menu;
var
jawab : char;
Pilih,x : integer;
begin
jawab := 'Y';
repeat
91
clrscr;
Judul;
write('Pilihan 1,2,3,4,5,6 atau 0 --> Exit ! : ');readln(Pilih);
case Pilih of
0 : jawab:='T';
1 : begin
InsertD(P);
Cetak(P);
end;
2 : begin
InsertB(P);
Cetak(P);
end;
3 : cetak(P);
4 : begin
HapusNode(P);
Cetak(P);
end;
5 : linkedrandom;
6 : begin
dispose(P);
P:=nil;
end;
else writeln('Ma''af Anda salah Pilih..!');
end;
writeln('Tekan sebarang tombol untuk lanjut...!');
readkey;
until jawab='T';
clrscr;
write('Terima Kasih..!');
end;
{**************************************************************
* Program Utama *
**************************************************************}
begin
menu;
dispose(P);
end.
program matrik;
uses wincrt;
type data = array[1..10,1..10] of integer;
var matrikI,matrikII : data;
baris,kolom,pil : integer;
procedure isimatrik;
var i,j : integer;
begin
writeln('Penentuan ORDO MATRIK I');
write('Masukan banyak baris matrik I = ');readln(baris);
92
write('Masukan banyak kolom matrik I = ');readln(kolom);
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
readln(matrikI[i,j]);
end;
clrscr;
writeln('Penentuan ORDO MATRIK II');
write('Masukan banyak baris matrik II = ');readln(baris);
write('Masukan banyak kolom matrik II = ');readln(kolom);
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
readln(matrikII[i,j]);
end;
end;
procedure jumlahmatrik(m1,m2 : data);
var hasil : data;
i,j : integer;
begin
for i:=1 to baris do
for j:=1 to kolom do
begin
hasil[i,j]:=m1[i,j]+m2[i,j];
end;
clrscr;
writeln('Hasil Penjumlahan MATRIK');
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
write(hasil[i,j]);
end;
end;
procedure kurangmatrik(m1,m2 : data);
var hasil : data;
i,j : integer;
begin
for i:=1 to baris do
for j:=1 to kolom do
begin
hasil[i,j]:=m1[i,j]-m2[i,j];
end;
clrscr;
writeln('Hasil Penjumlahan MATRIK');
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
write(hasil[i,j]);
end;
end;
procedure kalimatrik(m1,m2 : data);
var hasil : data;
i,j,z : integer;
93
begin
for i:=1 to baris do
for j:=1 to kolom do
begin
hasil[i,j]:=0;
for z:=1 to baris do
hasil[i,j]:=hasil[i,j]+matrikI[i,z]*matrikII[z,j];
end;
clrscr;
writeln('Hasil Penjumlahan MATRIK');
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
write(hasil[i,j]);
end;
end;
begin
writeln(' M E N U');
writeln('(1) Penjumlahan Matrik');
writeln('(2) Pengurangan Matrik');
writeln('(3) Perkalian Matrik');
write('Pilihan = ');readln(pil);
clrscr;
case pil of
1 : begin
isimatrik;
jumlahmatrik(matrikI,matrikII);
end;
2 : begin
isimatrik;
kurangmatrik(matrikI,matrikII);
end;
3 : begin
isimatrik;
kalimatrik(matrikI,matrikII);
end;
end;
end.
Hasilnya adalah:
program pecahan;
uses wincrt;
var
uang,pecah1,pecah2,pecah3,pecah4,pecah5,pecah6,pecah7,pecah8,pecah9,pecah10
: longint;
begin
94
write('TOTAL Belanja = ');readln(uang);
pecah1:=uang div 100000;
uang:=uang mod 100000;
pecah2:=uang div 50000;
uang:=uang mod 50000;
pecah3:=uang div 20000;
uang:=uang mod 20000;
pecah4:=uang div 10000;
uang:=uang mod 10000;
pecah5:=uang div 5000;
uang:=uang mod 5000;
pecah6:=uang div 1000;
uang:=uang mod 1000;
pecah7:=uang div 500;
uang:=uang mod 500;
pecah8:=uang div 100;
uang:=uang mod 100;
pecah9:=uang div 50;
uang:=uang mod 50;
pecah10:=uang div 25;
uang:=uang mod 25;
writeln('100000 ada ',pecah1);
writeln('50000 ada ',pecah2);
writeln('20000 ada ',pecah3);
writeln('10000 ada ',pecah4);
writeln('5000 ada ',pecah5);
writeln('1000 ada ',pecah6);
writeln('500 ada ',pecah7);
writeln('100 ada ',pecah8);
writeln('50 ada ',pecah9);
writeln('25 ada ',pecah10);
end.
Hasilnya adalah:
program permutasi;
uses wincrt;
type data = array[1..10] of char;
var
ax : data;
i,n : byte;
procedure permutasi(a : data; mulai : byte);
95
var
i : byte;
temp : char;
begin
if mulai=n then
begin
for i:=1 to n do
write(a[i]);
writeln;
end
else
begin
for i:= mulai to n do
begin
temp:=a[i];
a[i]:=a[mulai];
a[mulai]:=temp;
permutasi(a,mulai+1);
end;
end;
end;
begin
write('Masukan N (permutasi) = ');readln(n);
for i:=1 to n do
ax[i]:=chr(i+64);
permutasi(ax,1);
end.
Hasilnya adalah:
program pointer1;
uses wincrt;
type ptr = ^simpul;
simpul = record
data : string;
next : ptr;
end;
var list,baru,bantu : ptr;
i : integer;
begin
list := nil;
for i:=1 to 5 do
begin
new(baru);
write('Nama ke-',i);readln(baru^.data);
baru^.next:=list;
96
list:=baru;
end;
bantu:=list;
while bantu<>nil do
begin
writeln(bantu^.data);
bantu:=bantu^.next;
end;
end.
Hasilnya adalah:
Program Pointer2 ;
Uses
WinCrt ;
Type
Petunjuk_Pegawai = ^Data_Pegawai ;
Data_Pegawai = Record
Nip : String[9] ;
Nama : String[25] ;
Gaji : Real ;
End ;
Var
Data_Pegawaix : Array[1..20] of Petunjuk_Pegawai;
i, j, n : Byte ;
t1, t2 : String ;
t3 : Real ;
Begin
Write('Bayaknya data...? ') ; ReadLn(n);
For i := 1 to n do
Begin
Writeln;
Writeln('Data Pegawai ke ',i:2);
New(Data_Pegawaix[i]) ;
With Data_Pegawaix[i]^ do
Begin
Write('N I P..........: '); ReadLn(Nip) ;
Write('Nama Pegawai...: '); ReadLn(Nama) ;
Write('Gaji Pokok Rp '); ReadLn(Gaji) ;
End ;
97
End ;
ClrScr;
WriteLn(' DATA PEGAWAI PT. DAPUR NGEBUL
') ;
WriteLn('----------------------------------------------------') ;
WriteLn(' No. | N I P | NAMA PEGAWAI | GAJI POKOK ') ;
WriteLn('----------------------------------------------------') ;
For i := 1 to n do
With Data_Pegawaix[i]^ do
Writeln(i:3,' | ',Nip:9,' | ',Nama:25,' | Rp ',Gaji:8:2) ;
For i := 1 to n do
Begin
For j := i to n do
Begin
If Data_Pegawaix[i]^.Nip > Data_Pegawaix[j]^.Nip then
Begin
t1 := Data_Pegawaix[i]^.Nip ;
Data_Pegawaix[i]^.Nip := Data_Pegawaix[j]^.Nip ;
Data_Pegawaix[j]^.Nip := t1 ;
t2 := Data_Pegawaix[i]^.Nama ;
Data_Pegawaix[i]^.Nama := Data_Pegawaix[j]^.Nama ;
Data_Pegawaix[j]^.Nama := t2 ;
t3 := Data_Pegawaix[i]^.Gaji ;
Data_Pegawaix[i]^.Gaji := Data_Pegawaix[j]^.Gaji ;
Data_Pegawaix[j]^.Gaji := t3 ;
End ;
End ;
End ;
WriteLn('----------------------------------------------------') ;
WriteLn(' Soritng Berdasarkan NIP ') ;
WriteLn('----------------------------------------------------') ;
For i := 1 to n do
With Data_Pegawaix[i]^ do
Writeln(i:3,' | ',Nip:9,' | ',Nama:25,' | Rp ',Gaji:8:2) ;
WriteLn('----------------------------------------------------') ;
End. { Akhir program }
Hasilnya adalah:
98
Program Pointer3 ;
Uses
WinCrt ;
Type
Petunjuk = ^RecNama ;
RecNama = Record
Nip : String[9] ;
Nama : String[25] ;
Gaji : Real ;
Berikut : Petunjuk ;
End ;
Var
DataNama,
NamaAwal : Petunjuk ;
Lagi : Char ;
Begin
NamaAwal := nil ;
Repeat
New(DataNama) ;
Write('Nama Mahasiswa...: ') ; ReadLn(DataNama^.Nama) ;
DataNama^.Berikut := NamaAwal ;
NamaAwal := DataNama ;
Write('Tambah data...(Y/T) ? '); ReadLn(Lagi) ;
WriteLn ;
Until Upcase(Lagi) <> 'Y' ;
{ Tampilkan Daftar }
WriteLn('Menampilkan Data') ;
WriteLn('-------------------------------------') ;
DataNama := NamaAwal ;
While DataNama <> Nil Do
Begin
WriteLn(DataNama^.Nama);
DataNama := DataNama^.Berikut;
End ;
End. { Akhir program }
99
Hasilnya adalah:
Program Pointer4 ;
Uses
WinCrt ;
Type
Pointer = ^Data ;
Data = Record
Bil : integer ;
Next : Pointer ;
End ;
Var
DataBil,
BilAwal : Pointer ;
Lagi : Char ;
Begin
BilAwal := nil ;
Repeat
New(DataBil) ;
Write('Masukan Bilangan : ') ; ReadLn(DataBil^.Bil) ;
DataBil^.Next := BilAwal ;
BilAwal := DataBil ;
Write('Tambah data...(Y/T) ? '); ReadLn(Lagi) ;
WriteLn ;
Until Upcase(Lagi) <> 'Y' ;
{ Tampilkan Daftar }
WriteLn('Menampilkan Data') ;
WriteLn('-------------------------------------') ;
DataBil := BilAwal ;
While DataBil <> Nil Do
Begin
WriteLn(DataBil^.Bil);
DataBil := DataBil^.Next;
End ;
End. { Akhir program }
100
Hasilnya adalah:
Program Pointer5;
Uses
WinCrt ;
Type
Pointer = ^Data ;
Data = Record
Info : Integer ;
Kiri,Kanan : Pointer ;
End ;
Var
P,baru : Pointer ;
Lagi : Char ;
a : integer ;
Begin
{ BilAwal := nil ;}
Repeat
New(baru);
writeln('insert di depan dengan pointer linked list');
Write('Masukan Bilangan : '); ReadLn(a);
baru^.info:=a;
baru^.kiri:=nil;
baru^.kanan:=nil;
if p = nil
then
p:=baru
else
begin
baru^.kanan:=p;
p^.kiri:=baru;
p:=baru;
end;
Write('Tambah data...(Y/T) ? '); ReadLn(Lagi);
Writeln;
Until Upcase(Lagi) <> 'Y' ;
{ Tampilkan Daftar }
WriteLn('Menampilkan Data') ;
WriteLn('-------------------------------------') ;
101
While P <> Nil Do
Begin
WriteLn(p^.info);
P := P^.kanan;
{baru :=p;}
End ;
End. { Akhir program }
Hasilnya adalah:
program pointer6;
uses wincrt;
type ptr = ^simpul;
simpul = record
nama : string;
tinggi : real;
next : ptr;
end;
var
list,baru: ptr;
i,n,pil : integer;
nama : string;
tinggi: real;
procedure tambahdata_dpn(var listnya : ptr; namanya : string; tingginya
: real);
var baru : ptr;
begin
new(baru);
baru^.nama:=namanya;
baru^.tinggi:=tingginya;
if listnya=nil then
listnya:=baru
else
baru^.next:=listnya;
listnya:=baru;
end;
procedure tampildata_dpn(var listnya : ptr);
var bantu : ptr;
begin
102
bantu:=listnya;
writeln('NAMA - TINGGI');writeln;
while bantu<> nil do
begin
writeln(bantu^.nama,' - ',bantu^.tinggi:0:2);
bantu:=bantu^.next;
end;
end;
procedure hapusdata_dpn(var listnya : ptr);
var bantu : ptr;
begin
if listnya=nil then
writeln('List kosong')
else
if listnya^.next=nil then
begin
bantu:=listnya;
listnya:=nil;
dispose(bantu);
end
else
begin
bantu:=listnya;
listnya:=listnya^.next;
dispose(bantu);
end;
end;
begin
list:=nil;
repeat
clrscr;
writeln(' M E N U : ');
writeln;
writeln('(1). Tambah Data');
writeln('(2). Ambil Data');
writeln('(3). Lihat Data');
writeln('(0). Keluar');
write('PILIHAN = ');readln(pil);writeln;
case pil of
1 : begin
write('Banyak Data yang ditambah [PUSH] = ');readln(n);
for i:=1 to n do
begin
writeln('-------------');
write('NAMA = '); readln(nama);
write('TINGGI = '); readln(tinggi);
tambahdata_dpn(list,nama,tinggi);
end;
end;
2 : begin
hapusdata_dpn(list);
writeln('Data Telah Diambil [POP]');
readln;
end;
3 : begin
tampildata_dpn(list);
103
readln;
end;
end;
until (pil=0);
{writeln('sisa');
tampildata_dpn(list);}
readln;
end.
Hasilnya adalah:
program segitiga_pascal;
uses wincrt;
var bil : array[0..100,0..100] of integer;
i,j,k,n : integer;
begin
write('Tingkatannya = ');readln(n);
for i:=0 to (n-1) do
begin
bil[i,0]:=1;
bil[i,i]:=1;
for j:=1 to (i-1) do bil[i,j]:=bil[i-1,j-1]+bil[i-1,j];
for k:=0 to i do write(bil[i,k]);
writeln;
end;
end
Hasilnya adalah:
104
program segitiga_pascal2;
uses wincrt;
var bil1,bil2 : array[1..100] of integer;
i,j,n : byte;
begin
write('Tingkatannya = ');readln(n);
writeln('1');
bil1[1]:=1;
bil1[2]:=1;
writeln(bil1[1],' ',bil1[2]);
for i:=2 to n do
begin
bil2[1]:=1;
write(bil2[1],' ');
for j:=2 to i do
begin
bil2[j]:=bil1[j-1]+bil1[j];
write(bil2[j],' ');
end;
bil2[i+1]:=1;
write(bil2[i+1],' ');
move(bil2,bil1,sizeof(bil1));
writeln;
end;
end.
Hasilnya adalah:
Program data_mahasiswa;
uses wincrt;
var pil,i,k,j : integer;
tinggi : array[1..100] of real;
mahasiswa : array[1..100] of string;
procedure menu(var pilih:integer);
begin
clrscr;
gotoxy(20,5);writeln('**********************************');
gotoxy(20,6);writeln(' M E N U');
gotoxy(20,7);writeln('**********************************');
gotoxy(20,8);writeln;
gotoxy(20,9);writeln(' 1. Tambah Data');
gotoxy(20,10);writeln(' 2. Urutkan Data');
gotoxy(20,11);writeln(' 3. Tampilkan Data');
gotoxy(20,12);writeln(' 4. Hapus Data');
gotoxy(20,13);writeln(' 5. Edit Data');
gotoxy(20,14);writeln(' 6. Statistik');
105
gotoxy(20,15);writeln(' 0. Keluar');
gotoxy(20,16);writeln('**********************************');
gotoxy(20,18);writeln('**********************************');
gotoxy(20,17);write('Pilihan = ');readln(pilih);
end;
procedure tambah;
begin
clrscr;
writeln('******************');
writeln(' Tambah Data');
writeln('******************');
writeln;
write('Banyak data yg ditambahkan = ');readln(j);
for i:=1 to j do
begin
k:=k+1;
writeln('-----------');
writeln(' Data ke-',k);
writeln('-----------');
write('Nama Mahasiswa : ');readln(mahasiswa[k]);
write('Tinggi Badan : ');readln(tinggi[k]);
end;
end;
procedure urutkan;
var pil2,x,y : integer;
temp2: string;
temp : real;
begin
clrscr;
writeln('******************');
writeln(' Urutkan Data');
writeln('******************');
writeln;
if k=0 then
begin
write('Data masih kosong, ENTER untuk ke MENU');
readln;
end
else
begin
writeln('Urutan berdasarkan :');
writeln('1. Nama Mahasiswa');
writeln('2. Tinggi Badan');
write('Pilihan = ');readln(pil2);
if (pil2=1) then
begin
for i:=1 to k-1 do
for j:=i+1 to k do
begin
if length(mahasiswa[i])>length(mahasiswa[j]) then
x:=length(mahasiswa[i])
else
x:=length(mahasiswa[j]);
for y:=1 to x do
begin
if ((mahasiswa[i,y])>(mahasiswa[j,y])) then
106
begin
temp:=tinggi[i];
temp2:=mahasiswa[i];
tinggi[i]:=tinggi[j];
mahasiswa[i]:=mahasiswa[j];
tinggi[j]:=temp;
mahasiswa[j]:=temp2;
y:=x;
end
else if ((mahasiswa[i,y])<(mahasiswa[j,y])) then
y:=x;
end;
end;
write('Data telah terurutkan, ENTER untuk ke MENU');readln;
end
else if (pil2=2) then
begin
for i:=1 to k-1 do
for j:=i+1 to k do
begin
if tinggi[i]>tinggi[j] then
begin
temp:=tinggi[i];
temp2:=mahasiswa[i];
tinggi[i]:=tinggi[j];
mahasiswa[i]:=mahasiswa[j];
tinggi[j]:=temp;
mahasiswa[j]:=temp2;
end;
end;
write('Data telah terurutkan, ENTER untuk ke MENU');readln;
end
else
begin
write('Data GAGAL diurutkan, ENTER untuk ke MENU');readln;
end;
end;
end;
procedure tampilkan(pos: byte; teks : string);
begin
clrscr;
writeln('******************');
gotoxy(pos,2);writeln(teks);
writeln('******************');
writeln;
writeln('Terdapat ',k,' data ');
for i:=1 to k do
begin
writeln('-----------');
writeln(' Data ke-',i);
writeln('-----------');
writeln('Nama Mahasiswa : ',mahasiswa[i]);
writeln('Tinggi Badan : ',tinggi[i]:0:2,' cm');
writeln;
end;
writeln;
write('ENTER untuk melanjutkan');readln;
107
end;
procedure editkan;
var bil : integer;
begin
tampilkan(5,'Edit Data');
if (k>0) then
begin
write('Data yang di edit urutan ke-');readln(bil);
if (bil>0) and (bil<=k) then
begin
writeln('-----------');
writeln(' Data ke-',bil);
writeln('-----------');
writeln('Nama Mahasiswa : ',mahasiswa[bil]);
writeln('Tinggi Badan : ',tinggi[bil]:0:2);
writeln('[::] Edit Data [::]');
write('Nama Mahasiswa : ');readln(mahasiswa[bil]);
write('Tinggi Badan : ');readln(tinggi[bil]);
writeln;
write('Data telah diubah, ENTER untuk ke MENU');
readln;
end
else
begin
writeln;
write('No Data tidak tepat, ENTER untuk ke MENU');readln;
end;
end;
end;
procedure hapuskan;
var bil,i : integer;
begin
tampilkan(5,'Hapus Data');
if (k>0) then
begin
write('Data yang di hapus urutan ke-');readln(bil);
if (bil>0) and (bil<=k) then
begin
for i:=bil to k-1 do
begin
tinggi[i]:=tinggi[i+1];
mahasiswa[i]:=mahasiswa[i+1];
end;
k:=k-1;
writeln;
write('Data telah dihapus, ENTER untuk ke MENU');
readln;
end
else
begin
writeln;
write('No Data tidak tepat, ENTER untuk ke MENU');readln;
end;
end;
end;
procedure statistik;
var i,j : integer;
108
temp,jum : real;
temp2 : string;
begin
clrscr;
writeln('******************');
writeln(' Statistik Data');
writeln('******************');
if (k>0) then
begin
jum:=0;
writeln;
writeln('Banyak data yang ada = ',k);
for i:=1 to k-1 do
begin
for j:=i+1 to k do
begin
if tinggi[i]>tinggi[j] then
begin
temp:=tinggi[i];
temp2:=mahasiswa[i];
tinggi[i]:=tinggi[j];
mahasiswa[i]:=mahasiswa[j];
tinggi[j]:=temp;
mahasiswa[j]:=temp2;
end;
end;
jum:=jum+tinggi[i];
end;
writeln('Rata-rata tinggi mahasiswa = ',((jum+tinggi[k])/k):0:2);
writeln('Mahasiswa yang memiliki tinggi badan terrendah =
',mahasiswa[1],' (',tinggi[1]:0:2,')');
writeln('Mahasiswa yang memiliki tinggi badan tertinggi =
',mahasiswa[k],' (',tinggi[k]:0:2,')');
writeln;
end
else
begin
writeln;
write('Data masih kosong, ');
end;
write('ENTER untuk ke MENU');readln;
end;
{ program utama }
begin
repeat
menu(pil);
case pil of
0 : exit;
1 : tambah;
2 : urutkan;
3 : tampilkan(3,'Tampilkan Data');
4 : hapuskan;
5 : editkan;
6 : statistik;
else
gotoxy(20,19);write('Pilihan salah, ENTER untuk ke
109
MENU');readln;
end;
until pil=0;
end.
Hasilnya adalah:
{Program Polynomial dengan menggunakan Pointer}
Program Polynomial;
uses wincrt;
type
Point = ^node;
node = record
pangkat : integer;
koefisien : integer;
next : point;
end;
var
P : point;
{============================================================
= Procedure untuk memasukkan data secara urut =
============================================================}
Procedure InsertUrut(var A : point; Koef, Pang : integer);
var
baru, bantu : point;
begin
new(baru);
baru^.next:=nil;
baru^.Pangkat := Pang;
baru^.Koefisien := Koef;
if A=nil then
A:=baru
else
begin
if Pang < A^.Pangkat then
begin
baru^.next := A;
A:=baru;
110
end
else
begin
bantu:=A;
while (bantu^.next <> nil) and (Pang > bantu^.next^.Pangkat)
do
bantu:=bantu^.next;
if (bantu^.next<>nil) and (Pang = bantu^.next^.Pangkat)
then
bantu^.next^.Koefisien := bantu^.next^.Koefisien +
Koef
else
if (Pang = bantu^.Pangkat) then
bantu^.Koefisien := bantu^.Koefisien + Koef
else
begin
baru^.next:=bantu^.next;
bantu^.next:=baru;
end;
end;
end;
end;
{============================================================
= Procedure untuk mencetak Persamaan dari Polynomial =
= yang dihasilkan =
============================================================}
Procedure CetakPoly(A : Point);
var
bantu : point;
begin
bantu:=A;
if bantu<>nil then
begin
gotoXY(16,13);writeln('Bentuk Persamaan Plynomialnya adalah:');
gotoXY(16,15);write('Y = ');
while bantu<>nil do
begin
write(bantu^.koefisien,'x^',bantu^.pangkat);
bantu:=bantu^.next;
if bantu <> nil then write(' + ');
end;
end
else
begin
gotoXY(16,13);writeln('Belum ada Polynomial');
gotoXY(16,14);writeln('Pilih no 1 untuk membuat..!!??');
end;
end;
{============================================================
= Procedure untuk memasukkan Koefisien dan Pangkat pada =
= Suatu Polynomial =
============================================================}
111
Procedure InsertPoly(var A : point);
var
i, jum, dataP, dataK : integer;
begin
gotoXY(16,13);write('Jumlah data :');readln(jum);
for i:=1 to jum do
begin
gotoXY(16,15);write('Nilai Koefisien ke-[',i,'] :');readln(dataK);
gotoXY(16,16);write('Nilai Pangkat ke-[',i,'] :');readln(dataP);
InsertUrut(A, dataK, dataP);
end;
end;
{============================================================
= Fungsi untuk menghitung perpangkatan =
============================================================}
Function Pangkat(a,b : integer):Real;
var
i : integer;
Hsl : real;
begin
if a=0 then
Hsl:=0
else
begin
if b=0 then
Hsl:=1
else
begin
if b > 0 then
begin
Hsl:=1;
for i:=1 to b do
Hsl := Hsl*a;
end
else
begin
Hsl:=1;
for i:=1 to abs(b) do
Hsl := Hsl*a;
Hsl :=1/Hsl;
end;
end;
end;
Pangkat:=Hsl;
end;
{============================================================
= Fungsi untuk menghitung derivatif dari Polynomial =
============================================================}
Function Deriv(x : integer; A : point):real;
var
bantu : point;
Hsl : Real;
begin
112
Hsl:=0;
bantu:=A;
while bantu<>nil do
begin
Hsl:=Hsl+bantu^.Pangkat * bantu^.Koefisien *
Pangkat(x,bantu^.Pangkat-1);
bantu:=bantu^.next;
end;
Deriv:=Hsl;
end;
{============================================================
= Procedure untuk menampilkan Judul =
============================================================}
Procedure Judul;
const
garis = '===========================================';
begin
gotoXY(14,1);writeln(' PROGRAM POLYNOMIAL DENGAN POINTER
');
gotoXY(14,4);writeln(garis);
gotoXY(14,5);writeln('| MENU UTAMA
|');
gotoXY(14,6);writeln(garis);
gotoXY(14,7);writeln('| 1. Memasukkan Data
|');
gotoXY(14,8);writeln('| 2. Menampilkan Persamaan Polynomial
|');
gotoXY(14,9);writeln('| 3. Menghitung derivatif dari Polinomial
|');
gotoXY(14,10);writeln('| 4. Hapus Polynomial
|');
gotoXY(14,11);writeln(garis);
end;
{============================================================
= Procedure untuk menghitung derivatif dari Polynomial =
============================================================}
Procedure HitungDeriv(nilai : integer;var P : point);
var
x, n : integer;
begin
gotoXY(16,13);write('Masukkan nilai x:');readln(n);
CetakPoly(P);
gotoXY(16,17);write('Derivatif dengan x=',n,' adalah
:',Deriv(n,P):4:3);
end;
Procedure HapusPoly(var A : point);
var
bantu : point;
jawab : char;
begin
gotoXY(16,13);write('Yakin akan dihapus ?');readln(jawab);
if upcase(jawab)='Y' then
113
begin
bantu:=nil;
dispose(A);
A:=bantu;
end;
gotoXY(16,15);write('Polynomial sudah dihapus..');
end;
{============================================================
= Procedure untuk menu utama =
============================================================}
Procedure Menu;
var
jawab : char;
Pilih,x : integer;
begin
jawab := 'Y';
repeat
clrscr;
Judul;
gotoXY(16,12);write('Pilihan 1,2,3 atau 0 --> Exit ! :
');readln(Pilih);
case Pilih of
0 : jawab:='T';
1 : InsertPoly(P);
2 : cetakPoly(P);
3 : HitungDeriv(x,P);
4 : HapusPoly(P);
else gotoXY(16,13);writeln('Ma''af Anda salah Pilih..!');
end;
gotoXY(16,21);writeln('Tekan sebarang tombol untuk lanjut...!');
readkey;
until jawab='T';
clrscr;
gotoXY(30,12);write('Terima Kasih..!');
end;
{============================================================
= Program Utama =
============================================================}
begin
Menu;
end.
{**** End of File ****}
114
program ackrement;
uses wincrt;
function Ackrement(m,n:integer):integer;
begin
if m=0 then Ackrement:=n+1
else
if n=0 then Ackrement:=Ackrement(m-1,1)
else
Ackrement:=Ackrement(m-1,Ackrement(m,n-1));
end;
begin
writeln(Ackrement(1,2));
end.
Hasilnya: 4
{Program Pohon biner yang lebih besar ke kiri}
uses wincrt;
Type
Tree=^ptr;
ptr=record
data:char;
kiri,kanan:Tree;
end;
Var
baru,P:Tree;
x:char;
Procedure Tambah(var P:tree; baru:tree);
begin
if p=nil then
p:=baru
else
if p^.data>baru^.data then
Tambah(p^.kanan,baru)
else
Tambah(p^.kiri,baru);
end;
Procedure Lihat(p:tree);
begin
if p<> nil then
begin
Lihat(p^.kanan);
write(p^.data);
Lihat(p^.kiri);
end;
end;
begin
new(p);p:=nil;
repeat
115
write('Masukkan data : ');readln(x);
if x<>#13 then begin
new(baru);baru^.kiri:=nil;baru^.kanan:=nil;
baru^.data:=x;
Tambah(p,baru);
end;
until x=#13;
Lihat(p);
end.
Hasilnya adalah:
Program Sorting_Bubble;
Uses winCrt;
Const
Max = 10;
Type
Arr = Array[1..max] Of Byte;
Var
Data : Arr;
i : Byte;
Procedure Input;
Begin
Clrscr;
Writeln('Masukkan 10 Data ');
Writeln('=================');
For I:=1 To Max Do
Begin
Write('Data Ke :',I,'=');Readln(Data[i]);
End;
Clrscr;
For i:=1 to Max Do
Write(Data[i],' ');
Writeln;
Writeln('=========================');
Writeln('Data Yang telah Diurutkan');
Writeln;
{ Readln;}
End;
Procedure Change (Var a,b :Byte);
Var c:Byte;
Begin
116
C:=a;a:=b;b:=c;
End;
Procedure Asc_Bubble;
Var
P,Q : Byte;
Flag: Boolean;
Begin
Flag:=False;
P:=2;
While (P<Max) And (Not Flag) Do
Begin
Flag:=True;
For Q:=Max Downto P Do
If Data[Q]<Data[Q-1] Then
Begin
Change(Data[Q],data[Q-1]);
Flag:=False;
End;
Inc(i);
End;
Write(' Ascending ');
End;
Procedure Desc_Bubble;
Var
P,Q : Byte;
Flag: Boolean;
Begin
Flag:=False;
P:=2;
While (P<Max) And (Not Flag) Do
Begin
Flag:=True;
For Q:=Max Downto P Do
If Data[Q]>Data[Q-1] Then
Begin
Change(Data[Q],data[Q-1]);
Flag:=False;
End;
Inc(i);
End;
Write('Descending ');
End;
Procedure Output;
Begin
For I:=1 To Max Do
Write(Data[I],' ');
Writeln;
End;
Begin
Input;
Asc_Bubble; Output;
Desc_Bubble; OutPut;
Writeln;
117
Write('Tekan Enter Untuk Lanjut');
Readln;
End.
Hasilnya adalah:
program menampilkan_nilai_dengan_if_then_else;
uses wincrt;
var
nilai : real;
keterangan,
predikat : string;
ulang : char;
begin
clrscr;
repeat
writeln;
write('Masukkan nilai anda : '); readln(nilai);
if nilai > 80 then
keterangan := 'A'
else
if nilai >= 61 then
keterangan := 'B'
else
if nilai >= 41 then
keterangan := 'C'
else
if nilai >= 21 then
keterangan := 'D'
else
if nilai >=0 then
keterangan := 'E'
else keterangan :='Maaf mas .....
salah masuk';
writeln('Nilai anda adalah : ', keterangan);
write('Ada data lagi [y/t] : ');readln(ulang);
until ulang ='t';
end.
118
=======================================================================.
program menampilkan_nilai_dengan_case;
uses crt;
var
nilai : integer;
keterangan,
predikat : string;
ulang : char;
begin
clrscr;
repeat
writeln;
write('Masukkan nilai anda : '); readln(nilai);
case nilai of
81..100: writeln ('Nilai Anda Adalah : A');
61..80 : writeln ('Nilai Anda Adalah : B');
41..60 : writeln ('Nilai Anda Adalah : C');
21..40 : writeln ('Nilai Anda Adalah : D');
0..20 : writeln ('Nilai Anda Adalah : E');
else writeln ('Maaf mas .... anda salah masuk nilai ...!!!!');
end;
write('Ada data lagi [y/t] : ');readln(ulang);
until ulang ='t';
end.
uses crt;
var
nilai : integer;
keterangan,
predikat : string;
ulang : char;
begin
clrscr;
repeat
writeln;
write('Masukkan nilai anda : '); readln(nilai);
case nilai of
81..100: writeln ('Nilai Anda Adalah : A');
61..80 : writeln ('Nilai Anda Adalah : B');
41..60 : writeln ('Nilai Anda Adalah : C');
21..40 : writeln ('Nilai Anda Adalah : D');
0..20 : writeln ('Nilai Anda Adalah : E');
else writeln ('Maaf mas .... anda salah masuk nilai ...!!!!');
end;
write('Ada data lagi [y/t] : ');readln(ulang);
until ulang ='t';
end.
Hasilnya adalah:
119


======================================================================
Program huruf;
uses wincrt;
function KHuruf(s:string):string;
var
x:byte;
Panjang:integer;
begin
Panjang:=length(s);
for x:=1 to Panjang do
begin
if s[x] <> upcase(s[x]) then
s[x]:=upcase(s[x])
else if s[x]=' ' then s[x]:=s[x] else
s[x]:=chr(ord(s[x])+32);
end;
KHuruf:=s;
end;
var
k:string;
begin
clrscr;
write('Masukan Kalimat : ');readln(k);
writeln;
writeln('Kata Tersebut Adalah : ',k);
writeln;
writeln('Setelah di konversi : ',KHuruf(k));
readkey;
end.
Hasilnya adalah:
Program Exponen;
uses crt;
var
x,n : byte;
Function Expo(a,b : byte):real;
var Suku,E : real;
k : byte;
begin
E := 0;
k := 0;
Suku :=1;
while k<= b do
begin
E := E + Suku;
K := k+1;
Suku := Suku * a/k;
end;
120
Expo := E;
end;
Begin
write('Input X = ');readln(x);
write('Input N = ');readln(n);
clrscr;
Writeln('e ^ n = 1 + x + (x^2)/2! + (x^3)/3!...');
Writeln('Dimana x = ',x,' dan n = ',n);
Writeln('Maka e = ',Expo(x,n):2:2);
readln;
end.
=======================================================================


Program Menu_makanan;
 uses crt;
procedure nas;
var piln:integer;
begin
writeln;
writeln('1. Nasi Goreng Kambing');
writeln('2. Nasi Goreng Harmoni');
writeln('3. Nasi Goreng Spesial');
write('Masukkan pilihan Anda : ');
read(piln);
case piln of
1: writeln('Nasi Goreng Kambing terpesan');
2: writeln('Nasi Goreng Harmoni terpesan');
3: writeln('Nasi Goreng Spesial terpesan');
end;
readln;
readln;
end;

procedure mie;
var pilm:integer;
begin
writeln;
writeln('1. Mie Goreng Pedas');
writeln('2. Mie Goreng Telor');
writeln('3. Mie Goreng Spesial');
write('Masukkan pilihan Anda : ');
read(pilm);
case pilm of
1: writeln('Mie Goreng Pedas terpesan');
2: writeln('Mie Goreng Telor terpesan');
3: writeln('Mie Goreng Spesial terpesan');
end;
readln;
readln;
end;

procedure bakso;
var pilb:integer;
begin
writeln;
writeln('1. Bakso Biasa');
writeln('2. Bakso Telor');
writeln('3. Bakso Urat');
write('Masukkan pilihan Anda : ');
read(pilb);
case pilb of
1: writeln('Bakso Biasa terpesan');
2: writeln('Bakso Telor terpesan');
3: writeln('Bakso Urat terpesan');
end;
readln;
readln;
end;

var pilihan:byte;

begin
clrscr;
writeln('>>>>>>& gt;>>>>M E N U<<<<<<<<<<<');
writeln('1. Nasi Goreng');
writeln('2. Mie Goreng');
writeln('3. Bakso');
write('Pilih Menu (1..3) : '); readln(pilihan);
case pilihan of
1:nas;
2:mie;
3:bakso;
end;

end.