http://alifrusdiana.blogspot.com/. Diberdayakan oleh Blogger.

Popular Posts

Test Footer 1

Comment

Template information

Random Post

Test Footer

Rabu, 22 Januari 2014

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.
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.
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.
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.
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.
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.
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.
Unknown

ANTRIAN

 INI PROGRAM ANTRIAN

program antrian_bioskop;
uses wincrt;
const max=10;
type queue=record
nama,judul:array[1..max] of string;
depan,belakang:0..max;
end;

type jual=record
nama,judulj:string;
jt:1..8;
total:real;
end;
larik_jual=array[1..20] of jual;
label ulang;



var bioskop,qp:queue;
    jual1:larik_jual;
nb,na,jf,keluar:string;
pil:1..6;
ct:longint; i,j,n:byte;
tot:real;
        ketemu:boolean;

function full(q:queue):boolean;
begin
if (q.belakang=max) then full:=true else full:=false;
end;

function empty(q:queue):boolean;
begin
if (q.belakang=0) then empty:=true else empty:=false;
end;

procedure pushq(var q:queue;x:string);
begin
if full(q) then writeln ('antrian sedang penuh')
else
begin
inc(q.belakang);
q.nama[q.belakang]:=x;
end;
end;

procedure popq(var q:queue);
begin
if empty(q) then writeln('antrian sudah kosong')
else
begin
na:=q.nama[q.depan];
        jf:=q.judul[q.depan];
{digeser}
for i:=1 to (q.belakang-1) do
q.nama[i]:=q.nama[i+1];
dec(q.belakang);
end;
end;

procedure cetak_antrian(var q:queue);
begin
writeln('ANTRIAN YANG ADA SAAT INI');
writeln('------------------------------------');
writeln('antrianno         nama');
writeln('------------------------------------');
for i:=1 to q.belakang do writeln(i:3,' ',q.nama[i]:15);
writeln('------------------------------------');
end;

procedure cetak_pem(var x:larik_jual);
var tot:real;
begin
writeln('Pembelian Tiket Hari Ini');
writeln('---------------------------------------------------------------------');
writeln('|  No |  Nama     |     Judul     |     Jumlah    |     Total    |');
writeln('---------------------------------------------------------------------');
for i:=1 to n do
begin
writeln(i:3,' ',x[i].nama:11,'  ',x[i].judulj:8,'  ',x[i].jt:10,' Tiket           Rp. ',x[i].total:11:2);
tot:=tot+x[i].total;
end;
writeln('---------------------------------------------------------------------');
writeln('-------------------------------------------------Total--Rp ',tot:11:2);
end;

procedure bosan(var q:queue);
var posisi:byte;

begin
ketemu:=false;
write('Masukkan Nama yang ingin keluar ==> ');readln(keluar);
for i:=q.belakang downto 1 do
begin
     if (q.nama[i]=keluar) then
     begin
     ketemu:=true;
     posisi:=i;
     end;
end;
if ketemu then
begin
     for j:=q.belakang downto posisi+1 do
     begin
     inc(qp.belakang);
     qp.nama[qp.belakang]:=q.nama[j];
     end;
q.belakang:=posisi;
na:=q.nama[q.belakang];
dec(q.belakang);
for j:=q.belakang downto 1 do
begin
     inc(q.belakang);
     q.nama[q.belakang]:=qp.nama[j];
end;
end
else
writeln('Nama Tidak ada Dalam Antrian');
end;


begin{utama}
bioskop.depan:=1;
repeat
begin
clrscr;
writeln(' PELAYANAN ANTRIAN BIOSKOP XXI');
writeln('1. Masuk antrian');
writeln('2. Layanan pembelian tiket');
writeln('3. Keluar antrian,bosan');
writeln('4. Cetak antrian');
writeln('5. Cetak pembelian tiket');
writeln('6. Selesai');
write('Pilih 1-6 --> ');readln(pil);
case pil of
1:
begin
write('masukan nama baru yang akan diantri ');readln(nb);
                pushq(bioskop,nb);
end;
2:
begin
if not empty(bioskop) then
begin
popq(bioskop);
ulang:write('saudara ',na,' akan membeli beberapa tiket ? ');readln(ct);
                        write('Masukkan Judul Film !');readln(jf);
if ct>4 then {Jika jumlah tiket>4, ulangi pemasukan}
begin writeln('Maks pembelian 4 tiket, ulang ');goto ulang;end
else
begin
tot:=25000*ct; {max ct 4}
writeln('Anda harus membayar Rp ',tot:8:2);
                        inc(n);
                        jual1[n].nama:=na;
                        jual1[n].judulj:=jf;
                        jual1[n].jt:=ct;
                        jual1[n].total:=tot;
end;
end
else writeln('antrian sudah habis');
end;
3:      begin
                if not empty(bioskop) then bosan(bioskop) else
                writeln('Antrian Sudah Kosong');
                if ketemu and not empty(bioskop) then
                begin
                     writeln('Orang yang Keluar adalah ',na);
                end;
                end;
4: if not empty(bioskop) then cetak_antrian(bioskop) else
writeln('antrian sudah kosong');
5:      begin
                cetak_pem(jual1);
                end;
6: writeln('TERIMAKASIH');
end;
readln;
end
until (pil=6);
end.
Unknown

ARRAY

INI PROGRAM PASCAL ARRAY

program array1;
Uses wincrt;
Var
  I         :Longint;
  Nm        :Array[1..100]Of String[25];
  Hk,Subt   :Array[1..100]Of Real;
  Lm        :Array[1..100]Of Integer;
  Tot       :Real;

Begin
  I:=1;
  While(I<=3) Do
      Begin
        clrscr;
        Writeln('Data Ke :',I);
        Writeln('===========');
        Write('Inputkan Nama Tamu :');Readln(Nm[I]);
        Write('Inputkan Lama Menginap :');Readln(Lm[I]);
        Write('Inputkan Harga Kamar :');Readln(Hk[I]);
        Subt[I] :=Lm[I] * Hk[I];
        Writeln;
        Tot :=Tot + Subt[I];
        I:=I +1;
      End;
  Writeln('--------------------------------------------------');
  Writeln('No            Nama   Lama        Harga   Sub      ');
  Writeln('              Tamu   Menginap    Kamar   Total    ');
  Writeln('--------------------------------------------------');
      For I:=1 To 3 Do
        Begin
          Writeln(I:3,Nm[I]:15,Lm[I]:10,Hk[I]:10:0,Subt[I]:8:0);
        End;
  Writeln('--------------------------------------------------');
  Writeln('Total :',Tot:12:0);
  readln;
End.
Unknown