FUNCTION

 INI PROGRAM FUNCTION


USES winCRT;
PROCEDURE JUDUL;
VAR I:BYTE;
BEGIN
     WRITELN('MENGHITUNG LUAS PERSEGI PANJANG');
     FOR I:= 1 TO 31 DO
         WRITE('-');
     WRITELN;
END;
PROCEDURE INPUT(VAR A,B:BYTE);
VAR I:BYTE;
BEGIN
     WRITE('PANJANG : '); READLN(A);
     WRITE('LEBAR   : '); READLN(B);
END;
FUNCTION LUASPP(A,B:BYTE):INTEGER;
VAR C:INTEGER;
BEGIN
     C:=A*B;
     LUASPP:=C;
END;
FUNCTION KELLPP(A,B:BYTE):INTEGER;
VAR C:INTEGER;
BEGIN
     C:=2*(A+B);
     KELLPP:=C;
END;

{---------------INI ADALAH AWAL PROGRAM UTAMA-----------------}

VAR P,L,PILIH:BYTE;
    MCL:CHAR;
BEGIN
     CLRSCR;
     MCL:='Y';
     WHILE (MCL='Y') DO
     BEGIN
          WRITELN('1. LUAS');
          WRITELN('2. KELILING');
          WRITE('PILIH [1/2] : '); READLN(PILIH);
          CASE PILIH OF
          1:BEGIN
                 JUDUL;
                 INPUT(P,L);
                 WRITELN('LUAS : ',LUASPP(P,L));
            END;
          2:BEGIN
                 JUDUL;
                 INPUT(P,L);
                 WRITELN('KELILING :',KELLPP(P,L));
            END;
          END;
          WRITE('MAU COBA LAGI [Y/T] : '); READLN(MCL);
     END;
     REPEAT UNTIL KEYPRESSED;
END.

Read More »

Add Comment

Unknown

LINKED LIST

 INI PROGRAM LINKED LIST


PROGRAM LinkedList1;
uses wincrt;
CONST
  Header    ='------------ Menu Utama ------------';
  Separator ='------------------------------------';
TYPE
  DataString  = STRING[30];
  ListPointer = ^ListRecord;
  ListRecord  = RECORD
                  DataField : DataString;
                  NextField : ListPointer
                END;
VAR
  FirstPointer : ListPointer;
PROCEDURE BuildList(VAR FirstPointer : ListPointer;
                        DataItem     : DataString);
VAR
  ToolPointer : ListPointer;
BEGIN
  NEW(ToolPointer);
  ToolPointer^.DataField := DataItem;
  ToolPointer^.NextField := FirstPointer;
  FirstPointer:=ToolPointer
END;
PROCEDURE ReadList(FirstPointer : ListPointer);
VAR  CurrentPointer : ListPointer;
BEGIN
  CurrentPointer := FirstPointer;
  WHILE CurrentPointer <> NIL DO
     BEGIN
       WRITELN(CurrentPointer^.DataField);
       CurrentPointer := CurrentPointer^.NextField
     END;
  WRITELN
END;
PROCEDURE GetData(VARFirstPointer:ListPointer);
VAR  Name:DataString;
BEGIN
  WRITELN('Masukkan nama yang akan ditambahkan lalu tekan ENTER jika selesai.');
  READLN(Name);
  WHILE LENGTH(Name) <> 0 DO
  BEGIN
     BuildList(FirstPointer,Name); READLN(Name)
  END
END;
PROCEDURE DisplayInfo(FirstPointer:ListPointer);
BEGIN
   WRITELN(Separator);
   WRITELN('Isi dari daftar:');
   ReadList(FirstPointer);
   WRITE('Tekan sembarang tombol untuk lanjut...');
   READLN
END;
procedure cetak(firstpointer:listPointer);
var jejek:text;
    CurrentPointer : ListPointer;
begin
assign(jejek,'gundulmu.txt');
rewrite(jejek);
writeln(jejek,'Tertulis dengan Indah sebagai berikut :');
writeln(jejek);
Writeln(jejek,separator);
Writeln(jejek,'ISi dari daftar');
writeln(jejek);
CurrentPointer := FirstPointer;
  WHILE CurrentPointer <> NIL DO
     BEGIN
       WRITELN(jejek,CurrentPointer^.DataField);
       CurrentPointer := CurrentPointer^.NextField
     END;
writeln;
writeln('Data telah di tulis ke gundulmu.txt, tinggal di lihat saja...');
readln;
close(jejek);
end;

PROCEDURE Menu;
VAR  Option : INTEGER;
BEGIN
  WRITELN(Header);
  WRITELN('1. Simpan data pada daftar.');
  WRITELN('2. Tampilan daftar.');
  Writeln('3. Tulis data ke teks ');
  WRITELN('4. Keluar.');
  WRITELN(Separator);
  WRITE('Pilihan --> ');
  READLN(Option);
  CASE Option OF
     1 : GetData(FirstPointer);
     2 : DisplayInfo(FirstPointer);
     3 : cetak(firstpointer);
     4 : exit;
  END;
  Menu
END;
BEGIN
  FirstPointer := NIL;
  menu
END.

Read More »

