Minggu, 13 Januari 2013

Menambah Data;

program Latihan_menambah_file;
uses wincrt;

var
ftext:text;
begin
assign(ftext,'Latihan.txt');
append (ftext);

writeln;
writeln(ftext,'=>LATIHAN BROOOO<=');
writeln(ftext,'==================');
writeln(ftext,'MASUK ANGIN');
writeln(ftext,'BALING');
writeln(ftext,'<===============>');
close (ftext);
end.

membuat file

program Latihan_file;
uses wincrt;

var
ftext:text;
begin
assign(ftext,'Latihan.txt');
rewrite(ftext);

writeln(ftext,'=>LATIHAN BROOOO<=');
writeln(ftext,'==================');
writeln(ftext,'SAYA LAGI BELAJAR');
writeln(ftext,'SAYA LAGI SIBUKKK');
writeln(ftext,'<===============>');
close (ftext);
end.

Pencarian Bagi Dua

program Pencarian_Bagi_Dua;
uses wincrt;

var
L : array [1..100] of integer;
n1,x1,m,hasil :integer;

function BinarySearch2(n :integer; x : integer) : integer;

var
i,j : integer;
idx, k : integer;

ketemu : boolean;
begin
i := 1;
j := n;

ketemu := false;
while (not ketemu) and (i <= j) do
begin
k:=(i + j) div 2;
if (L[k] = x) then                           
ketemu:= true
else
if (x > l[k]) then
i := k + 1
else
j := k - 1;
end;

if (ketemu) then
idx := k
else
idx := -1;

BinarySearch2:=idx;
end;

begin
write ('masukkan jumlah data : ');
readln (n1);

for m:=1 to n1 do
begin
write ('masukkan isi larik ke ' ,m,' ');
        readln (L[m]);
end;

write ('inputkan data yang ingin dicari : ');
readln (x1);


hasil:=BinarySearch2 (n1,x1);

if (hasil = -1) then
writeln ('tidak ditemukan di larik')
else
writeln ('data inputan ditemukan di larik ke : ', hasil);

end.

Minggu, 06 Januari 2013


Program Bubble_Sort;

Uses WinCrt;

const

max = 100;

type

Larik = array [1..max] of integer;

var

A: Larik;

I: integer;

N: integer;

pil:byte;

procedure Jumlah_Data;

begin

write('Masukkan banyaknya data = '); readln(N);

writeln;

end;

procedure Input;

var

I: integer;

begin

for I:=1 to N do

begin

write('Masukkan data ke-', I, ' = '); readln(A[I]);

end;

end;

procedure Change(var A, B: integer);

var

T: integer;

begin

T:=A;

A:=B;

B:=T;

end;

procedure asc_buble;

var

p,q :INTEGER;

flag:boolean;

begin

flag:=false;

p:=2;

while (p<N) and (not flag) do

begin

flag:=true;

for q:=N downto p do

if A[q]<A[q-1] then

begin

change(A[q],A[q-1]);

flag:=false;

end;

inc(i);

end;

writeln;

write('Data Diurutkan Secara Ascending: ');

end;

procedure desc_buble;

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 A[q]>A[q-1] then

begin

change(A[q],A[q-1]);

flag:=false;

end;

inc(i);

end;

writeln;

write('Data Diurutkan Secara Descending: ');

end;

procedure Output;

var

i: integer;

begin

for i:=1 to N do

write(A[i], '  ');

writeln;

end;

begin

Jumlah_Data;

input;

clrscr;

writeln('[1].pengurutan secara Ascending');

writeln('[2].pengurutan secara Descending');

write('Silahkan Masukkan Pilihan Anda = ');readln(pil);

case pil of

1:asc_buble;

2:desc_buble;

end;

output;

end.