Game Pascal

Uses crt;
const
  bpm=176;
  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 PASCAL');
  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.