Menghitung nilai Sin dengan sudut radian

Langsung aja praktekin y...

program sin(x);
uses crt;
const pi = 3.14;
var
x,rad,p1,tot : real;
n,i,faktor,p2,j : integer;
tanda : byte;

begin

clrscr;
writeln(' Menentukan nilai sin(x)');
write('Nilai x = '); readln(x);
write('Masukkan pangkat = '); readln(n);
rad := pi*x/180;
i := 1;
tanda := 1;
while i <= n do
begin
p1 := exp(i*ln(rad));
faktor := 1;
for j := 1 to i do
faktor := faktor *j;
p2 := faktor;
tot := tot + (tanda*p1/p2);
tanda := (-1)*tanda;
i := i+2;
end;
writeln('Sin(',x:5:2,') = ',tot:5:2);
readln;
end.


Klo ada pertanyaan langsung di komen...
:)

Baca selengkapnya...

Menghitung Luas dan keliling lingkaran

Waktu ini ada seorang teman yang katanya dia lagi belajar turbo pascal..
Program ini penulis buat pada waktu lagi belajar pascal..Semoga yang lagi belajar Pascal bisa cpet ngerti he2...

Program Luas_dan_Keliling_Lingkaran;
uses crt;
const pi = 3.14;
var
r,K,L : real;
begin

clrscr;
writeln('=============================');
writeln('Menghitung Luas dan Keliling');
writeln('----------------------------');
write('Jari - jari = '); readln(r);
K := pi*2*r;
L := pi*r*r;
writeln('Keliling Lingkaran = ',K:5:2);
writeln('Luas Lingkaran = ',L:5:2);
writeln('=============================');
readln;
end.

Klo ada yg belum dimengerti langsung j kasi komen...
:)

Baca selengkapnya...

Program Cek kelulusan dalam bahasa Pascal

program cek_kelulusan_siswa;
uses crt;
var
nama : string[25];
kelas : string[5];
no_absen : string[3];
n_tugas : byte;
n_u_hari : byte;
n_u_umum : byte;
rerata : real;
lulus : boolean;
predikat : string[20];

begin
clrscr;
writeln('====================================================');
writeln('| Program Mengecek Kelulusan Siswa |');
writeln('====================================================');
writeln;
writeln('Input Data Siswa');
writeln('----------------');
write('Nama : '); readln(nama);
write('Kelas : '); readln(kelas);
write('No Absen : '); readln(no_absen);
write('Nilai Tugas : '); readln(n_tugas);
write('Nilai Ulangan Harian : '); readln(n_u_hari);
write('Nilai Ulangan Umum : '); readln(n_u_umum);
rerata:=(n_tugas + 2 * n_u_hari + 3 * n_u_umum)/6;
if rerata >=70 then lulus:=true
else lulus:= false;
clrscr;
writeln('====================================================');
writeln('| Program Mengecek Kelulusan Siswa |');
writeln('====================================================');
writeln;
writeln(' Siswa dengan');
writeln('----------------');
writeln('Nama : ',nama);
writeln('Kelas : ',kelas);
writeln('No Absen : ',no_absen);
writeln('Nilai Tugas : ',n_tugas);
writeln('Nilai Ulangan Harian : ',n_u_hari);
writeln('Nilai Ulangan Umum : ',n_u_umum);
writeln('Rata - rata : ',rerata:0:2);
if lulus then
begin
if rerata < 80 then predikat:='memuaskan'
else if rerata <90 then predikat:='sangat memuaskan'
else predikat:='dengan pujian';
writeln('Dinyatakan Lulus dengan ',predikat);
end
else
writeln('Dinyatakan Tidak Lulus');
readln;
end.

Baca selengkapnya...

Penggunaan Record pada Turbo Pascal

uses crt;
type nilai = record
hari,tugas,umum,na : real;
end;
type mapel = record
kimia,basindo : nilai;
end;
type siswa = record
nama : string[25];
nis : string[3];
mp : mapel;
end;

