Trang ChínhTrợ giúpTìm kiếmThành viênNhómĐăng kýĐăng Nhập

Share | 
 

 Nhảy Audition trên Pascal

Xem chủ đề cũ hơn Xem chủ đề mới hơn Go down 
Tác giảThông điệp
Admin
Admin
Admin
avatar

Tổng số bài gửi : 165
Join date : 14/09/2008
Age : 24
Đến từ : Quảng Ninh

Bài gửiTiêu đề: Nhảy Audition trên Pascal   Wed Jan 21, 2009 5:21 am

Copy đoạn mã sau vào Pascal để chạy:




Uses crt;
const
bpm=178;
leng=180;


var
scoreplus:longint;
clock:longint absolute $0000:$046C;
time,score,start:longint;
npf,ngr,nco,nb,nm:longint;
dem,perfectx,rythm,l,j,i,lv:longint;
c:char;
deldance,press:boolean;
misses:integer;
s,s1:string;
f:set of 1..10;


{ ================================================== ============= }

procedure hd;
begin

clrscr;
i:=10;

gotoxy(17,i);
textcolor(red); writeln('WELL COME TO AUDITION, WAS WRITTEN BY PASCAN');

inc(i);
gotoxy(2,i);

textcolor(white); writeln('Ban nhan phim ',#24,' ',#25,' ',#26,' ',#27 ,' theo hien thi cua man hinh');

inc(i);
gotoxy(2,i); writeln('Nhan khoang trang de ghi diem khi con tro vao o trung tam');

inc(i);
gotoxy(2,i); write('De vao che do');

textcolor(5); write(' DEL ');
textcolor(white); writeln('(So diem tang len nhieu hon) ban nhan phim Delete');

inc(i);
gotoxy(2,i); writeln('Khi do phim do xuat hien ban phai nhay nguoc lai voi hien thi');

inc(i);
gotoxy(2,i); write('De ket thuc chuong trinh ban hay nhan phim ');

textcolor(yellow); writeln('q');
textcolor(white);

readln;
clrscr;


end;
{ ================================================== ============= }
procedure finish;
var q:byte; cont:boolean;
begin

gotoxy(15,10); writeln('FINISH MOVE');
gotoxy(34,12);
s1:=s;
f:=[];
repeat
cont:=true;
q:=random(9)+1;
if not (q in f) then
begin
f:=f+[q]; delete(s1,q,1);
cont:=false;
case ord(s[q]) of
24: insert(chr(25),s1,q);
25: insert(chr(24),s1,q);
26: insert(chr(27),s1,q);
27: insert(chr(26),s1,q);
end;
end;
until not cont;
for q:=1 to lv do
begin
if q in f then textcolor(red) else textcolor(lightgray);
write(s1[q]);
end;
end;
{ ================================================== ============= }
procedure clear;
begin
textcolor(0);
gotoxy(33,12); writeln('-----------------------------');
textcolor(lightgray);
end;
{ ================================================== ============= }
procedure perfect;
begin
misses:=0;
inc(npf);

inc(perfectx);

textcolor(lightred);
gotoxy(34,10);

if perfectx<=0 then
begin
scoreplus:=150*(lv+1)*4+ord(lv>1)*lv*lv*lv*lv;
writeln('PERFECT');
end else
begin
scoreplus:=250*(lv+1)*perfectx*4+ord(lv>1)*lv*lv*lv*lv;
writeln('PERFECT X ',perfectx);
end;
if lv =10 then score:=score+30000;
textcolor(lightgray);
clear;
end;
{ ================================================== ============= }
procedure great;
begin
misses:=0;
inc(ngr);
perfectx:=-1;

textcolor(green); gotoxy(34,10); writeln('GREAT');
scoreplus:=150*(lv+1)*3+ord(lv>1)*lv*lv*lv;

if lv=10 then score:=score+28000;
clear;
end;
{ ================================================== ============= }
procedure cool;
begin
misses:=0;
inc(nco);
perfectx:=-1;
textcolor(blue); gotoxy(34,10); writeln('COOL');

scoreplus:=150*(lv+1)*2+ord(lv>1)*lv*lv;

if lv =10 then score:=score+25000;
clear;


end;
{ ================================================== ============= }
procedure bad;
begin

misses:=0;
inc(nb);
perfectx:=-1;
textcolor(red);
gotoxy(34,10);
writeln('BAD');
scoreplus:=150*(lv+1)+ord(lv>1)*lv;
if lv =10 then score:=score+22500;
clear;


end;
{ ================================================== ============= }
procedure create;
begin
textcolor(blue); gotoxy(43,13); writeln('C');
textcolor(lightgray);
end;
{ ================================================== ============= }
procedure remove;
begin
textcolor(0); gotoxy(43,13); writeln('C');
textcolor(lightgray);
end;
{ ================================================== ============= }
procedure again;
var q:byte;
begin
j:=1;
gotoxy(34,12); textcolor(lightgray);

if ((not deldance) or (lv<6)) and ( not (lv=10) ) then writeln(s)
else
for q:=1 to lv do
begin
if q in f then textcolor(red) else textcolor(lightgray);
write(s1[q]);
end;
textcolor(lightgray);
end;
{ ================================================== ============= }
procedure miss;
begin
if misses<>3 then inc(nm);
misses:=3;
textcolor(red); gotoxy(34,10); write('MISS');
textcolor(lightgray);
perfectx:=-1;
clear;
scoreplus:=0;


end;
{ ================================================== ============= }
procedure replace(var j:longint; x:longint);
begin

textcolor(green); gotoxy(j+33,12); write(chr(x));
textcolor(lightgray);
inc(j);
end;
{ ================================================== ============= }
procedure perform;
var p,q:byte; cont:boolean;
begin
s1:=s;
f:=[];
for p:=1 to 3 do
repeat
cont:=true;
q:=random(lv-1)+1;
if not (q in f) then
begin
f:=f+[q]; delete(s1,q,1);
cont:=false;
case ord(s[q]) of
24: insert(chr(25),s1,q);
25: insert(chr(24),s1,q);
26: insert(chr(27),s1,q);
27: insert(chr(26),s1,q);
end;
end;
until not cont;
for q:=1 to lv do
begin
if q in f then textcolor(red) else textcolor(lightgray);
write(s1[q]);
end;
end;
{ ================================================== ============= }
procedure timeout;
var o:longint;
begin
o:=(clock-start) div 18;
gotoxy(19,16);
if (leng-o) mod 60 <10 then writeln((leng-o) div 60,':0',(leng-o) mod 60:1)
else
writeln((leng-o) div 60,':',(leng-o) mod 60);
end;
{ ================================================== ============= }
procedure screen;
var p:byte;
begin
textcolor(lightblue);
gotoxy(15,11); writeln('{ }');
gotoxy(40,11); writeln('°±ÛÛÛÛÛ±°');

textcolor(white);
gotoxy( (time*41 div rythm) +15,11);writeln('Û');
textcolor(lightgray);


end;
{ ================================================== ============= }
procedure count;
var x:integer;
begin

x:=time*123 div rythm +3;
if (j>lv) and (misses=1) then
begin
case x of
90:perfect;
87..89,91..93:perfect;
81..86,94..99:cool;
78..80,100..102:bad;
else miss;
end; { end case }
if deldance and (lv>5) then scoreplus:=(scoreplus*3) div 2;
score:=score+scoreplus;
end else
if (misses<>0) and (misses<>3) then
begin
misses:=2;
miss;
end;
end;
{ ================================================== ============= }
procedure main;
begin
score:=0;
deldance:=false;
lv:=1;
time:=0;
rythm:=9000 div bpm;
randomize;
textcolor(lightgray); gotoxy(24,16); writeln('(',bpm:3,' bpm)');
dem:=0;
repeat
screen;
timeout;
textcolor(0); gotoxy(49,14); writeln('----------------------');
textcolor(lightgray); gotoxy(49,14); writeln(score);
if (time mod rythm=0) then
begin
misses:=1;
time:=0;
if lv=10 then
begin
lv:=6;
dem:=0;
end else
if (dem = (lv div 2 +trunc(sqrt(lv))) ) then
begin
dem:=0;
inc(lv);
end;
s:='';
j:=1;
textcolor(0); gotoxy(15,10); writeln('---------------------------------------');
textcolor(lightgray); gotoxy(34,12);

for i:=1 to lv do s:=s+chr(random(4)+24);

if deldance and (lv >5) and (lv<10) then perform else writeln(s);

if lv= 10 then finish;
if lv < 10 then
begin

gotoxy(15,10);
writeln('Level ',lv);
inc(dem);
end;
end;
if keypressed then c:=readkey else c:=#0;
if (ord(c )=72) and (ord(s[j])=24) then replace(j,24) else
if (ord(c )=80) and (ord(s[j])=25) then replace(j,25) else
if (ord(c )=77) and (ord(s[j])=26) then replace(j,26) else
if (ord(c )=75) and (ord(s[j])=27) then replace(j,27) else
if (ord(c )=83) then deldance:= not deldance else
if (ord(c )=32) then count else
if (c<>#0) and (j<=length(s)) then again;

if deldance then create else remove;

delay(90);
inc(time);
if (time*41 div rythm +1> 34) and ((j<=lv) or (misses=1)) and (misses<>0) then miss;
until (c='q') or (clock-start>leng*18);
end;
{ ================================================== ============= }
begin
clrscr;
npf:=0;
ngr:=0;
nco:=0;
nb:=0;
nm:=0;
hd;
start:=clock;
perfectx:=-1;
clrscr;
textcolor(lightgray);
main;
gotoxy(10,18);
writeln('Perfect Great Cool Bad Miss Score');
gotoxy(13,19);
writeln(npf:2,' ',ngr:2,' ',nco:2,' ',nb:2,' ',nm:2,' ',score:8);
readln;
end.

Nếu không nhảy được thì các bạn vào đường lick sau để down file .txt về rồi copy từ file đó ra để chạy
uploading.com Audition.txt.html
Về Đầu Trang Go down
Xem lý lịch thành viên http://lopchungminh.forum-pro.org
 
Nhảy Audition trên Pascal
Xem chủ đề cũ hơn Xem chủ đề mới hơn Về Đầu Trang 
Trang 1 trong tổng số 1 trang
 Similar topics
-
» Audition - Nỗi Buồn Thoáng Qua
» Âu Cơ - Lạc Long Quân - Truyện tranh
» [Walt Disney - 2010] Tangled
» GỬI NGƯỜI TÔI YÊU ĐANG Ở PHƯƠNG XA

Permissions in this forum:Bạn không có quyền trả lời bài viết
 :: Ứng dụng :: Ứng dụng của Pascal-
Chuyển đến