Add Comment

Unknown

PENCARIAN

 INI PROGRAM PENCARIAN

 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.

Read More »

Add Comment

Unknown

PENGURUTAN

 INI PROGRAM PENGURUTAN

program counting_sort;
uses wincrt;
type
nilai = array[1..50] of integer;
var
nl : nilai;
mindata,maxdata: integer;
jumlah ,i:integer;
procedure isinilai(var nl:nilai; var n:integer);
var
j:integer;
begin
write('banyak data : ');
readln(n);
for j:=1 to n do
begin
write('data ke ',j,' : ');
readln(nl[j]);
end;
end;

procedure minmax(nl:nilai;n:integer;var mindata:integer;var maxdata:integer);
begin
mindata :=nl[1];
maxdata :=nl[1];
for i:=2 to n do
begin
if nl[i] < mindata then mindata :=nl[i];
if nl[i] > maxdata then maxdata :=nl[i];
end;
end;

procedure countsort(var tabint:nilai;n:integer;mindata:integer;maxdata:integer);
const min=1;max=100;
var
i,j,k:integer;
tabcount:array [min..max] of integer;
begin
for i:=mindata to maxdata do
tabcount[i]:=0;

for i:=1 to n do
tabcount[tabint[i]]:=tabcount[tabint[i]]+1;
k:=0;
for i :=mindata to maxdata do
if tabcount[i]<>0 then
for j:=1 to tabcount[i] do
begin
k:=k+1;
tabint[k]:=i;
end;
end;

procedure cetak(nl:nilai;n:integer);
begin
for i:=1 to n do
write(nl[i],' ');
writeln;
end;

begin
isinilai(nl,jumlah);
minmax(nl,jumlah,mindata,maxdata);
writeln('ini data sebelum diurutkan: ');
cetak(nl,jumlah);
countsort(nl,jumlah,mindata,maxdata);
writeln('ini data setelah diurutkan: ');
cetak(nl,jumlah);
readln;
end.

Read More »

Add Comment

Unknown

PROCEDURE

 INI PROGRAM PROCEDURE

Uses winCrt;

Procedure CetakAngka1Sd(N: Byte);
Var
  I: Byte; {Deklarasi Lokal}
 Begin
 For I:=1 To N Do
  writeln(I);
 End;

{Program Utama}
Begin
 {Bersihkan layar}
 clrscr;
 {Panggil Prosedur Cetak 1 s.d 20}
 CetakAngka1SD(20);
{Panggilan Lagi Prosedur Cetak Angka 1 s.d 100}
 CetakAngka1SD(100);
Readln; {Tunggu Penekanan Tombol Enter}
End.

Read More »

Add Comment

Unknown

RECORD

INI PROGRAM RECORD

uses wincrt;
type
TSiswa = record
nim : string[8];
nama : string[25];
agama : string[10];
ktp : string[25];
end;
var
s : TSiswa;
umur : integer ;
ts : integer;
tl : integer;
begin
clrscr;
write ('Masukkan tahun sekarang: ');
readln (ts);
writeln ('Isikan data anda dalam Form ini');
write ('NIM : ');
readln (s.nim);
write ('NAMA : ');
readln (s.nama);
write ('TAHUN LAHIR : ');
readln (tl);
umur := (ts-tl);
write ('AGAMA : ');
readln (s.agama);
write ('NO.KTP : ');
readln (s.ktp);
writeln;
writeln ('Berikut ini informasi yang anda berikan: ');
writeln ('NIM : ', s.nim);
writeln ('NAMA : ', s.nama);
writeln ('Umur : ', umur);
writeln ('AGAMA : ', s.agama);
writeln ('NO.KTP : ', s.ktp);
READLN;
end.

Read More »

Add Comment

Unknown

TUMPUKAN

 INI PROGRAM TUMPUKAN

Program pop_pushModifikasi;
uses wincrt;
const elemen =255; {batas maximum karakter}
type S255 = string [elemen];
 tumpukan = record
 isi : s255;
 atas : 0..elemen;
end;

var
T : tumpukan;
W, tambah : char;
kalimat : s255;
i,j : integer;

procedure awalan (var T : tumpukan);
begin
 T.Atas := 0;
end;

procedure push (var T : tumpukan; X : char);
begin
 T. Atas := T.Atas+1;
 T.Isi[T.Atas] := X;
end;

function pop (var T : tumpukan): char;
begin
 pop := T.Isi[T.Atas];
 T.atas := T.atas-1;
end;

begin {program utama}
 clrscr;
 writeln('Masukkan Kalimat : ');
 read(kalimat);
writeln;
 for i := 1 to length (kalimat) do
 push (T, kalimat [i]);
 writeln('Elemen yang di-push : ', kalimat); readln;
 writeln('Tambah karakter : ');
 readln(tambah);

{melakukan proses pop}
for i := 1 to length (kalimat) do
push (t, kalimat [i]);
writeln;
writeln('Hasil akhir : '); write(tambah);
{menampilkan hasil proses pop}
for j := 1 to length (kalimat) do
begin
 w := pop (T);
 write(w);
end;
readln;
end.

Read More »

Add Comment

Unknown