var
i,n,a : byte;
student : array [1..100] of siswa;
stop : boolean;
b : string[4];
begin
stop := false;
Repeat
clrscr;
write('Banyak siswa : '); readln(n);
clrscr;
writeln('=======================================================================');
writeln('NIS Nama Siswa Mata Pelajaran N.Hr N.Tgs N.Umum N.Akhir');
writeln('-----------------------------------------------------------------------');
a:=4;
for i := 1 to n do
begin
with student[i] do
begin
readln(nis);
gotoxy(6,a);
readln(nama);
with mp do
begin
gotoxy(26,a);
writeln('Bahasa Indonesia');
with basindo do
begin
gotoxy(44,a);
readln(hari);
gotoxy(50,a);
readln(tugas);
gotoxy(57,a);
readln(umum);
na:=(2*hari+tugas+3*umum)/6;
gotoxy(65,a);
writeln(na:3:2);
end;
with kimia do


Download source code lengkapnya di sini

Baca selengkapnya...

Penggunaan If pada Turbo Pascal

Program Toserba;
uses crt;
var
pelanggan : char;
dis : string[3];
tot,blnja : real;
begin
clrscr;
writeln(' Dedix Toserba');
writeln('=================================');
write('Berbelanja sebesar = '); readln(blnja);
write('Pelanggan (y/t) ? : '); readln(pelanggan);

if pelanggan='y' then
begin
if blnja<=100.000 then
begin
tot := blnja -(10/100*blnja);
dis :='20%';
end
else

Download source lengkapnya di sini

Baca selengkapnya...

Mencari nilai Sin(x) dengan x dalam radian

program sin(x);
uses crt;
const pi = 3.14;
var
x,rad,p1,tot : real;
n,i,faktor,p2,j : integer;
tanda : byte;

begin
clrscr;
writeln(' Menentukan nilai sin(x)');
write('Nilai x = '); readln(x);

write('Masukkan pangkat = '); readln(n);
rad := pi*x/180;
i := 1;
tanda := 1;
while i <= n do

Download program lengkap ny di sini..

Baca selengkapnya...

Contoh penggunaan procedure pada Turbo Pascal

program Menu_Program;
uses crt;
var
a:byte;
i,n,x : integer;
sigmay,sigmax,ratax,ratay,sigma,sigma1,sigma2,cov,varian : real;
rerata,hsl : real;
procedure hapus_layar;
begin
clrscr;
end;

procedure mean;
begin
writeln('Menghitung Mean dari beberapa Data');
writeln('----------------------------------');
write('Masukkan banyak data yang akan di input :');
readln(n);
sigma:=0;
for i:=1 to n do
begin
write('Input x',i,' :');
readln(x);
sigma:=sigma + x;
end;
rerata := sigma/n;
writeln('Mean dari data - data terebut adalah ',rerata:5:2);
readln;

end;
procedure varians;
begin
writeln('Menentukan Varians');
writeln('------------------');
write('Masukan banyak data : ');
readln(n);
while n<2 do
begin
writeln('Banyak data harus lebih dari 2');
write('Masukkan banyak data : ');
readln(n);
end;
sigma1 := 0;
sigma2 := 0;
for i := 1 to n do
begin
write('Masukkan data',i,' : ');
readln(x);
sigma1:=sigma1 + x;
sigma2:=sigma2 + (x*x);
end;
hsl :=(n*sigma2 - (sigma1*sigma1))/(n*(n-1));
writeln('Varians = ',hsl:5:2);
readln;
end;
procedure covar;
var
x,y,px,py,k : array [1..100] of real;
begin
write('n = '); readln(n);
sigmax := 0;
sigmay := 0;
for i := 1 to n do
begin
write('x = '); readln(x[i]);
write('y = '); readln(y[i]);
sigmax := sigmax + x[i];
sigmay := sigmay + y[i];
end;
ratax := sigmax/n;
ratay := sigmay/n;
sigma := 0;
for i := 1 to n do
begin
px[i] := x[i] - ratax;
py[i] := y[i] - ratay;
k[i] := px[i]*py[i];
sigma := sigma + k[i];
end;

