F0rUM cUa? mynh` c0 nhJu` cAi hAy cAc' bAn. vAo` xEm vA` lAm` thAnk` vjEn dE? ForUm cUa? mYnh` dc l0n' mAnh nhA
 
Trang ChínhCalendarTrợ giúpTìm kiếmThành viênNhómĐăng kýĐăng Nhập

Share | 
 

 Nhảy Au trên Pascal

Go down 
Tác giảThông điệp
Admin
Admin


Tổng số bài gửi : 105
Join date : 15/07/2010

Bài gửiTiêu đề: Nhảy Au trên Pascal   Sat Jul 17, 2010 6:46 pm

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:Cool;
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://teenclub.freeforums.biz
 
Nhảy Au trên Pascal
Về Đầu Trang 
Trang 1 trong tổng số 1 trang

Permissions in this forum:Bạn không có quyền trả lời bài viết
cậubé :: Ung dung va Yahoo :: Ung dung Pascal-
Chuyển đến