Masukan
program segitiga;
uses wincrt;
var
alas, tinggi: real;
i, N: integer;
procedure
hitungluassegitiga(alas, tinggi: real);
var
luas:real;
begin
luas:=(alas*tinggi)/2;
write(luas:2:2);
end;
begin
write('masukkan jumlah
segitiga: '); readln(N);
for i:= 1 to N do
begin
writeln;
write('masukkan
alas: '); readln(alas);
write('masukkan
tinggi: '); readln(tinggi);
hitungluassegitiga(alas, tinggi);
end;
END.
Keluaran
program segitiga;
uses wincrt;
var
a, t, l: real;
i, N: integer;
procedure
hitungluassegitiga(alas, tinggi: real; var luas: real);
begin
luas:=(alas*tinggi)/2;
end;
begin
write('masukkan
jumlah segitiga: '); readln(N);
for i:= 1 to N do
begin
writeln;
write('masukkan
alas: '); readln(a);
write('masukkan
tinggi: '); readln(t);
hitungluassegitiga(a, t, l);
write('luas
segitiga: ',l:2:2);
end;
END.
Inc
Program Inc;
uses wincrt;
var i,x : integer;
procedure inc(var
x:integer);
begin
x:=x+1;
end;
begin
x:=0;
for i:=1 to 10 do
begin
write
(x);
inc(x);
end;
end.
program HIMPUNAN;
uses wincrt;
const Nmaks = 100;
type larikint = array [1..Nmaks] of integer;
var x,i,nA,nB:integer;
A,B:larikint;
procedure baca (var H:larikint; var nH:integer);
begin
i:=0;
nH:=0;
x:=0;
while x<>9999
do
begin
i:=i+1;
H[i]:=x;
write ('[',i,']
= ');readln(x);
nH:=nH+1;
end;
nH:=nH-1
end;
BEGIN
writeln ('Himpunan
A : ');
Baca(A,nA);
write('Banyak
anggota A : ', nA);
writeln;
writeln;
writeln ('Himpunan
B : ');
baca(B,nB);
write('Banyak
anggota B : ', nB);
END.
program membandingkan dua himpunan;
uses wincrt;
const Nmaks=100;
type LarikInt =
array[1..Nmaks] of integer;
var A,B:larikInt;
i,z,nA,nB:integer;
himp,jawab:char;
Procedure
himpunan (himp:char;z:integer; var A:larikint; var nA:integer);
var i:integer;
begin
i:=0;
nA:=0;
while z<>999 do
begin
i:=i+1;
A[i] := z;
write (himp,i,' = '); readln(z);
nA:=nA+1;
end;
nA:=nA-1;
writeln
('Banyak anggota himpunan ',himp,' = ',nA);
end;
procedure
cetakhimpunan(A:larikInt;nA:integer;himp:char);
var
i:integer;
begin
write(himp,' = { ');
for
i:=2 to nA+1 do
if i<nA+1 then
write(a[i],' , ')
else write(a[i]);
write('}');
writeln;
end;
procedure
cekhimpunan(A,B:larikint;nA,nB:integer);
var
m,n:integer;
sama,c : integer;
begin
if
nA-1<>nB-1 then write ('himpunan A <> himpunan B')
else
begin
sama :=0;
for m:=2 to nA+1 do
begin
n:=1;
for n:=2 to nB+1 do
begin
if A[m]=B[n]
then
sama:=sama+1;
end;
end;
if sama<>nA-1 then write('himpunan A <> himpunan B') else
writeln('himpunan A = himpunan B');
end;
writeln;
end;
BEGIN
repeat
clrscr;
z:=-999;
writeln('masukkan
anggota-anggota himpunan A (jika sudah, inputkan 999) : ');
himp:='a';
himpunan(himp,z,A,nA);
writeln;
himp:='b';
writeln('masukkan anggota-anggota himpunan B
(jika sudah, inputkan 999) : ');
himpunan(himp,z,B,nB);
writeln;
clrscr;
kepala;
himp:='a';
cetakhimpunan(A,nA,himp);
himp:='b';
cetakhimpunan(B,nB,himp);
writeln;
cekhimpunan(A,B,nA,nB);
writeln;
write('ulangi
program (y/t) ? ');
writeln;
readln(jawab );
until jawab='t';
END.
program Kalender;
uses wincrt;
var tanggal, bulan, tahun : integer;
ulang : string;
procedure
namabulan (var bulan : integer);
var nobulan : integer;
begin
write
('masukan tanggal : '); read (tanggal);
write
('masukan bulan : '); read (nobulan);
write
('masukan tahun : '); read (tahun);
writeln;
write
('Tanggal yang anda inputkan : '
,tanggal, ' ');
case nobulan of
1 : write ('januari ');
2 :
write ('februari ');
3 :
write ('maret ');
4 :
write ('april ');
5 :
write ('mei ');
6 : write ('juni ');
7 : write ('juli ');
8 : write ('agustus ');
9 :
write ('september ');
10 : write
('oktober ');
11 : write
('november ');
12 : write
('desember ');
end;
end;
begin
namabulan (bulan); write ( tahun);
writeln;
writeln;
end.
program Rata-rata
Larik;
uses wincrt;
const Nmaks = 100;
type LarikInt = array[1..Nmaks] of integer;
var A :
LarikInt;
i :
integer;
x :
integer;
n:
integer;
maks :
real;
procedure
Bacalarik(x: integer; var A : larikInt);
begin
i:=0;
while x
<> 9999 do
begin
i:= i+1;
A[i]:= x;
write('Nilai[',i, ']= ');readln(x);
end;
end;
procedure
CetakLarik(var A : larikInt);
var n : integer;
begin
for n:=2 to i
do
writeln('[',n-1, ']= ',A[n]);
end;
procedure
Hitungrata(var A :larikInt);
var n : integer;
jumlah :
integer;
rata: real;
begin
jumlah:= 0;
for n:= 2 to i do
jumlah:=jumlah+A[n];
rata:=jumlah/(i-1);
write(rata:0:2);
end;
procedure
Maksimum(var maks : real);
var max, n
: integer;
begin
max:=0;
for n:= 2 to i do
if A[n] >
max then
max:=A[n];
write(max);
end;
begin
Bacalarik(n, A);
writeln;
Cetaklarik(A);
writeln;
write('jadi rata-ratanya adalah: ');
Hitungrata(A);
writeln;
write('jadi nilai maksimum dari semua datanya adalah: ');
Maksimum(maks);
end.
Program RataRata;
uses wincrt;
var i,n : integer;
u :real;
procedure
HitungRataRata (n:integer; var u:real);
var x,k,j :
integer;
begin
write ('n = ');
readln (n);
j := 0;
for k := 1 to n
do
begin
write ('x
= '); readln (x);
j := j+x;
u := j/n;
end;
write
('Rata-rata = ',u:0:2);
end;
begin
HitungRataRata
(n,u);
end.
program jamberikut;
uses wincrt;
var jam,menit,detik:longint;
j:integer;
procedure jamberikutnya(var jam,menit,detik:longint);
var
totaldetik,
sisadetik,sisa: longint;
begin
totaldetik:=
jam*3600 + menit*60 + detik+1;
sisa:= totaldetik;
jam:= sisa div
3600;
sisadetik:= sisa
mod 3600;
menit:= sisadetik
div 60;
detik:= sisadetik
mod 60;
end;
BEGIN
write('masukkan
jam: ');
readln(jam);
write('masukkan
menit: ');
readln(menit);
write('masukkan
detik: ');
readln(detik);
writeln('jam
awal:');
write(jam, ':',
menit, ':', detik);
jamberikutnya(jam,menit,detik);
writeln;
writeln('jam
berikutnya setelah 1 detik: ');
write(jam, ':',
menit, ':', detik);
END.
program
Pengolahan_Data;
uses wincrt;
type larik = array [1..100] of string;
larikan = array
[1..100] of integer;
var
H,M :larikan;
A : larik;
i,no,jumlah,y,z,n,menu:integer;
rata:real;
procedure input;
begin
z:=999;
y:=0;
i:=0;
jumlah:=0;
M[i]:=H[i];
while
A[i]<> 'berhenti' do
begin
i:=i+1;
write('Nama
Mahasiswa: ');
readln(A[i]);
if A[i]<>
'berhenti' then
begin
write('Nilai
: ');
readln(H[i]);
end;
jumlah:=jumlah+H[i];
if H[i] > y
then
begin
y:=
H[i];
end;
if (H[i] <
z) and (H[i] >0 )then
begin
z := H[i];
end;
end;
n:=i-1;
rata:=
jumlah/(n);
end;
procedure diatasrataan;
begin
writeln
('rata-rata data : ',rata:2:2);
writeln;
writeln ('daftar
nama yang diatas rata-rata : ');
i:=0;
while i<>n
do
begin
i:=i+1;
if (H[i] >
rata) then
begin
writeln
(A[i],' dengan nilai : ',H[i],' ');
writeln;
writeln;
end;
end;
end;
procedure
dibawahrataan;
begin
writeln ('daftar
nama yang dibawah rata-rata: ');
writeln;
i:=0;
while i<>n
do
begin
i:=i+1;
if (H[i] <
rata) then
begin
writeln
(A[i],' dengan nilai : ',H[i],' ');
end;
end;
end;
procedure max;
begin
writeln ('nilai
maksimum data tersebut: ',y);
i:=0;
writeln('yang
meraih nilai maksimum adalah: ');
while i<>n
do
begin
i:=i+1;
if (H[i] = y)
then
begin
write
(A[i],',');
end;
end;
writeln;
end;
procedure min;
begin
writeln('nilai
minimum data tersebut: ',z);
writeln ('yang
meraih nilai minimum adalah: ');
i:=0;
while i<>n
do
begin
i:=i+1;
if (H[i] = z)
then
begin
write
(A[i],',');
end;
end;
end;
BEGIN
writeln
('':15,' Masukan Nama dan
Nilai ');
writeln
('':15,' ');
writeln ('Ket:
inputkan"berhenti" bila ingin menghentikan inputan data mahasiswa');
input;
writeln;
clrscr;
begin
repeat
writeln;
writeln('No Menu
Pilihan:');
writeln ('1:
Rata-rata, nilai diatas rata-rata dan dibawah rata-rata ');
writeln ('2:
Nilai maksimum dan minimum dari semua data');
writeln ('3:
keluar ');
writeln;
writeln;
writeln('Pilih
menu Yang anda inginkan: ');
read ( no);
clrscr;
if no > 3
then writeln ('':15,'!!!!!maaf pilihan anda salah');
writeln;
case no of
1:
begin
diatasrataan;
dibawahrataan;
writeln;
writeln;
end;
2:
begin
max;
min;
end;
3:
begin
menu := 3;
writeln('');
writeln('');
end;
end;
until menu = 3;
end;
END.
program himpunan_irigab;
uses wincrt;
const Nmaks=100;
type LarikInt =
array[1..Nmaks] of integer;
var
A,B,irisan:larikInt;
i,z,nA,nB:integer;
himp,jawab,masuk:char;
Procedure
himpunan (himp:char;z:integer; var A:larikint; var nA:integer);
var
i:integer;
begin
i:=0;
nA:=0;
while z<>999 do
begin
i:=i+1;
A[i] := z;
write (himp,i,' = '); readln(z);
nA:=nA+1;
end;
nA:=nA-1;
writeln
('Banyak anggota himpunan ',himp,' = ',nA);
end;
procedure
cetakhimpunan(A:larikInt;nA:integer;himp:char);
var i:integer;
begin
write(himp,' = { ');
for
i:=2 to nA+1 do
if i<nA+1 then
write(a[i],' , ')
else write(a[i]);
write(' }');
writeln;
end;
procedure
cekhimpunan(A,B:larikint;nA,nB:integer;var irisan:larikint;var i:integer);
var
m,n:integer;
sama,c : integer;
begin
sama:=0;
i:=0;
for
m:=2 to nA+1 do
for n:=2 to nB+1 do
if A[m]=B[n] then
begin
sama:=sama+1;
i:=i+1;
irisan[i] :=
A[m];
end;
if
sama<>nA then writeln('himpunan A dan himpunan B berbeda')
else writeln('himpunan A dan himpunan B sama');
writeln('nA=',nA,' , nB=',nB);
end;
procedure
irisanhimpunan(irisan:larikint;i:integer);
var m:integer;
begin
write('irisan himpunan A dan B = { ');
for
m:=1 to i do
if m<i then write(irisan[m],' , ')
else write(irisan[m]);
write(' }');
end;
procedure
gabunganhimpunan(A,B,irisan:larikint;nA,nB,i:integer);
var
gabungan:larikint;
m,n,j,sama,samatidak:integer;
begin
sama:=0;
samatidak:=sama;
j:=0;
for
m:=2 to nA+1 do
begin
for n:=1 to i do
if A[m]=irisan[n] then sama:=sama+1;
if samatidak=sama then
begin
j:=j+1;
gabungan[j]:=A[m];
end;
samatidak:=sama;
end;
sama:=0;
samatidak:=sama;
for
m:=2 to nB+1 do
begin
for n:=1 to i do
if B[m]=irisan[n] then sama:=sama+1;
if samatidak=sama then
begin
j:=j+1;
gabungan[j]:=B[m];
end;
samatidak:=sama;
end;
write('gabungan himpunan A dan B = { ');
for
m:=1 to i do
if j=0 then if m<i then write(irisan[m],' , ')
else
write(irisan[m])
else write(irisan[m],' , ');
for
m:=1 to j do
if m<j then write(gabungan[m],' , ') else write(gabungan[m]);
writeln(' }');
end;
BEGIN
repeat
writeln('':13,'tekan enter dua kali untuk masuk program');
readln(masuk);
clrscr;
z:=-999;
writeln('masukkan
anggota-anggota himpunan A ');
writeln('dengan
syarat(a1<>a2)');
writeln('inputkan
"999" untuk berhenti ');
writeln;
himp:='A';
himpunan(himp,z,A,nA);
writeln;
himp:='B';
writeln('masukkan
anggota-anggota himpunan B');
writeln('dengan
syarat( b1<> b2)');
writeln('inputkan
"999" untuk berhenti) : ');
writeln;
himpunan(himp,z,B,nB);
writeln;
clrscr;
nama;
himp:='A';
cetakhimpunan(A,nA,himp);
himp:='B';
cetakhimpunan(B,nB,himp);
writeln;
cekhimpunan(A,B,nA,nB,irisan,i);
writeln;
irisanhimpunan(irisan,i);
writeln;
gabunganhimpunan(A,B,irisan,nA,nB,i);
writeln;
write('ulangi
program (y/t) ? ');
writeln;
readln(jawab );
until jawab='t';
clrscr;
writeln('':10,'-----------------Semoga
Bermanfaat!!!!-------------------');
END.
program sequens;
uses wincrt;
const nmaks = 10;
type mahasiswa = record
nama: string;
nim: integer;
end;
type mhs = array [1..nmaks] of mahasiswa;
var M: mhs;
n,
idx, nimcari: integer;
ulang: string;
masuk:char;
procedure inputdata(var n: integer; var M:
mhs);
var i, y: integer; x: string;
begin
i:=1;
write(' Nama: ');
readln(x);
while x <> 'stop' do
begin
write(' NIM: ');
readln(y);
M[i].nama:=x;
M[i].nim:=y;
i:=i+1;
writeln;
write(' Nama: ');
readln(x);
end;
i:=i-1;
n:=i;
writeln;
end;
procedure tulisdata(n: integer; M: mhs);
var i: integer;
begin
writeln('Data Nama dan NIM Mahasiswa:');
writeln;
for
i:= 1 to n do
begin
writeln(i,'. ',M[i].nama);
writeln('
',M[i].nim);
end;
end;
procedure caridata(n: integer; M: mhs; var
nimcari: integer; var idx: integer);
var i: integer;
begin
writeln;
write('Masukkan NIM yang akan dicari: ');
readln(nimcari);
i:=1;
while (i<n) and (M[i].nim <> nimcari) do
begin
i:=i+1;
end;
if
M[i].nim = nimcari then
idx:=i
else
idx:=-1;
end;
BEGIN
writeln(' ***Ketik
"stop" untuk menghentikan input data***');
writeln;
inputdata(n, M);
clrscr;
tulisdata(n, M);
caridata(n, M, nimcari, idx);
if
idx <> -1 then
writeln('Mahasiswa dengan NIM ',nimcari, ' terdapat dalam data diatas,
yang bernama ',M[idx].nama)
else
begin
n:=n+1;
M[n].nim:=nimcari;
writeln('NIM tidak terdapat dalam data');
writeln('Karena NIM yang diimputkan tidak ada datanya');
write('Masukan data nama mahasiswa dengan NIM (',nimcari,') : ');
readln(M[n].nama);
writeln;
tulisdata(n, M);
end;
END.
program matrik;
uses wincrt;
type data = array[1..10,1..10] of integer;
var matrikI,matrikII : data;
baris,kolom,pil : integer;
masuk:char;
x:string;
procedure isimatrik;
var
i,j : integer;
begin
writeln('Penentuan ORDO MATRIK I');
write('Masukan banyak baris matrik I = ');readln(baris);
write('Masukan banyak kolom matrik I = ');readln(kolom);
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
readln(matrikI[i,j]);
end;
clrscr;
writeln('Penentuan ORDO MATRIK II');
write('Masukan banyak baris matrik II = ');readln(baris);
write('Masukan banyak kolom matrik II = ');readln(kolom);
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
readln(matrikII[i,j]);
end;
end;
procedure jumlahmatrik(m1,m2 : data);
var hasil : data;
i,j : integer;
begin
for i:=1 to baris do
for j:=1 to kolom do
begin
hasil[i,j]:=m1[i,j]+m2[i,j];
end;
clrscr;
writeln('Hasil Penjumlahan MATRIK');
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
write(hasil[i,j]);
end;
end;
procedure kurangmatrik(m1,m2 : data);
var hasil : data;
i,j : integer;
begin
for i:=1 to baris do
for j:=1 to kolom do
begin
hasil[i,j]:=m1[i,j]-m2[i,j];
end;
clrscr;
writeln('Hasil Penjumlahan MATRIK');
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
write(hasil[i,j]);
end;
end;
procedure kalimatrik(m1,m2 : data);
var hasil : data;
i,j,z : integer;
begin
for i:=1 to baris do
for j:=1 to kolom do
begin
hasil[i,j]:=0;
for z:=1 to baris do
hasil[i,j]:=hasil[i,j]+matrikI[i,z]*matrikII[z,j];
end;
clrscr;
writeln('Hasil Penjumlahan MATRIK');
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
write(hasil[i,j]);
end;
end;
BEGIN
writeln('================================================================');
writeln(' P R O G R A M M A T R I K S ');
writeln('================================================================');
writeln;
writeln(' Menu Pilihan : ');
writeln(' (1)
Penjumlahan Matrik');
writeln(' (2) Pengurangan Matrik');
writeln(' (3)
Perkalian Matrik');
writeln;
write(' Pilihan = ');readln(pil);
clrscr;
case pil of
1
: begin
isimatrik;
jumlahmatrik(matrikI,matrikII);
end;
2
: begin
isimatrik;
kurangmatrik(matrikI,matrikII);
end;
3
: begin
isimatrik;
kalimatrik(matrikI,matrikII);
end;
end;
end;
END.
program pencarian;
uses wincrt;
var
i,
no : byte;
s,
cari, lagi, lg : string;
masuk:char;
procedure Input(no : byte; var s : string);
begin
writeln('================================================================');
writeln(' Program Pencarian Huruf dan Kata');
writeln('================================================================');
writeln;
writeln;
writeln('
Anda Memilih No.',no);
if no=1 then writeln(' Program
Pencarian Huruf dalam Teks.')
else begin
if no=2 then writeln(' Program
Pencarian Kata dalam Teks.');
end;
write(' Masukkan Teks : ');
readln(s);
writeln;
end;
procedure CariHuruf(a : string; var na : byte);
var
ns : byte;
begin
ns:=length(s);
na:=0;
for i:=1 to ns do
begin
if s[i]=a then
na:=na+1;
end;
end;
procedure Ulang1;
var
ncari : byte;
begin
lg:='Y';
while (lg='Y') or (lg='y') do begin
write(' Huruf yang dicari : ');
readln(cari);
CariHuruf(cari,ncari);
writeln(' Huruf
"',cari,'" yang Anda cari ada ',ncari); writeln;
write(' Cari huruf lagi? (Y/T)
'); readln(lg);
writeln;
end;
end;
procedure CariKata(x : string; var ketemu : boolean);
var
j, k : byte;
d:integer;
begin
i:=0;
ketemu:=false;
repeat
i:=i+1;
if s[i]=x[1] then
begin
k:=0;
for j:=1 to length(x) do
begin
if s[i+j-1]=x[j] then
k:=k+1;
end;
if k=length(x) then
ketemu:=true;
end;
until (i=length(s)) or (ketemu=true);
end;
procedure JumlahKata(x : string; var d:integer);
var
j, k : byte;
begin
i:=0;
d:=0;
repeat
i:=i+1;
if s[i]=x[1] then
begin
k:=0;
for j:=1 to length(x) do begin
if s[j+i-1]=x[j] then k:=k+1;
end;
if k=length(x) then d:=d+1;
end;
until i=length(s);
end;
procedure Ulang2;
var
ketemu : boolean;
d:integer;
begin
lg:='Y';
while (lg='Y') or (lg='y') do begin
write(' Kata yang dicari : ');
readln(cari);
CariKata(cari,ketemu);
if ketemu then
writeln(' Kata
"',cari,'" yang Anda cari "terdapat dalam" teks.')
else
writeln(' Kata
"',cari,'" yang Anda cari "tidak ada dalam" teks.');
JumlahKata(cari,d);
writeln(' Banyak kata
"',cari,'" ialah : ',d);
write(' Cari kata lagi? (Y/T) ');
readln(lg);
writeln;
end;
end;
BEGIN
lagi:='Y';
while (lagi='Y') or (lagi='y') do
begin
clrscr;
writeln('================================================================');
writeln(' Program
Pencarian Huruf dan Kata');
writeln('================================================================');
writeln;
; writeln('
PILIHAN MENU');
writeln(' 1. Program Pencarian
Huruf');
writeln(' 2. Program Pencarian
Kata');
writeln;
writeln;
write('
Masukkan pilihan Anda : '); readln(no);
if (no<1) or (no>2) then
begin
writeln('
PILIHAN MENU ERROR!!');
writeln;
end;
case no of
1 : begin
clrscr;
Input(no,s);
Ulang1;
end;
2 : begin
clrscr;
Input(no,s);
Ulang2;
end;
end;
write(' Kembali ke
Menu Utama? (Y/T) '); readln(lagi);
clrscr;
if (lagi='T') or (lagi='t') then
begin
end;
end;
END.
Program bagi2
program nimnama;
uses wincrt;
const nmaks= 20;
type Larik= array [1..nmaks] of integer;
var L: Larik;
i,x,n,idx:
integer;
ketemu:boolean;
procedure start;
procedure
input(n:integer;var L:Larik);
begin
for i:=1 to n do
begin
write(i,'. ');
write('masukkan ');readln(L[i]);
end;
end;
procedure
caribgdua(L:Larik;n,x:integer;var idx:integer);
var i,j,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(L[k]<x) then
i:=k+1
else
j:=k-1;
end;
if ketemu then
begin
idx:=k;
write(x,'
ditemukan. data ke- ',idx);
end
else
begin
idx:=-1;
write(x,'
tidak ditemukan ');
end;
end;
BEGIN
write('masukkan n:
');readln(n);
input(n,L);
write('masukkan x:
');readln(x);
caribgdua(L,n,x,idx);
END.
program faktorial;
uses wincrt;
var
n:integer;
function fak( n:integer):integer;
begin;
if n= 0 then fak:=1
else
fak:= n *fak(n-1);
end;
begin
writeln('masukan
nilai dari faktorial yang anda inginkan: ');
readln (n);
writeln('faktorial
yang anda inputkan ',n,'!');
write ('maka
nilainya: ',fak(n));
end.
Program fibonaci;
uses wincrt;
var
n:integer;
Function Fib(n:integer) :integer;
begin
if (n=0) or (n=1) then
Fib:= n
else
Fib:= Fib(n-1) + Fib(n-2);
end;
begin
write('barisan deret ke-berapa(n) dari deret fibonacci yang
anda inginkan = ');readln(n);
Fib(n);
writeln('nilai dari barisan fibonacci ke-',n,' adalah
',Fib(n));
end.
program fpb_uy;
uses wincrt;
var
x,y:integer;
function fpb( x,y: integer):integer;
begin
if y = 0 then
fpb:= x
else
fpb:= fpb(y, x mod y);
end;
begin
write('masukan nilai x = '); readln(x);
write('masukan nilai y = '); readln(y);
fpb(x,y);
write('maka nilai fpb dari kedua inputan itu adalah
',fpb(x,y));
end.
program banyak huruf;
uses wincrt;
var a,b,c,d:integer;
p,q,r:string;
procedure input;
begin;
clrscr;
writeln('program menghitung banyak kata');
writeln('masukkan paraghraf yang diinginkan :');readln(p);
end;
procedure proses;
begin;
writeln('masukan kata yang dicari :');readln(q);
a:=0;
d:=0;
repeat
a:=a+1;
if p[a]=q[1] then
begin
c:=0;
for b:=1 to
length(q) do begin
if p[b+a-1]=q[b]
then c:=c+1;
end;
if c=length(q) then d:=d+1;
end;
until a=length(p);
writeln('banyak kata ialah :',d);
end;
procedure exit;
begin;
clrscr;
end;
BEGIN
r:='y';
repeat
if r='y' then begin
input;
proses;
end else begin
clrscr;
writeln('input salah');
end;
write('ingin mengulang program? (y/n) :');readln(r);
until r='n';
exit;
END.
program pangkat;
uses wincrt;
var
n,k:integer;
function fak( k:integer):integer;
begin;
if k= 0 then fak:=1
else
fak:= n *fak(k-1);
end;
begin
writeln('masukan
nilai yang ingin dipangkatkan: ');
readln (n);
writeln('masukan
nilai pangkat: ');
readln (k);
write ('maka
nilainya: ',fak(k));
end.
program pecahan;
uses wincrt;
const nmaks= 50;
type angka = array [1..nmaks] of integer;
var A: angka;
n, i: integer;
masuk:char;
x:string;
procedure nama;
begin
writeln('
================================================================');
writeln(' P R O G R A M P E C A H A N');
writeln('
================================================================');
end;
procedure input(var n: integer; var A: angka);
var j: integer;
begin
write('Masukkan
jumlah suku: ');
readln(n);
for j:= 1 to n do
begin
write('A[',j,'] = ');
readln(A[j]);
end;
end;
function P(i: integer): real;
begin
if i=n then
P:=A[n]
else
P:=A[i]+(1/P(i+1));
end;
BEGIN
x:='y';
repeat
begin
if x='y'then
clrscr;
nama;
writeln;
writeln;
writeln(' ***tekan enter 2x untuk memulai
program***');
readln(masuk);
clrscr;
writeln('================================================================');
writeln(' Program Mencari Hasil dari Program
Pecahan');
writeln('================================================================');
writeln;
writeln;
writeln;
input(n, A);
i:=1;
writeln;
writeln('Maka nilai pecahan = ',P(i):2:3);
writeln;
write('Apakah
anda ingin mengulang program kembali (Y/N) : ');
readln(x);
end;
until x='n';
if x='n' then
begin
clrscr;
end;
END.
program polinom;
uses wincrt;
type koef = array[1..20] of integer;
var
a:koef;
n,i,x,c:integer;
masuk:char;
procedure nama;
begin
writeln(' ================================================================');
writeln(' P R O G R A M P O L I N O M');
writeln('
================================================================');
end;
Function p( i: integer): real;
begin
if i = n then
p:= a[n]
else
p:= a[i] + x * p(i+1);
end;
procedure input(var
n:integer;var a:koef);
begin
for c:=0 to n do
begin
write('a[',c,'] =
');readln(a[c]);
end;
end;
begin
clrscr;
nama;
writeln;
writeln;
writeln(' ***tekan enter 2x untuk memulai
program***');
readln(masuk);
clrscr;
writeln('================================================================');
writeln(' Program Mencari Hasil dari Fungsi
Polinom');
writeln('================================================================');
writeln;
writeln;
writeln;
writeln('Masalah
Polinom :');
writeln('pn(x) = a0 + a1x + ... + anx^n');
writeln;writeln;
write('masukan pangkat yang anda inginkan = ');
readln(n);
writeln('masukan nilai "a" yang anda inginkan');
input(n,a);
write('masukan nilai x =
');readln(x);
write('jadi hasil dari fungsi polinom adalah ',p(i):2:0);
end.
program hurufke2;
uses wincrt;
var
s:string;
begin
read(s);
write(s[2]);
end.
Program cari_huruf a;
uses wincrt;
var kata:string;
i,x,y:integer;
begin
write('Masukan kata: ');
readln(kata);
y:=length(kata);
x:=0;
for i:=1 to y do begin
if (kata[i]='a') or (kata[i]='A') then begin
x:=x+1;
end;
end;
writeln('Banyak a: ',x);
end
program HitungJmlkarakter;
uses wincrt;
var
kata:string;
procedure Hitungkarakter(nm:string);
var
jmlh:integer;
begin
jmlh:=length(nm);
writeln('banyaknya huruf yang diinputkan adalah ',jmlh,'
huruf');
end;
BEGIN
writeln('masukan kata atau kalimat yang anda inginkan: ');readln(kata);
Hitungkarakter(kata);
END.
Program jumlahvocal;
uses wincrt;
var inputkata,x:string;
jumlah,i,jumVokal:integer;
masukanLagi:char;
begin
repeat
clrscr;
gotoxy(1,2);
write('masukan
kata atau kalimat');
gotoxy(1,4);
readln(inputkata);
x:=inputkata;
jumlah:=0;
for i:=1 to
length(x) do
begin
if x[i] in
['A','I','U','E','O','a','i','u','e','o'] then jumlah:=jumlah+1;
end;
jumVokal:=jumlah;
gotoxy(1,6);
writeln('jumlah
huruf vokal= ',jumVokal);
writeln;
gotoxy(1,10);
write('masukan
kalimat lagi?[Y/T]= ');
masukanLagi:=upcase(readkey);
writeln(masukanLagi);
until
masukanLagi<>'Y';
end
program pengurutan
angka;
uses wincrt;
var A : array [0..99] of integer ;
i,j,N,temp:integer;
pilih:char;
procedure input;
begin
write(' Data
yang ke',j+1,'=');
readln(A[j]);
end;
procedure ascending;
begin
for i:=1 to
(N-1) do
begin
for j:=i
downto 1 do
begin
if A[j]
< A[j-1] then
begin
temp:=A[j];
A[j]:=A[j-1];
A[j-1]:=temp;
end;
end;
end;
writeln('Hasil
setelah pengurutan adalah');
for j:=0 to
(N-1) do
begin
writeln(A[j]);
end;
end;
procedure
discending;
begin
for i:=1 to
(N-1) do
begin
for j:=i
downto 1 do
begin
if A[j]
>A[j-1] then
begin
temp:=A[j];
A[j]:=A[j-1];
A[j-1]:=temp;
end;
end;
end;
writeln
('Hasil setelah pengurutan adalah');
for j:=0
to(N-1) do
begin
writeln(A[j]);
end;
end;
BEGIN
write (' Berapa
masukan anda (maks 100)='); readln(N);
for j:=0 to (N-1)
do
input;
write('hasil
ditampilkan secara ascending atau discending(a/d)?');readln(pilih);
if (pilih='a') OR
(pilih='A')then
ascending;
if (pilih= 'd') or
(pilih='D') then
discending;
END.