Download source code lengkapnya di sini..

Ini contoh prosedur program statistik..Keren kan..

Baca selengkapnya...

Perkalian matrix

uses crt;
var
a,b,c : array [1..50,1..50] of integer;
i,j,k,x,y,z : integer;
begin
clrscr;
writeln('Ukuran matrix A');
write('Baris : '); readln(x);
write('Kolom : '); readln(y);
writeln;
writeln('Ukuran matrix B');
writeln('Baris : ',y);
write('Kolom : '); readln(z);
for i:=1 to x do
for j:=1 to y do
begin

write('Elemen A[',i,',',j,'] : ');
readln(a[i,j]);
end;
writeln;
for i:=1 to y do
for j:=1 to z do
begin


Download source code lengkapnya di sini

Baca selengkapnya...

Unit Adjoin

unit adjoin;

interface
type matrix = array [1..10,1..10] of integer;
mi=record
e : matrix;
end;
min = array [1..10,1..10] of mi;
var
i,j,row,col,x,y,k,l : byte;
A : matrix;
function pangkat(var x,n : integer):integer;
procedure tukar(var a,b : integer);
procedure transpose(var A:matrix);


implementation
function pangkat(var x,n : integer):integer;
var
p,i : integer;
begin
p := 1;
for i := 1 to n do
p := p * x;
pangkat:=p;
end;
procedure tukar(var a,b : integer);
var
temp : integer;
begin
temp := a;
a := b;
b := temp;
end;


procedure transpose(var A : matrix);
begin
for i := 2 to row do
for j := 1 to (i-1) do
tukar(A[i,j],A[j,i]);
end;

procedure minor(var m : min; A : matrix);
begin
for i := 1 to (row-1) do
for j := 1 to (col-1) do
begin
x:= 0;
for k :=1 to row do
begin
x:=x+1;
y := 0;
for l := 1 to col do
begin
y:=y+1;


Download source code unit lengkapnya di sini

Pada unit ini juga terdapat prosedur pencarian determinan dan invers matrik..
Keren kan...

Komen yaw..

Baca selengkapnya...

Mencari Covarian

USES CRT;
var
n,i : integer;

x,sigma,sigmax,sigmay,ratax,ratay,cov : real;
procedure covar;
var
x,y,px,py,k : array [1..100] of real;
begin
write('n = '); readln(n);
sigmax := 0;
sigmay := 0;
for i := 1 to n do

Download program lengkapnya di sini ..

Baca selengkapnya...

Administrasi mahasiswa

Program Administrasi_Mahasiswa;
uses crt;
const
pkkspp = 400000;
infospp = 600000;
elekspp = 500000;
bogaspp = 450000;
ptikspp = 500000;
pkkprak = 100000;
infoprak = 500000;
elekprak = 450000;
bogaprak = 600000;
ptikprak = 350000;
sehat : real = 10000;
var

nm,jur : string;
nojur : byte;
tahun :integer;
spp,prak : real;
tot : real;
begin
clrscr;
writeln('Administrasi Mahasiswa Fakultas Teknik dan Kejuruan');
writeln('===================================================');
write('Nama : '); readln(nm);
writeln('Keterangan Jurusan : ');
writeln('1. PKK');
writeln('2. D3 Informatika');
writeln('3. D3 Elektro');
writeln('4. D3 Boga Perhotelan');
writeln('5. PTIK');
write('Jurusan (tulis no saja) : '); readln(nojur);
write('Tahun Masuk : '); readln(tahun);
if tahun<2004 then
begin

if nojur = 1 then
begin
spp := pkkspp;
jur := 'PKK'
end
else if nojur = 2 then
begin
spp :=infospp;
jur := 'D3 Informatika';
end
else if nojur = 3 then
begin
spp :=elekspp;
jur := 'D3 Elektro'
end
else if nojur = 4 then
begin
spp :=bogaspp;
jur := 'D3 Boga Perhotelan';
end
else if nojur= 5 then
begin
spp :=ptikspp;
jur := 'PTIK'
end
else
writeln('Jurusan salah, tolong ulangi !!');

