program antrian tiket

Rabu, 16 Februari 2011

Uses wincrt;
Const Loket = 55;
Kanan = 75;
UpBound = 11;
LowBound = 1;
Type Orang = Object
Badan : Array[1..3] Of String[6];
X,Y,Mentok : Byte;
Procedure init;
Procedure gerak;
End;
Antrian = object
Queue : Array[LowBound..UpBound] Of Orang;
Noel : integer;
Procedure Input(Var Out : Char);
Procedure Create;
Procedure insertion;
Procedure deletion;
Procedure doproses;
End;

Procedure Orang.Init;
Begin
X := 1; Y := 20; Mentok := Loket;
Badan[1] := (' ');
Badan[2] := (' -( )- ');
Badan[3] := ('__/^\__');
End;

Procedure Orang.Gerak;
Begin
repeat
GotoXY(X,Y); Write(Badan[1]);
GotoXY(X,Y+1); Write(Badan[2]);
GotoXY(X,Y+2); Write(Badan[3]);
Inc(X); GotoXY(16,6);
If X = 75 Then
Begin
GotoXY(X,Y); Clreol;
GotoXY(X,Y+1); Clreol;
GotoXY(X,Y+2); Write('______');

End;
Until X = Mentok;
End;

Procedure Antrian.input;
Var Pil : char;
Begin
GotoXY(1,2); Write('1. Bikin Antrian');
GotoXY(1,3); Write('2. Antrian Masuk');
GotoXY(1,4); Write('3. Antrian Keluar');
GotoXY(1,5); Write('4. Bye..Bye..');
GotoXY(1,6); Write(' PILIHAN [1..4] ? ');
Pil := Readkey; Write(Pil); Out := Pil;
End;

Procedure Antrian.create;
Var I : integer;
Begin
For I := 18 To 22 Do
Begin
GotoXY(1,I); Clreol;
end;
For I := 1 To 80 Do Write('_');
GotoXY(58,17); Write(' ANTRIAN KARCIS');
GotoXY(60,18); Write(' _______');
GotoXY(60,19); Write(' /_______\');
GotoXY(60,20); Write(' /-| | | | |-\');
GotoXY(60,21); Write(' | | | | | ');
GotoXY(60,22); Write(' __| LOKET |__');
GotoXY(60,23); Noel := 0;
End;

Procedure Antrian.Insertion;
Begin
If Noel >= upbound Then
Begin
GotoXY(3,23);
Write('Antrian Penuh');
Noel := UpBound;
End
Else
Begin
Inc(Noel); Queue[Noel].Init;
Queue[Noel].Mentok := (Loket - Noel * 5) + 5;
Queue[Noel].Gerak;
End;
End;

Procedure Antrian.Deletion;
Var I : integer;
Front : Orang;
Begin
If Noel < lowbound Then
Begin
GotoXY(59,23);
Write(' Antrian kosong'); Noel := 0;
End
Else
Begin
Dec(Noel);
GotoXY(55,20); Write(' ');
GotoXY(55,21); Write(' ');
GotoXY(55,22); Write('_______');
Front := Queue[1];
Front.Mentok := 75;
Front.X := 72;
Front.Gerak;
For I := 1 To Noel Do Queue[I].X := Queue[I+1].X;
For I := 1 To Noel Do Queue[I].Gerak;
End;
End;

Procedure Antrian.DoProses;
Var Menu : char;

Begin
Noel := 0;
Repeat
Input(Menu);
GotoXY(1,23); Clreol;
Case Menu Of
'1' : Create;
'2' : Insertion;
'3' : Deletion;
End;
until Menu = '4';
End;

{* PROGRAM UTAMA *}

Var Queue : Antrian;
Begin
Clrscr;

writeln ( ' program antrian tiket ' );
queue.doproses;
End.

»»  READMORE...

Membuat Recent Comment Di Blog

Selasa, 15 Februari 2011

»»  READMORE...

program perkalian matrik

Rabu, 09 Februari 2011

uses wincrt;
type
matrik_A=array[1..3,1..3]of byte;
matrik_B=array[1..3,1..3] of byte;
matrik_C=array[1..3,1..3] of byte;

var
a:matrik_A;
b:matrik_B;
c:matrik_C;
i,j,k:integer;

begin
for i:=1 to 3do
begin
for j:=1 to 3do
begin
c[i,j]:=0;
end;
end;
for i:=1 to 3 do
begin
for j:=1 to 3do
begin
writeln ('masukan nilai matrik A=');readln(a[i,j]);
end;
end;
for i:=1 to 3 do
begin
for j:=1 to 3 do
begin
writeln('masukan nillai matrik B=');readln(b[i,j]);
end;
end;
for i:=1 to 3 do
begin
for j:=1 to 3 do
begin
for k:=1 to 3 do
begin
c [i,j]:=c[i,j]+a[i,k]*b[k,j];
end;
end;
end;
for i:=1 to 3 do
begin
for j:=1 to 3 do
begin
writeln ('nilai perkalian +',c[i,j]);
end;
end;
end.

»»  READMORE...

program stack

program data_lagu;
uses wincrt;
label baby;
const maxstack=100;
type s100=string[maxstack];
stack=record
judul:array[1..maxstack] of string;
ujung:0..maxstack;
end;
var lagu:stack;
lagubaru:string;
pil:char;
cetak:string;
procedure push( var lagu:stack;baru:string);
begin
if (lagu.ujung=maxstack) then writeln('stack penuh')
else
begin
lagu.ujung:=lagu.ujung+1;
lagu.judul[lagu.ujung]:=baru;
end;
end;
function pop (var lagu:stack): string;
begin
if (lagu.ujung=0) then writeln('stack kosong')
else
begin
pop:=lagu.judul[lagu.ujung];
lagu.ujung:=lagu.ujung-1;
end;
end;
function cetaklagu(var lagu : stack):string;
var i : integer;
begin
if (lagu.ujung=0) then writeln('stack kosong')
else
begin
for i:=1 to lagu.ujung do
writeln(lagu.judul[i]);
end;
end;
begin
baby:
clrscr;
writeln('program stack');
writeln('pilihan');
writeln('1.tambah data (push)');
writeln('2.ambil data (pop)');
writeln('3.cetak');
writeln('4.keluar');
writeln('pil 1/2/3/4 :?');
write('masukan pilihan :');readln(pil);
case pil of
'1':begin
clrscr;
writeln('masukan lagu baru');
write('judul baru:');readln(lagubaru);
push(lagu,lagubaru);
writeln('lagu yang ada di stack ',lagu.ujung,' buah');
readln;
end;
'2':begin
clrscr;
writeln('mengambil lagu dari stack');
writeln('lagu yang di ambil : ',pop(lagu));
writeln('lagu yang ada di stack ',lagu.ujung,' buah');
readln;
end;
'3':begin
clrscr;
writeln('isi stack');
cetaklagu(lagu);
writeln('lagu yang ada di stack ',lagu.ujung,' buah');
readln;
end;
'4':halt;
end;
write(#7);
goto baby;
end.

»»  READMORE...

program antrian

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);

var i,awal : integer;
begin
CLRSCR;
writeln('---------------');
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],' ');
writeln('---------------');
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 Nomor 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;

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.

»»  READMORE...

program cari_suku_fibonacci

Senin, 07 Februari 2011

uses crt;
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.

hasil run

»»  READMORE...

Program Konversi_Bilangan

Uses Crt;
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;
des:=des div 2;
writeln(des:4,bin:20);
until des=0;
writeln('(',desi,') desimal =',bin,' (Biner)');
end.

hasli run

»»  READMORE...

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.

hasil run

»»  READMORE...