Pascal's Algorithm
Pengertian algoritma
pemrograman adalah suatu alur yang dipergunakan dalam suatu perhitungan atau
pemecahan suatu masalah secara sistematis, serta dalam kegiatan pemrograman
algoritma biasanya dianggap sebagai sebuah logika untuk menentukan program yang
akan dibuat. Dalam definisi lain, algoritma pemrograman adalah serangkaian
proses yang wajib diikuti dalam suatu perhitungan pemecahan masalah yang lain,
terutama pada program komputer. Algoritma pemrograman adalah suatu pemecahan
masalah dengan suatu susunan yang logis berdasarkan sistematika tertentu. Berikut beberapa Contoh Pemograman Pascal.
1. Program Tetris 2 Playerprogram tetris_2player;
uses crt;
type _points = array [1..4] of record
x,y : longint;
end;
tetris = record
points : _points;
cshape, nshape, xmodel, xtetris, ymodel, ytetris : longint;
end;
Const template : array [1..8] of _points =
(((x:1; y:1),(x:1; y:2),(x:2; y:1),(x:2; y:2)),
((x:2; y:1),(x:1; y:1),(x:3; y:1),(x:4; y:1)),
((x:1; y:2),(x:1; y:1),(x:1; y:3),(x:2; y:3)),
((x:2; y:2),(x:2; y:1),(x:2; y:3),(x:1; y:3)),
((x:1; y:2),(x:1; y:1),(x:2; y:2),(x:2; y:3)),
((x:1; y:2),(x:2; y:1),(x:2; y:2),(x:1; y:3)),
((x:1; y:2),(x:1; y:1),(x:1; y:3),(x:2; y:2)),
((x:1; y:2),(x:2; y:1),(x:2; y:2),(x:2; y:3)));
var field : array [1..79,1..25] of boolean;
tetris1, tetris2, ttetris : tetris;
quit,gameover : boolean;
answer : char;
procedure init_field;
var i : longint;
begin
clrscr; fillchar(field,sizeof(field),0);
for i := 3 to 22 do
begin
gotoxy(20,i); write(#186); field[20,i] := true;
gotoxy(36,i); write(#186); field[36,i] := true;
gotoxy(60,i); write(#186); field[60,i] := true;
gotoxy(76,i); write(#186); field[76,i] := true;
end;
for i := 1 to 15 do
begin
gotoxy(20+i,23); write(#205); field[20+i,23] := true;
gotoxy(60+i,23); write(#205); field[60+i,23] := true;
end;
gotoxy(20,23); write(#200);
gotoxy(60,23); write(#200);
gotoxy(36,23); write(#188);
gotoxy(76,23); write(#188);
gotoxy(6,4); write('Next:');
gotoxy(46,4); write('Next:');
end;
procedure drawtetris(objek : tetris; mode : Boolean);
var i : longint;
c : char;
begin
if mode then c := #178 else c := #32;
for i := 1 to 4 do
begin
field[objek.points[i].x,objek.points[i].y] := mode;
gotoxy(objek.points[i].x, objek.points[i].y);
write(c);
end;
gotoxy(1,1);
End;
procedure dropnew(var objek : tetris);
var i : longint;
begin
if objek.cshape <> 0 then
begin
for i := 1 to 4 do
begin
ttetris.points[i].x := template[objek.nshape,i].x + objek.xmodel;
ttetris.points[i].y := template[objek.nshape,i].y + objek.ymodel;
end;
drawtetris(ttetris,false);
end;
objek.cshape := objek.nshape;
objek.nshape := random(8) + 1;
for i := 1 to 4 do
begin
objek.points[i].x := template[objek.cshape,i].x + objek.xtetris;
objek.points[i].y := template[objek.cshape,i].y + objek.ytetris;
ttetris.points[i].x := template[objek.nshape,i].x + objek.xmodel;
ttetris.points[i].y := template[objek.nshape,i].y + objek.ymodel;
if field[objek.points[i].x,objek.points[i].y] then
begin
gameover := true;
break;
end;
end;
drawtetris(objek,true);
drawtetris(ttetris,true);
end;
procedure init_tetris(var objek : tetris; id : longint);
begin
objek.nshape := random(8) + 1;
if id = 1 then
begin
objek.xmodel := 7; objek.xtetris := 26;
end else begin
objek.xmodel := 47; objek.xtetris := 66;
end;
objek.ymodel := 5; objek.ytetris := 2;
dropnew(objek);
end;
procedure eliminate(objek : tetris; y : longint);
var i,j,k : longint;
blank : boolean;
begin
for i := y downto 3 do
begin
blank := false;
for j := objek.xmodel + 14 to objek.xmodel + 28 do
if not field[j,i] then
begin
blank := true;
break;
end;
if not blank then
begin
for k := i downto 3 do
begin
gotoxy(objek.xmodel + 14,k);
for j := (objek.xmodel + 14) to (objek.xmodel + 28) do
begin
if field[j,k-1] then write(#178) else write(#32);
field[j,k] := field[j,k-1];
end;
end;
eliminate(objek,i);
break;
end;
end;
end;
procedure slide(var objek : tetris);
var i : longint;
dropped : boolean;
begin
drawtetris(objek,false);
ttetris := objek;
dropped := false;
for i := 1 to 4 do
begin
inc(ttetris.points[i].y);
if field[ttetris.points[i].x,ttetris.points[i].y] then
begin
dropped := true;
break;
end;
end;
if not dropped then objek := ttetris;
drawtetris(objek,true);
if dropped then
begin
eliminate(objek,22);
dropnew(objek);
end;
end;
procedure rotate(var objek : tetris);
var i : longint;
collide : boolean;
begin
drawtetris(objek,false);
ttetris := objek;
collide := false;
for i := 2 to 4 do
begin
ttetris.points[i].y := objek.points[1].y + objek.points[i].x - objek.points[1].x;
ttetris.points[i].x := objek.points[1].x - objek.points[i].y + objek.points[1].y;
if field[ttetris.points[i].x,ttetris.points[i].y] then
begin
collide := true;
break;
end;
end;
if not collide then objek := ttetris;
drawtetris(objek,true);
end;
procedure shift(var objek : tetris; x, y : longint);
var i : longint;
collide : boolean;
begin
drawtetris(objek,false);
ttetris := objek;
collide := false;
for i := 1 to 4 do
begin
ttetris.points[i].x := objek.points[i].x + x;
ttetris.points[i].y := objek.points[i].y + y;
if field[ttetris.points[i].x,ttetris.points[i].y] then
begin
collide := true;
break;
end;
end;
if not collide then objek := ttetris;
drawtetris(objek,true);
if collide then eliminate(objek,22);
end;
procedure userinput;
var i : longint;
c : char;
begin
for i := 1 to 20 do
begin
if keypressed then
begin
c := upcase(readkey);
case c of
'W' : if tetris1.cshape <> 1 then rotate(tetris1);
#72 : if tetris2.cshape <> 1 then rotate(tetris2);
'A' : shift(tetris1,-1,0);
#75 : shift(tetris2,-1,0);
'S' : shift(tetris1,0,1);
#80 : shift(tetris2,0,1);
'D' : shift(tetris1,1,0);
#77 : shift(tetris2,1,0);
#27 : gameover := true;
#32 : repeat delay(10); until keypressed;
end;
end;
delay(10);
end;
end;
begin
randomize;
while not quit do
begin
init_field;
init_tetris(tetris1,1);
init_tetris(tetris2,2);
gameover := false;
while not gameover do
begin
slide(tetris1);
slide(tetris2);
userinput;
end;
gotoxy(1,25); write('Play Again[Y/N]? ');
repeat
answer := upcase(readkey);
until answer in ['Y','N',#27];
if (answer = 'N') or (answer = #27) then break;
end;
end.
2. Program Matrix
uses crt;
var
a,b,c,d,e,g:integer;
f:char;
begin clrscr;
write('Tekan dan lihat hasilnya :D');
writeln;
writeln('Meka');
writeln('Kelas XI MIPA 4/14');
readln; clrscr;
// sintak matrik dengan perulangan repeat until
Repeat
a:=1+random(120);
b:=1+random(49);
c:=random(10);
g:=2+random(27); // ubah angka 30 jadi 28 atau lebih kecil
For d:=b to b+c do
Begin
If d<50 then
Begin
f:=chr(random(255));
For e:=1 to 3 do
Begin
If e = 1 then
textcolor(10)
Else
textcolor(2);
gotoxy(a,g);
// delay(10);
Write(f);
End;
End;
End;
until keypressed;
end.
3. Program Sudoku
program sudoku;
uses crt,dos;
type
puzzle=array[0..80]of integer;
arraysol=array[0..2]of puzzle;
waktu=record
jam,menit,detik,sec:word;
end;
const
database:arraysol=(
(4,2,9,3,1,6,5,7,8
,8,6,7,5,2,4,1,9,3
,5,1,3,8,9,7,2,4,6
,9,3,1,7,8,5,6,2,4
,6,8,2,9,4,1,7,3,5
,7,4,5,2,6,3,9,8,1
,3,5,4,6,7,2,8,1,9
,1,7,8,4,5,9,3,6,2
,2,9,6,1,3,8,4,5,7),
(9,6,5,4,1,8,7,3,2
,1,4,3,2,6,7,9,5,8
,8,2,7,9,5,3,6,1,4
,5,7,9,3,8,4,1,2,6
,4,1,2,6,9,5,3,8,7
,6,3,8,1,7,2,4,9,5
,3,5,4,7,2,1,8,6,9
,7,8,6,5,3,9,2,4,1
,2,9,1,8,4,6,5,7,3),
(1,2,5,8,9,7,6,3,4
,6,7,4,5,1,3,9,2,8
,3,9,8,4,2,6,1,5,7
,4,8,2,6,5,9,7,1,3
,7,6,9,2,3,1,4,8,5
,5,3,1,7,8,4,2,9,6
,2,4,3,9,7,5,8,6,1
,9,5,6,1,4,8,3,7,2
,8,1,7,3,6,2,5,4,9));
var
arrayrandom:array[1..21]of integer;
rdonly:array[0..80]of boolean;
currentpuzzle:puzzle;
jawaban:puzzle;
nama:string;
level:integer;
tombol:char;
waktuawal,waktuakhir:waktu;
function chartoint(x:char):integer;
begin
chartoint:=ord(x)-48;
end;
procedure generatearrayrandom;
var i,j,tmp:integer;
valid:boolean;
begin
i:=0;
randomize;
while i<=21 do
begin
valid:=true;
tmp:=random(81);
for j:=1 to i do
begin
if arrayrandom[j]=tmp then
valid:=false;
end;
if valid then
begin
arrayrandom[i]:=tmp;
inc(i);
end;
end;
end;
procedure tampilbox;
var i,j:integer;
begin
clrscr;
for i:=1 to 19 do
begin
for j:=1 to 19 do
begin
if (i=1) or (i=19) or (j=1) or (j=19)
or (i mod 2 <>0) or (j mod 2 <>0)
then
begin
gotoxy(j,i);write('#');
end;
end;
writeln;
end;
gotoxy(2,2);
end;
procedure inputnama;
begin
clrscr;
write('Masukkan nama anda : ');
read(nama);
end;
procedure pilihjawaban;
begin
randomize;
currentpuzzle:=database[random(3)];
end;
procedure transform(tipe: integer);
var i,tmp,tmpindx,mod9,div9:integer;
begin
case tipe of
0:for i:=0 to 80 do {vertikal}
if(i mod 9 < 4) then
begin
tmp:=currentpuzzle[i];
div9:=i div 9;
tmpindx:=(9*div9+8)-(i-(9*div9));
currentpuzzle[i]:=currentpuzzle[tmpindx];
currentpuzzle[tmpindx]:=tmp;
end;
1:for i:=0 to 80 do{diagonal kanan}
if(i div 9 + i mod 9 < 8) then
begin
mod9:=i mod 9;
div9:=i div 9;
tmp:=currentpuzzle[i];
tmpindx:=(8-mod9) * 9 + 8 - div9;
currentpuzzle[i]:=currentpuzzle[tmpindx];
currentpuzzle[tmpindx]:=tmp;
end;
2:for i:=0 to 80 do{diagonal kiri}
if(i div 9 > i mod 9) then
begin
mod9:=i mod 9;
div9:=i div 9;
tmp:=currentpuzzle[i];
tmpindx:=div9+mod9*9;
currentpuzzle[i]:=currentpuzzle[tmpindx];
currentpuzzle[tmpindx]:=tmp;
end;
3:for i:=0 to 80 do {horizontal}
if(i div 9 < 4) then
begin
mod9:=i mod 9;
div9:=i div 9;
tmp:=currentpuzzle[i];
tmpindx:=mod9+(8-div9)*9;
currentpuzzle[i]:=currentpuzzle[tmpindx];
currentpuzzle[tmpindx]:=tmp;
end;
end;
end;
procedure randomjawaban;
var i:integer;
begin
randomize;
for i:=1 to 7 do
transform(random(4));
end;
procedure pilihlevel;
begin
write('Pilih level yang anda inginkan [1--7] : ');
read(level);
if not level in [1,2,3,4,5,6,7] then
level:=7;
end;
function checkrandom(data:integer):boolean;
var
tmp:boolean;
i:integer;
begin
tmp:=true;
for i:=1 to level*3 do
if arrayrandom[i]=data then
begin
tmp:=false;
break;
end;
checkrandom:=tmp;
end;
procedure tampilsebagian;
var i:integer;
begin
generatearrayrandom;
for i:=0 to 80 do
begin
if checkrandom(i) then
begin
gotoxy(2+2*(i mod 9),2+2*(i div 9));
write(currentpuzzle[i]);
jawaban[i]:=currentpuzzle[i];
rdonly[i]:=true;
end;
end;
gotoxy(2,2);
end;
function checkjawaban:boolean;
var i:integer;
tmp:boolean;
begin
tmp:=true;
for i:=0 to 80 do
if jawaban[i]<>currentpuzzle[i] then
begin
tmp:=false;
break;
end;
checkjawaban:=tmp;
end;
begin
textcolor(green);
inputnama;
pilihlevel;
tampilbox;
pilihjawaban;
randomjawaban;
tampilsebagian;
textcolor(red);
gettime(waktuawal.jam,waktuawal.menit,waktuawal.detik,waktuawal.sec);
repeat
tombol:=readkey;
if ord(tombol)=0 then
begin
tombol:=readkey;
case ord(tombol) of(*atas bawah kiri kanan*)
72:if wherey<>2 then
gotoxy(wherex,wherey-2);
80:if wherey<>18 then
gotoxy(wherex,wherey+2);
75:if wherex<>2 then
gotoxy(wherex-2,wherey);
77:if wherex<>18 then
gotoxy(wherex+2,wherey);
end;
end;
if (tombol>='0') and (tombol<='9') and not (rdonly[(wherex div 2 - 1)+(wherey div 2 - 1)*9]) then
begin
jawaban[(wherex div 2 -1)+(wherey div 2 - 1)*9]:=chartoint(tombol);
write(tombol);
gotoxy(wherex-1,wherey);
end;
until (ord(tombol)=27) or checkjawaban;
if checkjawaban then
begin
clrscr;
gettime(waktuakhir.jam,waktuakhir.menit,waktuakhir.detik,waktuakhir.sec);
writeln('selamat, ',nama,' anda sukses pada sudoku level ',level);
write('waktu anda : ');
if waktuakhir.menit-waktuawal.menit<>0 then
write(waktuakhir.menit-waktuawal.menit,' menit');
write(waktuakhir.detik-waktuawal.detik,' detik');
end;
readln;
readln;
normvideo;
end.
4. Program Sulap Angka
PROGRAM SULAPANGKA;
USES CRT;
VAR I, J, K, L: INTEGER;
YT: CHAR;
NILAI:INTEGER;
FUNCTION CSTR(I: INTEGER): STRING;
VAR S: STRING[11];
BEGIN
GOTOXY(30,1); WRITE('WELCOME IN MAGIC NUMBER'); STR(I, S); CSTR := S; END;
PROCEDURE TULIS(POSISI:INTEGER; TEKS:STRING);
VAR A, B, C: INTEGER;
BEGIN
A := POSISI; B := POSISI MOD 10; C := 1;
IF B = 0 THEN BEGIN B := 10;C := 0;
END;
GOTOXY(B * 8 - 5, (A DIV 10 + C) * 3 + 1); WRITE(TEKS);
END;
PROCEDURE BIKIN_KOTAK(KOLOM, BARIS: INTEGER);
BEGIN
CLRSCR;
FOR I:= 1 TO KOLOM DO BEGIN FOR J := 1 TO BARIS DO BEGIN
GOTOXY (J * 8 - 7, (I * 3)); WRITE('____');
GOTOXY (J * 8 - 7, (I * 3 + 1)); WRITE('| |');
GOTOXY (J * 8 - 7, (I * 3 + 2)); WRITE('____');
END;
END;
END;
PROCEDURE WIZARD7;
BEGIN
CLRSCR;
WRITELN('ANGKA YANG ANDA PILIH = ', NILAI);
WRITELN;
WRITE('INGIN MENGULANG (Y/ESC.)? ');READKEY; YT := READKEY;
END;
PROCEDURE WIZARD6;
BEGIN
BIKIN_KOTAK(2, 10);
FOR I := 1 TO 19 DO TULIS(I, CSTR(I + 31));
GOTOXY (5, 15); WRITE('APAKAH ANGKA YANG ANDA PILIH', ' ADA PADA DERETAN ANGKA DI ATAS (Y/T) ');
REPEAT YT := READKEY; UNTIL YT IN ['y', 'Y', 't', 'T', #27];
IF UPCASE(YT) = 'Y' THEN NILAI := NILAI + 32; WIZARD7; {===============================}
END;
PROCEDURE WIZARD5;
BEGIN
BIKIN_KOTAK(2, 10);
FOR I := 1 TO 16 DO TULIS(I, CSTR(I + 15));
FOR J := 17 TO 19 DO TULIS (J, CSTR(J + 31));
GOTOXY (5, 15); WRITE('APAKAH ANGKA YANG ANDA PILIH', ' ADA PADA DERETAN ANGKA DI ATAS (Y/T) ');
REPEAT YT := READKEY; UNTIL YT IN ['y', 'Y', 't', 'T', #27]; {===============================}
IF UPCASE(YT) = 'Y' THEN NILAI := NILAI + 16; WIZARD6;
END;
PROCEDURE WIZARD4;
BEGIN BIKIN_KOTAK(3, 10);
FOR J := 0 TO 2 DO FOR I := 1 TO 8 DO TULIS(J * 8 + I, CSTR(J * 16 + I + 7));
GOTOXY (5, 15); WRITE('APAKAH ANGKA YANG ANDA PILIH', ' ADA PADA DERETAN ANGKA DI ATAS (Y/T) ');
REPEAT YT := READKEY; UNTIL YT IN ['y', 'Y', 't', 'T', #27];
IF UPCASE(YT) = 'Y' THEN NILAI := NILAI + 8; WIZARD5; {===============================}
END;
PROCEDURE WIZARD3;
BEGIN
BIKIN_KOTAK(3, 10);
FOR J := 0 TO 5 DO FOR I := 1 TO 4 DO TULIS(J * 4 + I, CSTR(J * 8 + I + 3));
GOTOXY (5, 15); WRITE('APAKAH ANGKA YANG ANDA PILIH', ' ADA PADA DERETAN ANGKA DI ATAS (Y/T) ');
REPEAT YT := READKEY; UNTIL YT IN ['y', 'Y', 't', 'T'];
IF UPCASE(YT) = 'Y' THEN NILAI := NILAI + 4; WIZARD4; {===============================} END;
PROCEDURE WIZARD2;
BEGIN
BIKIN_KOTAK(3, 10); J:=0;
FOR J := 0 TO 12 DO FOR I := 1 TO 2 DO TULIS(J * 2 + I, CSTR(J * 4 + I + 1));
GOTOXY (5, 15); WRITE('APAKAH ANGKA YANG ANDA PILIH', ' ADA PADA DERETAN ANGKA DI ATAS (Y/T) ');
REPEAT YT := READKEY; UNTIL YT IN ['y', 'Y', 't', 'T', #27];
IF UPCASE(YT) = 'Y' THEN NILAI := NILAI + 2; WIZARD3; {===============================} END;
PROCEDURE WIZARD1;
BEGIN
BIKIN_KOTAK(3, 10); L:= 1;
REPEAT TULIS ((L + 1) DIV 2,CSTR(L)); L:= L + 2; UNTIL L > 50;
GOTOXY (5, 15); WRITE('APAKAH ANGKA YANG ANDA PILIH', ' ADA PADA DERETAN ANGKA DI ATAS (Y/T) ');
REPEAT YT := READKEY; UNTIL YT IN ['y', 'Y', 't', 'T', #27];
IF UPCASE(YT) = 'Y' THEN NILAI := 1; WIZARD2; {===============================}
END;
PROCEDURE TULIS_NOMOR;
BEGIN BIKIN_KOTAK(5, 10);
FOR K:= 1 TO 50 DO TULIS(K, CSTR(K));
GOTOXY(1, 20); WRITE ('PILIH SEBUAH ANGKA, ', 'TEKAN: Y, KALO MAU TERUS! '); WRITE ('TEKAN ESC UNTUK KELUAR ');
REPEAT YT := READKEY; IF UPCASE(YT) = 'Y' THEN
BEGIN
NILAI := 0; WIZARD1;
END;
UNTIL YT IN ['y', 'Y', 't', 'T', #27]; {===============================}
END;
(* Program Utama *)
BEGIN
CLRSCR;
TEXTATTR := $1F; REPEAT TULIS_NOMOR; UNTIL YT = #27;
END.
Komentar
Posting Komentar