1. Program Record
program record1;
uses wincrt;
type
mahasiswa = record
nama: string[20];
nim: string[10];
prodi: string[20];
alamat: string[30];
end;
var
data_mhs: array[1..50] of mahasiswa;
n,i: integer;
begin
clrscr;
writeln('Contoh pemakaian record: Data Mahasiswa');
write('Masukkan cacah data: ');readln(n);
for i:=1 to n do
begin
writeln('data ke-',i);
write('nama mahasiswa: ');readln(data_mhs[i].nama);
write('nomor mahasiswa: ');readln(data_mhs[i].nim);
write('program studi: ');readln(data_mhs[i].prodi);
write('alamat: ');readln(data_mhs[i].alamat);
end; {perhatikan pemakaian indeks untuk array !}
writeln;
write('Tekan ENTER ...');readln;
clrscr;
writeln('Tabel Data');
for i:=1 to n do
begin
with data_mhs[i] do {#32 = SPASI}
begin
write(i,#32,nama,#32:20-length(nama));
write(nim,#32:8-length(nim));
write(prodi,#32:20-length(prodi));
writeln(alamat);
end;
end;
end.
2. Program Membaca Kalimat dan Memprosesnya
program Kalimat1;
uses
WinCrt;
const
PanjangBaris = 128;
LebarKata = 10;
type
Kalimat = String[PanjangBaris];
DataHuruf = record
Cacah : Word;
AwalKata: Word;
end;
var
Baris, Kata : Word;
Huruf : LongInt;
TabeLebarKata: array[1..LebarKata] of Word;
TabelHuruf : array['A'..'Z'] of DataHuruf;
Masukan : Kalimat;
i : byte;
procedure InfoDataHuruf(Awal, Akhir: Char);
var
S: Char;
begin
Writeln; Write('Huruf :');
for S := Awal to Akhir do Write(S:5);
Writeln; Write('Frekuensi :');
for S := Awal to Akhir do Write(TabelHuruf[S].Cacah:5);
Writeln; Write('Di awal kata:');
for S := Awal to Akhir do Write(TabelHuruf[S].AwalKata:5);
Writeln;
end;
procedure CetakHasil;
var
i : Integer;
KataPerbaris: Real;
begin
if Baris <> 0 then KataPerbaris := Kata / Baris
else KataPerbaris := 0;
Writeln;
Writeln('Anda telah menuliskan ',Baris, ' baris (kalimat) ');
writeln('yang memuat ',Kata, ' kata dan ',Huruf,' huruf.');
Writeln('Rata-rata kata per baris: ',KataPerbaris:0:2,'.');
Writeln;
Write('Huruf/Kata: ');
for i := 1 to LebarKata do Write(i:4);
Writeln;
Write('Frekuensi : ');
for i := 1 to LebarKata do Write(TabeLebarKata[i]:4);
Writeln;
InfoDataHuruf('A', 'M');
InfoDataHuruf('N', 'Z');
end;
procedure Inisialisasi;
begin
Baris := 0;
Kata := 0;
Huruf := 0;
FillChar(TabelHuruf, SizeOf(TabelHuruf), 0);
FillChar(TabeLebarKata, SizeOf(TabeLebarKata), 0);
end;
function CekHuruf(S: Char): Boolean;
begin
CekHuruf := UpCase(S) in ['A'..'Z'];
end;
procedure CekBaris(var S: Kalimat);
var
i : Integer;
LebarHuruf: Word;
begin
Inc(Baris);
i := 1;
while i <= Length(S) do
begin
while (i <= Length(S)) and not CekHuruf(S[i]) do Inc(i);
LebarHuruf := 0;
while (i <= Length(S)) and CekHuruf(S[i]) do
begin
Inc(Huruf);
Inc(TabelHuruf[UpCase(S[i])].Cacah);
if LebarHuruf = 0 then Inc(TabelHuruf[UpCase(S[i])].AwalKata);
Inc(i);
Inc(LebarHuruf);
end;
if LebarHuruf > 0 then
begin
Inc(Kata);
if LebarHuruf <= LebarKata then
Inc(TabeLebarKata[LebarHuruf]);
end;
end;
end;
function BacaBaris(i:byte): Kalimat;
var
S: Kalimat;
begin
Write('Kalimat ke-',i,': ');
Readln(S); BacaBaris := S;
end;
begin
Writeln('Program Membaca kalimat/string dan memprosesnya.');
Writeln('Tuliskan sebuah kalimat & baris kosong untuk mengakhiri.');
Inisialisasi;
i:=1;
Masukan := BacaBaris(i);inc(i);
while Masukan <> '' do
begin
CekBaris(Masukan);
Masukan := BacaBaris(i);inc(i);
end;
CetakHasil;
end.
3. Program Operasi Matrik
Program Matrixmn;
uses wincrt;
const maxbaris=10;
maxkolom=10;
type matrix = record
baris,kolom : byte;
elemen : array[1..maxbaris,1..maxkolom] of real;
end;
procedure baca_matriks(var A:matrix;m,n:byte);
var i,j:byte;
begin
A.baris:=m; A.kolom:=n;
for i:=1 to m do
for j:=1 to n do
begin
write('Elemen ke-(',i,',',j,') = ');
readln(A.elemen[i,j]);
end;
end;
procedure cetak_matriks(A:matrix);
var i,j: byte;
begin
for i:=1 to A.baris do
begin
for j:=1 to A.kolom do write(A.elemen[i,j]:7:2);
writeln;
end;
end;
procedure jumlah(A,B:matrix;var M:matrix);
var i,j: byte;
begin
if (A.baris <> B.baris) or (A.kolom <>B.kolom) then
writeln('Error, matriks tidak cocok!') else
begin
M.baris:=A.baris;M.kolom:=A.kolom;
for i:=1 to A.baris do
for j:=1 to A.kolom do
M.elemen[i,j]:=A.elemen[i,j]+B.elemen[i,j];
end;
end;
procedure selisih(A,B:matrix;var M:matrix);
var i,j: byte;
begin
if (A.baris <> B.baris) or (A.kolom<>B.kolom) then
writeln('Error, matriks tidak cocok!') else
begin
M.baris:=A.baris;M.kolom:=A.kolom;
for i:=1 to A.baris do
for j:=1 to A.kolom do
M.elemen[i,j]:=A.elemen[i,j]-B.elemen[i,j];
end;
end;
procedure kali(A,B:matrix;var M:matrix);
var i,j,k: byte;
begin
if A.kolom<>B.baris then
writeln('Error, matriks tidak cocok!') else
begin
M.baris:=A.baris;
M.kolom:=B.kolom;
for i:=1 to M.baris do
for j:=1 to M.kolom do
begin
M.elemen[i,j]:=0;
for k:=1 to A.kolom do
M.elemen[i,j]:=M.elemen[i,j]+A.elemen[i,k]*B.elemen[k,j];
end;
end;
end;
procedure transpose(A:matrix; var M:matrix);
var i,j:byte;
begin
M.baris:=A.kolom;
M.kolom:=A.baris;
for i:=1 to M.baris do
for j:=1 to M.kolom do
M.elemen[i,j]:=A.elemen[j,i];
end;
var A,B,C,D,E,H:matrix;
m,n: byte;
begin {bagian utama}
writeln('Program Operasi Matriks');
writeln('Maksimum ukuran matriks 10 x 10.');
writeln('Menentukan ukuran matriks.');
writeln('Matriks A:');
write('Cacah baris = '); readln(m);
write('Cacah kolom = '); readln(n);
baca_matriks(A,m,n);
writeln('Matriks B:');
write('Cacah baris = '); readln(m);
write('Cacah kolom = '); readln(n);
baca_matriks(B,m,n);
write('Tekan ENTER ...');readln;
writeln('A = ');cetak_matriks(A);
writeln('B = ');cetak_matriks(B);
write('Tekan ENTER ...');readln;
writeln('A + B = ');jumlah(A,B,C);cetak_matriks(C);
writeln('A - B = ');selisih(A,B,D);cetak_matriks(D);
write('Tekan ENTER ...');readln;
writeln('AxB = ');kali(A,B,E);cetak_matriks(E);
writeln('A'' = ');transpose(A,H);cetak_matriks(H);
write('Tekan ENTER untuk keluar ...');readln;
donewincrt;
end.
4. Program Menara Hanoi
Program Hanoi1;
uses WinCrt;
const maxkeping=10;
type
menara=record
nama : char;
cacah : byte;
keping: array[1..maxkeping] of byte;
end;
72 Petunjuk Praktikum Pemrograman Komputer dengan Turbo Pascal
procedure cetakmenara(A:menara);
var i: byte;
begin
write(A.nama,'[');
for i:=1 to A.cacah do write(A.keping[i]:3);
writeln(']');
end;
procedure pindahkeping(var A,B:menara);
begin
writeln(A.keping[A.cacah],'[',A.nama,' --> ',B.nama,']');
inc(B.cacah);
B.keping[B.cacah]:=A.keping[A.cacah];
dec(A.cacah);
write('Tekan ENTER ...');readln;
end;
procedure hanoi(var A,B,C:menara;n:byte;var langkah:longint);
begin
if n=1 then
begin
cetakmenara(A);cetakmenara(B);cetakmenara(C);
inc(langkah);write('Langkah ke-',langkah,': ');
pindahkeping(A,C);
writeln('Selesai!');Exit;
end
else hanoi(A,C,B,n-1,langkah);
cetakmenara(A);cetakmenara(B);cetakmenara(C);
inc(langkah);write('Langkah ke-',langkah,': ');
pindahkeping(A,C);
hanoi(B,A,C,n-1,langkah);
end;
var i,n : byte;
langkah: longint;
A,B,C : menara;
lagi : char;
label mulai;
begin
mulai: clrscr;
writeln('Program Menara Hanoi:');
writeln('Memindahkan n keping batu dari menara A ke C');
writeln('dengan perantara menara B.');
writeln('Keping diberi nomor n (terbesar), (n-1), ..., 2, 1.');
writeln('Nomor besar harus di bawah nomor kecil.');
writeln('======================================');
write('Tuliskan cacah keping, n <= 10 : ');readln(n);
if (n<1) or (n>10) then goto mulai;
A.nama:='A';B.nama:='B';C.nama:='C';
A.cacah:=n; B.cacah:=0;C.cacah:=0;
for i:=1 to n do A.keping[i]:=(n+1-i);
langkah:=0;
hanoi(A,B,C,n,langkah);
cetakmenara(A);cetakmenara(B);cetakmenara(C);
write('Coba lagi? <Y/T>_ ');readln(lagi);
if upcase(lagi)='Y' then goto mulai;
donewincrt;
end.
No comments:
Post a Comment