uses wincrt;
var
nama,hari,weton:string;
tgl,bln,thn:integer;
nh,nw,x1,x2:integer;
procedure masuk;
begin
writeln('
********************************************* ');
writeln(' ****
**** ');
writeln(' ***
SELAMAT DATANG DI PRIMBON PERJODOHAN ***');
writeln(' ***
PROGRAM STUDI PENDIDIKAN MATEMATIKA
***');
writeln(' *** UNIVERSITAS PGRI ADI BUANA SURABAYA ***');
writeln(' **** Dibuat oleh : kelompok 10 **** ');
writeln('
********************************************* ');
writeln;
write(' Masukkan Nama Anda : ');
readln(nama);
write(' Masukkan Tanggal Lahir Anda : '); readln(tgl);
write(' Masukkan Bulan Lahir Anda : ');
readln(bln);
write(' Masukkan Tahun Lahir Anda : ');
readln(thn);
end;
procedure masuk2 ;
begin
writeln;
writeln('
**********************************************************');
writeln;
write(' Masukkan Nama Pasangan Anda : '); readln(nama);
write(' Masukkan Tanggal Lahir Pasangan Anda : ');
readln(tgl);
write(' Masukkan Bulan Lahir Pasangan Anda : '); readln(bln);
write(' Masukkan Tahun Lahir Pasangan Anda : '); readln(thn);
end;
procedure proses;
var
a,b,c,d,x,y,hr,hp:integer;
begin
a:= (thn-1900) div
4;
case bln of
1: if thn mod 4
=0 then b:=0 else b:=1;
2: if thn mod 4 =
0 then b:=31 else b:=32;
3: b:=60;
4: b:=91;
5: b:=121;
6: b:=152;
7: b:=182;
8: b:=213;
9: b:=244;
10:b:=274;
11:b:=305;
12:b:=335;
end;
c:=tgl;
d:=thn-1900;
x:=a+b+c+d;
y:=a+b+c;
hr:= x mod 7;
case hr of
1:hari:='Minggu';
2:hari:='Senin';
3:hari:='Selasa';
4:hari:='Rabu';
5:hari:='Kamis';
6:hari:='Jumat';
else
hari:='Sabtu';
end;
hp:=y mod 5;
case hp of
1:weton:='Legi';
2:weton:='Pahing';
3:weton:='Pon';
4:weton:='Wage';
else
weton:='Kliwon';
end;
end;
procedure harri;
begin
if (hari=
'Minggu') then begin nh:=5; end;
if (hari=
'Senin') then begin nh:=4; end;
if (hari=
'Selasa') then begin nh:=3; end;
if (hari= 'Rabu'
) then begin nh:=7; end;
if (hari=
'Kamis') then begin nh:=8; end;
if (hari=
'Jumat') then begin nh:=6; end;
if (hari=
'Sabtu') then begin nh:=9; end;
end;
procedure pasaran;
begin
if
(weton='Pahing') then begin nw:= 9 ;
end;
if (weton='Pon'
) then begin nw:= 7 ; end;
if
(weton='Wage') then begin nw:= 4 ; end;
if
(weton='Legi') then begin nw:= 5 ; end;
if
(weton='Kliwon') then begin nw:= 8 ;
end;
end;
procedure neptu;
begin
x1:=nh+nw;
end;
procedure neptu2;
begin
x2:=nh+nw;
end;
procedure kelahiran ;
begin
writeln;
write ('
" Hari kelahiran, ',nama, ': ',hari,'',' ',weton,' "');
end;
procedure kecocokan;
var
z,w:integer;
ket:string;
begin
z:= x1+x2;
w := z mod 5 ;
case w of
1:ket:='Cocok';
2:ket:='Lebih
dari Cocok';
3:ket:='Sangat
Cocok';
4:ket:='Kurang
Cocok';
else
ket:='Sangat Tidak Cocok';
end;
writeln;
writeln('
**********************************************************');
writeln;
write('** Hasil
Kecocokan Anda dan pasangan anda :',ket,' **');
writeln;
end;
procedure awal;
var
pilihan:char;
label lagi;
begin
lagi:
clrscr;
masuk;
if (thn <
1900) or (bln > 12) or (tgl > 30) then
begin
writeln;
writeln('^
Maaf tanggal lahir yang Anda masukkan di luar jangkauan ^');
writeln;
write('===================Coba diteliti lagi======================');
readln;
goto lagi
end;
proses;
harri;
pasaran;
neptu;
kelahiran;
masuk2;
if (thn <
1900) or (bln > 12) or (tgl > 30) then
begin
writeln;
writeln('^
Maaf tanggal lahir yang Anda masukkan di luar jangkauan ^');
writeln;
write('===================Coba diteliti lagi======================');
readln;
goto lagi
end;
proses;
harri;
pasaran;
neptu2;
kelahiran;
kecocokan;
writeln;
write('***************** Ingin mencoba lagi?(y/t) **************** '); readln(pilihan);
if (pilihan = 't')
or (pilihan = 'T') then
begin
writeln;
write('============Terima Kasih Atas Kunjungan Anda===============');
end;
if (pilihan =
'y') or (pilihan = 'Y') then
goto lagi;
end;
BEGIN
awal;
readln;
donewincrt;
END.
