program geometri_with_record; {© yunisusanti informatic engineering UNS} uses wincrt; type titik = record x, y : real; end; garis = record p, q : titik; end; var garisA, garisB : garis; grad, inter, x, y, jrk : real;
procedure identitas; forward; (* memperkenalkan proc identitas yang blm dibuat, tp akan sering dipakai di procedure2 diatasnya *) {================================= fungsi fungsi boolean ============================================} function ISSETITIK (p, q : titik): boolean; dan jarak} begin issetitik := (p.x = q.x) and (p.y = q.y); y1 = y2} end;
{syarat fungsi gradien, intercept, titikpot,
{issetitik bila xP = xQ dan yP=yQ / x1 = x2 &
function ISVERTIKAL (p, q : titik): boolean; begin isvertikal := (p.x = q.x) and (p.y <> q.y); end;
{syarat fungsi gradien}
function ISHORISONTAL (p, q : titik): boolean;
{ishorisontal bila y1 = y2 dan x1 tdk sm dgn
{isvertikal bila x1 = x2 dan y1 tdk sm dgn y2}
x2} begin ishorisontal := (p.y = q.y) and (p.x <> q.x); end; {================================= end fungsi boolean ==============================================}
{================================= begin procedure manipulasi ======================================} procedure manipulasi; {------------------begin of gradien-----------------------------------------------------------------} procedure gradienku; function GRADIEN (p, q : titik): real; begin (* syarat dari menghitung gradien adl garis TIDAK setitik maupun vertikal *) if (isvertikal(garisA.p, garisA.q) = false) and (issetitik(garisA.p, garisA.q) = false) and (isvertikal(garisB.p, garisB.q) = false) and (issetitik(garisB.p, garisB.q) = false) then begin grad := (q.y - p.y) / (q.x - p.x); writeln; writeln(' ',grad:5:2); end
{rumus menghitung gradien}
else begin clrscr; gotoXY(15, 8); writeln('ada garis yang setitik/ vertikal, gradien tidak bisa dihitung !!'); gotoXY(15,10); write ('anda harus kembali ke menu !!');readln; identitas; end; end; begin clrscr; gotoXY(15, 6); writeln('" gradien kedua garis "'); gotoXY(15, 9); writeln('- gradien garis A'); {untuk gradien dr garis A}
gradien(garisA.p,garisA.q);
{memanggil fungsi gradien}
gotoXY(15,13); writeln('- gradien garis B'); gradien(garisB.p,garisB.q);
{untuk gradien dr garis B} {memanggil fungsi gradien}
end;
{----------------------------end of gradien---------------------------------------------------------} {------------------- begin of intercept ------------------------------------------------------------} procedure intersepku; function INTERCEPT (p,q: titik): real; begin
{intercept bisa dihitung jika garis tdk
setitik} if (issetitik(garisA.p, garisA.q) = false)
and (issetitik(garisA.p, garisA.q) =
false) then begin
{rumus menghitung intercept} inter := (p.y)-((p.x)*((q.y - p.y) / (q.x - p.x))); writeln; writeln(' ',inter:5:2);
end else begin clrscr;
{jika garis setitik, maka intercept tdk
bs dhitung} gotoXY(15, 8); writeln('ada garis yang setitik, intercept tidak bisa dihitung !!'); gotoXY(15,10); write
('anda harus kembali ke menu !!');readln; identitas; end;
end; begin clrscr; gotoXY(15, 6); writeln('" intercept kedua garis "'); gotoXY(15, 9); writeln('- intercept garis A'); intercept(garisA.p,garisA.q); gotoXY(15,13); writeln('- intercept garis B'); intercept(garisB.p, garisB.q);
{intercept garis A} {memanggil fungsi intercept} {intercept garis B} {memanggil fungsi intercept}
end; {------------------- end of intercept --------------------------------------------------------------} {------------------- begin of titikpot -------------------------------------------------------------} procedure TITIKPOTONG; var grad1, grad2, int1, int2 : real; begin with garisA do begin {menghitung gradien dan intersep garis A} grad1 := (q.y - p.y) / (q.x - p.x); int1 := (p.y)-((p.x)*((q.y - p.y) / (q.x - p.x))); end; with garisB do begin {menghitung gradien dan intersep garis A} grad2 := (q.y - p.y) / (q.x - p.x); int2 := (p.y)-((p.x)*((q.y - p.y) / (q.x - p.x))); end; {dibawah ini bentuk lain fungsi ISPARALEL -> yaitu mengecek apakah kedua gradien sama} if (grad1 = grad2) then writeln(' tidak bisa dihitung titik potongnya !!') else begin {jika gradien tidak sama maka hitung titikpotong} x := (int2 - int1) / (grad1 - grad2); y := grad1*x + int1; writeln('
(',x:2:0,',',y:2:0,')'); end;
end; {------------------------------ end of titikpot --------------------------------------------------} {----------------------- begin of persamaan garis ------------------------------------------------} procedure PERSAMAAN1; {mencetak persamaan dari garis A / garis yg pertama} begin if (isvertikal(garisA.p, garisA.q) = false) then {mengecek apakah tidak vertikal}
begin
{persamaan y=intercept bila isvertikal
false dan {ishorisontal true} if (ishorisontal(garisA.p, garisA.q) = true) then writeln(' y = ',inter:2:1) else {persamaan utuh / y=gradX + intercept jika begin writeln(' end else writeln('
{isvertikal dan ishorisontal false} y = ',grad:2:1,'x + ',inter:2:1,''); end; x = ',garisA.p.x);
{pers x=pX jika garisnya vertikal}
end; procedure PERSAMAAN2;
{mencetak persamaan garis B / garis kedua}
begin if (isvertikal(garisB.p, garisB.q) = false) then begin if (ishorisontal(garisB.p, garisB.q) = true) then writeln(' y = ',inter:2:1) else begin writeln(' y = ',grad:2:1,'x + ',inter:2:1,''); end; end else writeln(' x = ',garisB.p.x); end;
{------------------- end of persamaan garis -------------------------------------------------------} begin clrscr; gradienku; readln; {memanggil/ menampilkan gradien dan intercept} intersepku; readln; clrscr; {menampilkan persamaan garis } gotoXY(10, 6); writeln('" persamaan garis A dan garis B "');writeln; persamaan1; writeln; persamaan2; readln; clrscr; {menampilkan titik potong} gotoXY(10, 6); writeln('" titik potong garis A dan garis B "');writeln; titikpotong; writeln; writeln; write(' # press -enter- to back to menu... '); readln; identitas; {kembali ke identitas / menu} end; {================================= end procedure manipulasi =======================================} {================================= begin menghitung jarak =========================================} procedure jarakqu; function JARAK (p, q : titik): real ; begin jrk := sqrt(sqr(q.x - p.x) + sqr(q.y - p.y));writeln; {rumus menghitung jarak} writeln(' jarak is ', jrk:5:1); end; var pil : char; begin clrscr; gotoXY(15, 7); writeln('" ingin menghitung jarak titik dari garis mana "'); gotoXY(15, 9); writeln('a. garis A B. garis B '); gotoXY(13,18); write ('silahkan pilih !! '); readln(pil); if pil = 'a' then {jika ingin menghitung jarak titik dari garis A} begin {syarat menghitung jarak jika tidak setitik} if (issetitik(garisA.p, garisA.q) = false) then jarak(garisA.p, garisA.q) else begin clrscr; gotoXY(15, 8); writeln('garis setitik, jarak tidak bisa dihitung !!'); gotoXY(15,10); write ('anda harus kembali ke menu !!');end; end; if pil = 'b' then
{jika ingin menghitung jarak titik dari garis B}
begin if issetitik(garisB.p, garisB.q) = false then jarak(garisB.p, garisB.q) else begin clrscr; {jika garis ternyata setitik} gotoXY(15, 8); writeln('garis setitik, jarak tidak bisa dihitung !!'); gotoXY(15,10); write ('anda harus kembali ke menu !! ');end; end; readln; identitas; {kembali ke menu utama / identitas} end; {==================================== end menghitung jarak =======================================}
{================================= begin procedure cetaktitik ====================================} procedure CETAKTITIK; var i : byte; begin clrscr; gotoXY(19, 6); writeln('" hasil cetak titik "'); gotoXY(15, 8); writeln('-------------------------------------------'); gotoXY(15, 9); writeln('-- nama garis titik ke x y --'); gotoXY(15,10); writeln('-------------------------------------------'); with garisA do {mencetak titik garis A} begin writeln('garis a':25, '1':11, p.x:9:0, p.y:7:0); writeln('garis a':25, '2':11, q.x:9:0, q.y:7:0); writeln; end; with garisB do {mencetak titik garis B} begin writeln('garis b':25, '1':11, p.x:9:0, p.y:7:0); writeln('garis b':25, '2':11, q.x:9:0, q.y:7:0); end; writeln; gotoXY(15,21); write('please select -enter- untuk menghitung jarak 2 titik !! readln; jarakqu; {memanggil proc untuk menghitung jarak}
');
end; {================================= end procedure cetaktitik ========================= ============}
{================================= begin procedure inputdata =====================================} procedure INPUTDATA; procedure garissatu; {input untuk garis A} begin clrscr; gotoXY(15,7); writeln('" inputkan 2 buah titik untuk garis A " '); writeln;writeln; writeln(' " titik ke (1) "'); with garisA do begin write(' nilai x = '); readln(p.x); write(' nilai y = '); readln(p.y); writeln; end; writeln(' " titik ke (2) "'); with garisA do begin write(' nilai x = '); readln(q.x); write(' nilai y = '); readln(q.y); writeln; end; end; procedure garisdua; {input untuk garis B} begin clrscr; gotoXY(15,7); writeln('" inputkan 2 buah titik untuk garis B" '); writeln;writeln; writeln(' " titik ke (1) "'); with garisB do begin
write(' write(' end; writeln(' with garisB do begin write(' write(' end;
nilai x = nilai y =
'); readln(p.x); '); readln(p.y); writeln;
" titik ke (2) "');
nilai x = nilai y =
'); readln(q.x); '); readln(q.y); writeln;
end; var pil : char; label 1; begin garissatu; garisdua; 1: clrscr; gotoXY(15, 6); writeln('" ingin manipulasi titik atau garis "'); gotoXY(15, 8); writeln('a. titik'); gotoXY(15,10); writeln('b. garis'); gotoXY(15,13); write('silahkan pilih !!
'); readln(pil);
if pil = 'a' then cetaktitik; {jika ingin manipulasi titik/ cetak titik dan menghitung jarak} if pil = 'b' then manipulasi else goto 1;
{jika ingin manipulasi garis/ gradien, intersept, dll}
end; {================================ begin procedure inputdata ======================================}
{================================= begin procedure identitas =====================================} procedure IDENTITAS; label 1; var pil : char; begin 1: clrscr; gotoXY(15, 9); write('- n a m e " yuni susanti "'); gotoXY(15,11); write('- n i m " M0507054 "'); gotoXY(15,13); write('- program name " manipulasi perhitungan dasar geometri "'); gotoXY(15,15); write('- d a t e " 6 Maret 2008, at 07.39 pm "'); gotoXY(25,21); write('select (a) to start, and (b) to quit '); gotoXY(25,23); write('then press enter !! '); readln(pil); if pil = 'a' then inputdata; {memanggil procedure inputdata} if pil = 'b' then begin clrscr; gotoXY(15, 6); write('Thanks 4 Use This Program Of Geometry Manipulation !!!'); gotoXY(15,10); write('... press any key to quit ^^ ... '); readkey; donewincrt; end else goto 1; {jika pil selain a/ b maka akan kembali ke label 1} end; {================================= end procedure identitas =======================================}
{================================= MAIN program ==================================================} begin screensize.x := 90; {lebar screen horisontal/ x } screensize.y := 400; {lebar screen vertikal/ y } identitas; end. {================================= END PROGRAM ===================================================}