end
else
begin
if nojur = 1 then
begin
spp := pkkspp;
prak:= pkkprak;
jur := 'PKK'
end

else if nojur= 2 then
begin
spp :=infospp;
prak:= infoprak;
jur := 'D3 Informatika';
end
else if nojur = 3 then
begin
spp :=elekspp;
prak:=elekprak;
jur := 'D3 Elektro';
end
else if nojur = 4 then
begin
spp :=bogaspp;
prak:=bogaprak;
jur := 'D3 Boga Perhotelan';
end
else if nojur= 5 then
begin
spp :=ptikspp;
prak:=ptikprak;
jur := 'PTIK';
end
else
writeln('Jurusan salah, tolong ulangi !!');
end;
tot := spp+prak+sehat;
writeln('Nama : ',nm);
writeln('Jurusan : ',jur);
writeln('Tahun Masuk : ',tahun);
writeln('Uang SPP : Rp. ',spp:7:2);
writeln('Uang Praktikum : Rp. ',prak:7:2);
writeln('Uang Kesehatan : Rp. ',sehat:7:2);
writeln('---------------------------------');
writeln('Total Pembayaran : Rp. ',tot:7:2);
writeln('=================================================');
readln;
end.

Baca selengkapnya...

Mengetahui tahun kabisat

Program kabisat;
uses crt;
var
tahun : longint;
begin
clrscr;
writeln('=================================');
writeln('Mengecek Tahun Kabisat atau Bukan');
write('Masukan tahun : '); readln(tahun);
if tahun mod 400 = 0 then
writeln ('Tahun ',tahun,' merupakan kabisat')
else if tahun mod 100 = 0 then
writeln ('Tahun ',tahun,' bukan merupakan kabisat')
else if tahun mod 4 = 0 then

Download source cide lengkap nya di sini.

Baca selengkapnya...

Unit Sorting

unit sort;
interface
uses crt;
type
larik = array [1..100] of integer;
var
i,j,n,y:byte;
copyL,l : larik;
procedure tukar(var a,b:integer);
procedure bubble_asc(var l:larik; n:byte);
procedure bubble_dsc(var l:larik; n:byte);
procedure select_min_asc(var l:larik; n:byte);
procedure select_min_dsc(var l:larik; n:byte);
procedure select_max_asc(var l:larik; n:byte);
procedure select_max_dsc(var l:larik; n:byte);
procedure insert_asc(var l:larik; n:byte);
procedure insert_dsc(var l:larik; n:byte);
procedure anim(var jml:byte);

implementation
procedure tukar(var a,b:integer);
var temp: integer;
begin
temp:=a;
a:=b;
b:=temp;
end;
procedure bubble_asc(var l:larik; n:byte);
begin
for i:=1 to n do
for j:=n downto i+1 do
if l[j] < l[j-1] then
begin
tukar(l[j],l[j-1])
end;
end;
procedure bubble_dsc(var l:larik; n:byte);
begin
for i:=1 to n do
for j:=n downto i+1 do
if l[j] > l[j-1] then
begin
tukar(l[j],l[j-1])
end;
end;


Pada unit ini akan terdapat prosedur - prosedur pengurutan data (sorting) dari ASC dan DESC. Juga terdapat prosedur untuk membuat animasi menu pada pascal. Keren kan....

Download source code dan *.TPU nya di sini.

Baca selengkapnya...

Pengguaan case

Program tokoPD;
uses crt;
const dancowb = 10000;
dancows = 4250;
dancowk = 2100;
indob = 8500;
indos = 4000;
indok = 2025;
milob = 7750;
milos = 4000;
milok = 2200;
suprib = 9600;
supris = 5100;
suprik = 2600;
sustab = 17000;
sustas = 14500;

sustak = 8300;
ovalb = 11250;
ovals = 6500;
ovalk = 3200;
var
no : byte;
ukuran : char;
banyak : longint;
bayar : real;
begin
clrscr;
writeln('===============================================');
writeln(' P & D Toserba');
writeln('Susu yang tersedia di P & D Toserba : ');
writeln('1. Dancow');
writeln('2. Indomilk');
writeln('3. Milo');
writeln('4. Suprima');
writeln('5. Sustagen');
writeln('6. Ovaltime');
writeln('--------------------------------------');
write('No susu : '); readln(no);
write('Ukuran (b:besar,s:sedang,k:kecil) : '); readln(ukuran);
write('Banyak barang : '); readln(banyak);
case no of
1 : begin
case ukuran of
'b' : bayar:=dancowb*banyak;
's' : bayar:=dancows*banyak;
'k' : bayar:=dancowk*banyak;
else writeln('Ukuran salah !!');
end;

Download source code lengkap nya di sini.

Baca selengkapnya...

Menghitung Jumlah huruf pada sebuah kata / kalimat

uses crt;
var
kata : string;
h : array ['A'..'Z'] of byte;
j : char;
i : byte;
begin
clrscr;
write('Input kata : ');readln(kata);
for i := 1 to length(kata) do
begin

for j := 'A' to 'Z' do
begin
if kata[i]= j then
begin

Download program lengkapnya di sini

Baca selengkapnya...

Gaji Pegawai

Program Gaji;
uses crt;
var
nama,alamat : string;
gaji_pkok,tunjangan,pajak,bersih : real;
begin
clrscr;
write('Nama Pegawai : '); readln(nama);
write('Alamat : '); readln(alamat);

write('Gaji Pokok : ');readln(gaji_pkok);
tunjangan := 15/100*gaji_pkok;
pajak := 7.5/100*gaji_pkok;
bersih :=


Download source code lengkap nya di sini.

Baca selengkapnya...

Metode Bagi dua

uses crt;
const epsilon=0.00001;
var
a,b,c,fa,fb,fc : real;

begin
writeln('Mencari akar dari persamaan f(x)=(x^3 + 1)/3');
writeln(' Dengan Metode Bagi Dua');
writeln('============================================');
write('Masukkan batas awal(a) : '); readln(a);
fa:=(a*a + 1)/3;

writeln('f(a) = ',fa:0:5);
repeat
write('Masukkan batas akhir(b) : '); readln(b);
fb:=(b*b +1)/3;
writeln('f(b) = ',fb:0:5);
if fa*fb < 0 then
begin
writeln('Syarat OK (f(a)*f(b)<0)');
writeln('f(a)*f(b) = ',(fa*fb):0:5);
end
else

Download di sini untuk source code lengkap nya..

Komen yaw..

Baca selengkapnya...

Regula Falsi

program regula_falsi;
uses crt;
label ulang;
var
x1,x2,x3,y1,y2,y3 : real;
i : integer;
Ab :char;
data1 : real;
begin

ulang:
clrscr;
writeln('Tentukan nilai akar dari persamaan f(x)=x^3+x^2-3x-3=0 dengan Regula Falsi');
write('Masukan nilai x1 = ');readln(x1);
y1 := x1 * x1 * x1 + x1 * x1 - 3 * x1 - 3;
writeln(' Nilai f(x1)= ',y1:0:4);
repeat
begin
write( 'Masukan nilai x2 = ' ); readln(x2);
y2 := x2 * x2 * x2 + x2 * x2 - 3 * x2 - 3;
write(' Nilai f(x2)= ',y2:0:4);
end;
if (y1*y2)<0 then
Writeln(' Syarat Nilai Ok')
else
Writeln(' Nilai X2 Belum Sesuai');
until ( y1 * y2 ) <0;
writeln;
writeln('Penyelesaian persamaan karekteristik dengan metoda regula falsi');
writeln('----------------------------------------------------------------------');
writeln(' n x f(x) error ');
writeln('----------------------------------------------------------------------');
repeat
begin
i:= i + 1; x3 := ( x2-( y2 / ( y2 - y1))*(x2-x1));
y3 := x3 * x3 * x3 + x3 * x3 - 3 * x3 - 3;
if i<10 then
writeln(' ',i,' : ',x3,' : ',y3,' : ',abs(y3),' : ')
else
writeln(i,' : ',x3,' : ',y3,' : ',abs(y3),' : ');
if ( y1 * y3 ) <0 then
begin
x2 := x3 ; y2 := y3 ;
end
else
begin
x1 := x3 ; y1 := y3;
end;
end;
until abs( y3 ) < 1E-08;
writeln('----------------------------------------------------------------------');
writeln('Akar persamaannya= ',x3);
writeln('Errornya=' ,abs( y3 ));
writeln('----------------------------------------------------------------------');
writeln('Apakah anda ingin mengulangi (y/t): ');
readln(ab);
if (ab='y') or (ab='Y') then
goto ulang;
end.

Baca selengkapnya...

Faktorial

Program FAKTORIAL;

uses crt;

var Faktor : real;
Cacah,
Bil_Awal,
Bil_Akhir,
Konter,
Baris : integer;

begin
clrscr;
writeln('MEMBUAT TABEL FAKTORIAL');
write('BILANGAN AWAL : ');readln(Bil_Awal);
write('BILANGAN AKHIR : ');readln(Bil_Akhir);writeln;


writeln(' TABEL FAKTORIAL');
writeln;
writeln('--------------------------------');
writeln(' BILANGAN HARGA FAKTORIAL');
writeln('--------------------------------');writeln;
Baris := 11;
for Cacah := Bil_Awal to Bil_Akhir do

Mau tau lanjutannya download aj y..Di sini..

Baca selengkapnya...

Unit Search

unit search;

interface

uses crt;
type larik = array [1..100] of integer;
var
i,n, y : byte;
x : integer;
l : larik;
found: boolean;

procedure sequential (var l : larik; x : integer; n:byte);
procedure binary (var l : larik;x: integer; n:byte);

implementation

procedure sequential (var l : larik; x : integer; n:byte);
begin
i:=1;
found := false;
while (not found) and (i<=n) do
begin
if x=l[i] then
found := true
else
i := i +1;
end;
clrscr;
if found then
writeln('Elemen yang bernilai ',x,' berada pada index ke ',i)
else
writeln('Elemen yang bernilai ',x,' tidak ada pada semua index');
writeln('===========================');
writeln(' Index ke- Nilai Data');
writeln('---------------------------');
y := 5;
for i := 1 to n do
begin
gotoxy(6,y);
writeln(i);
gotoxy(21,y);
writeln(l[i]);
inc(y);
end;
writeln('===========================');
end;


procedure binary (var l : larik; x :integer; n:byte);

var
a,iA,iAk,iT : byte;
kondisi : char;
temp : integer;
j : byte;
begin
{prosedur mengurutkan data}
{---------------------------------------}
for i := 1 to (n-1) do
for j := n downto (i+1) do
if l[j] < l[(j-1)] then
begin
temp := l[j];
l[j] := l[(j-1)];
l[(j-1)] := temp;
end;
{---------------------------------------}
a:=0;
iA :=1;
iAk :=n;
found :=false;
while ( not found) and (iA<=iAk) do
begin
iT:=(iA+iAk) div 2;
inc(a);
writeln('Iterasi ke ',a);
writeln('iA = ',iA);

Unit di atas adalah unit yang berisi prosedur - prosedur searching data. Yaitu prosedur binary dan sequential. Download di sini untuk source code dan file *.TPU nya.



Untuk memanggil Unit tersebut maka diperlukan sebuah program.

Program searching;
uses crt,search;
var
option : char;

begin
clrscr;
write('Masukkan banyak data : ');
readln(n);


Download source code nya di sini.

Komen yaw...

Baca selengkapnya...