Collection of Hack-Phreak Scene Programs/cleanhpvac.zip/cleanhpvac/WALLGAME.ZIP/WALL.PAS

Pascal/Delphi Source File | 1991-02-07 | 18KB | 765 lines

(***********************************************************************)
(*                                                                     *)
(*                              WALLGAME                               *)
(*                                                                     *)
(*               A version of The Old Favorite - BREAKOUT              *)
(*                   Copyright Jari Karjala 1987-1990                  *)
(*                                                                     *)
(*                                                                     *)
(*                     This is a FreeWare Program.                     *)
(*               You may copy it to your friends, but if               *)
(*               you change it, don't leave my name out.               *)
(*               This is not begware, so you need not pay              *)
(*               anything to play with this.                           *)
(*                                                                     *)
(***********************************************************************)

{ This version will compile without changes only with Turbo Pascal 5.0. }
{ If you change something, please mark the changes clearly.             }

{$R-,S-,I-,D-,A-,F-,V-,B+,L-,N- }

Uses
  crt,dos;

const
  Max_Wall = 10;
  Max_His = 8;
  Bonus_Brick = 10;
  Extra_Ball_Brick = 11;

type
  str20 = string[20];
  walltype = array[0..7] of string[20];
  AllWalls = array[1..max_wall] of record
                                 wall:walltype;
                                 msg:string[50];
                                 count:integer
                               end;
  HiScoresType = array [1..Max_His] of record
                                         Name : str20;
                                         Score : real;
                                       end;

var
  a,b,
  max_walls_read,
  Wall_no, Balls_left, Bricks_hit, Hit_Count, brick_hit_count,
  Paddle_x, Paddle_move_dir,
  Brick_x, Brick_y, Brick_move_dir, Brick_Type,
  Sav_x_inc, Sav_y_inc, bonus,
  Ball_x, Ball_y, Ball_x_inc, Ball_y_inc : integer;
  Score : real;
  Missed, May_Turn, FX, moving, Quiet, HasMouse : boolean;
  walls : AllWalls;
  wall : walltype;
  HiScores : HiScoresType;
  message : string[255];
  mouse_x,mouse_y : word;


{ Procedures for direct handling of PCompatible hardware }

const
  inverse = $70;
  normal = $f;

  screenseg : word = $B800;
  bmax = 11;

  { 0 1 2 3 4 5 6 7 8 9 : ; < > ? @ A  ... }
  Bricks:array[0..bmax] of string[8] = (#32#7#32#7#32#7#32#7,
                                        #178#$70#178#$70#178#$70#178#$70,
                                        #177#$70#177#$70#177#$70#177#$70,
                                        #176#$70#176#$70#176#$70#176#$70,
                                        #219#$7#219#$7#219#$7#219#$7,
                                        #176#$7f#176#$7f#176#$7f#176#$7f,
                                        #177#$7f#177#$7f#177#$7f#177#$7f,
                                        #178#$7f#178#$7f#178#$7f#178#$7f,
                                        #219#$7f#219#$7f#219#$7f#219#$7f,
                                        #$19#$70#$19#$70#$19#$70#$19#$70,
                                        #219#$7#50#$70#88#$70#219#$7,
                                        #66#$78#65#$78#76#$78#76#$78
                                       );
              {01234567890123}

  Paddle:string[16] = '   ▀▀▀▀▀▀▀▀   ';
  Empty_name:str20 = '             ';

Procedure InitHardWare;
var    regs:registers;
begin
  regs.ax:=0;
  regs.bx:=0;
  intr($33,regs);
  if regs.ax<>0 then begin
    HasMouse := true;
    regs.ax:=2;
    intr($33,regs);    { hide cursor }
    regs.ax:=4;
    regs.cx := 40;
    regs.dx := 0;
    mouse_x := regs.cx;
    mouse_y := regs.dx;
    intr($33,regs);    { set location }
    regs.ax:=$f;
    regs.cx := 2;
    regs.dx := 20;
    intr($33,regs);    { set mickeys }
  end
  else
     HasMouse := false;

  if lastmode=mono then screenseg:=$B000 else screenseg:=$B800;

end;

Function Get_Brick(x,y:integer):integer;
{ Returns the number of the brick in given position. }
begin
  x:=succ(x shr 4); y:=y shr 3;
  Get_Brick:=ord(wall[y][x])-ord('0');
end;

Procedure Put_Brick(x,y,a:integer);
{ A=type of brick.  If a=0 then brick is empty. }
{ X,Y are aligned to brick boundary.            }
var
  address,b:integer;
  brk:string[8];
begin
  address:=y shr 3 * 160 + x shr 1 and $F8;
  brk:=bricks[a];
  for b:=0 to 7 do mem[screenseg:address+b] := ord(brk[succ(b)]);
  if y<64 then wall[y shr 3][succ(x shr 4)]:=chr(ord('0')+a);
end;

Procedure Put_Paddle(x:integer);
var
  address,a,b:integer;
begin
  address:=3680+x shr 1 and $FE - 2*3 { three spaces };
  b := length(Paddle) - 1;
  if address + b > 3680+160 then b := b - (address - 3680 - 160);
  for a:=0 to b do
    memw[screenseg:address+a shl 1] := ord(Paddle[succ(a)])+$F00;
end;

Procedure Put_Ball(x,y,color:integer);
{ If color is 0 then ball is erased.   }
var
  address:integer;
begin
  address:=x shr 1 and $FE + y shr 3*160;
  if color<>0 then
    if odd(y shr 2) then mem[screenseg:address]:=220
                    else mem[screenseg:address]:=223
              else mem[screenseg:address]:=32;
  mem[screenseg:address+1]:=$F;
end;

Procedure WriteXY(x,y,attr:integer; str:string);
var
  a,address:integer;
begin
  address:=y*160 + x shl 1 - 2;
  for a:=1 to length(str) do
    memw[screenseg:address+a shl 1]:=attr shl 8 or ord(str[a]);
end;

procedure clrline(y:integer);
const line:string[80]=
'                                                                                ';
begin
  WriteXY(0,y,normal,line)
end;

procedure cls;
var
  a:integer;
begin
  for a:=24 downto 0 do clrline(a)
end;

Function Get_Direction:integer;
{ Returns value:   -2 if left shift + alt
                   -1 if left shift
                    0 if nothing
                    1 if right shift
                    2 if right shift + alt
                    Halt, if Ctrl + Alt pressed.  }
var
  a,b:integer;
  regs:registers;
begin
  regs.ax:=$200;
  intr(22,regs);
  a:=regs.ax;
  if a and 1 =1 then b:=1 else
  if a and 2 =2 then b:=-1 else
    b:=0;
  if a and 8 =8 then b:=b shl 1;
  if a and $c=$c then halt;
  Get_direction:=b;

  if HasMouse then begin
    regs.ax:=3;
    regs.cx:=0;
    intr($33,regs); { get cursor }
    if (regs.cx<>mouse_x) then begin
      if (regs.cx > mouse_x) then begin
        a := (regs.cx - mouse_x) div 2;
    if a>6 then
      a := 6;
      end
      else begin
        a := -((mouse_x - regs.cx) div 2);
    if a < -6 then
      a := -6;
      end;
      regs.ax:=4;
      regs.cx:=40;
      mouse_x := regs.cx;
      intr($33,regs);    { set cursor }
      Get_direction := a;
    end;
  end;
end;

Procedure Sound_on(f:integer);
begin
  if not Quiet then Sound(f);
end;

Procedure Sound_off;
begin
  nosound
end;

{******** Portable routines ********}

Procedure Beep(f,t:integer);
begin
  Sound_on(f);
  delay(t);
  Sound_off
end;

function strs(a:real; b:integer):string;
var
  s:string;
begin
  str(a:b:0,s);
  strs:=s;
end;

function sgn(a:integer):integer;
begin
if a<0 then sgn:=-1 else if a>0 then sgn:=1 else sgn:=0
end;

function exist(var a:text):boolean;
begin
  {$I-}
  reset(a);
  {$I+}
  exist:=(ioresult=0)
end;

Procedure Load_Walls;
var
  a,b,c,d:integer;
  source:text;
begin
  assign(source,'WALL DAT.A');
  if not exist(source) then
    begin Writeln('ERROR: File WALL DAT.A not found.');halt end;
  reset(source);
  readln(source,message);
  a:=1;
  while not eof(source) and (a<=max_wall) do
  with walls[a] do
  begin
    readln(source,msg);
    for b:=0 to 7 do readln(source,wall[b]);
    count:=0;
    for c:=0 to 7 do
      for d:=1 to 20 do
        if wall[c][d]<>'0' then count:=succ(count);
    a:=succ(a)
  end;
  max_walls_read:=pred(a);
  close(source);
end;

procedure load_hiscores;
var
  a,b:integer;
  st:string[8];
  source:text;
  line:string[28];
begin
  assign(source,'WALL SCO.RES');
  if not exist(source) then
    for a:=1 to max_his do
      with HiScores[a] do
        begin
          name:='*****   JPK   *****';
          score:=10000-1234*a;
        end
  else
    begin
      reset(source);
      for a:=1 to max_his do
        with HiScores[a] do
          readln(source,name,score);
    end;
  close(source);
end;

procedure save_hiscores;
var
  a,b:integer;
  dest:text;
  line:string[28];
begin
  assign(dest,'WALL SCO.RES');
  rewrite(dest);
  for a:=1 to max_his do
    with HiScores[a] do
      writeln(dest,name,score:8:0);
  close(dest);
end;

Procedure Print_HiScores;
var
  a:integer;
begin
  for a:=0 to 19 do
  begin
    put_brick(a shl 4,8,5);
    put_brick(a shl 4,184,5);
    put_brick(a shl 4,16,5);
    put_brick(a shl 4,176,5);
    put_brick(0,16+a shl 3,5);
    put_brick(312,16+a shl 3,5);
  end;
  writexy(28,4,inverse,' WALLGAME  Hall of Fame ');
  for a:=1 to Max_His do
    with HiScores[a] do
      writexy(25,4+a shl 1,normal,copy(name+empty_name,1,20)+'  '+strs(score,8));
end;

Procedure ReadNameXY(x,y,attr:integer; var st:str20);
var
  a:integer;
  ch:char;
begin
  while keypressed do ch:=readkey;
  a:=1;
  writexy(x,y,attr,st);
  repeat
    ch:=readkey;
    if (ch>chr(31))and(a<21) then
      begin
        st[a]:=ch;
        a:=a+1;
        writeXY(x+a-2,y,attr,ch);
      end
    else
      if ch=^H then
        if a>1 then
          begin
            a:=pred(a);
            st[a]:=' ';
            writexy(x,y,attr,st);
          end
  until ch=^M;

  if st=Empty_Name then
    st:=' Unknown ';
end;

procedure Insert_HiScore(sc:real);
var
  a,b:integer;
begin
  a:=max_his;
  while (sc>HiScores[a].score) and (a>1) do a:=pred(a);
  if sc<HiScores[1].score then a:=succ(a);
  for b:=pred(max_his) downto a do
    HiScores[succ(b)]:=HiScores[b];
  HiScores[a].score:=sc;
  HiScores[a].name:=Empty_name;
  cls;
  Writexy(15,24,inverse,'CONGRATULATIONS  --  You made it into Hall of Fame');
  Print_HiScores;
  ReadNameXY(25,4+a shl 1,inverse,HiScores[a].name);
  Save_HiScores;
end;

procedure Print_Wall;
var
  a,b:integer;
begin
  Cls;
  wall:=walls[wall_no].wall;
  for a:=0 to 7 do
    for b:=0 to 19 do
      put_brick(b*16,a*8,ord(wall[a][succ(b)])-ord('0'));
  bricks_hit:=0;
end;

Procedure pause(b:integer);
var
  a:integer;
begin
  a:=0;
  while (a<b) and (abs(Get_Direction)<>1) do
    begin
      a:=a+1;
      delay(1);
    end;
end;

procedure Scroll_message;
begin
  writeXY(0,0,normal,copy(message,1,80));
  message:=copy(message,2,length(message))+message[1];
  beep(1000,1);
  delay(100);
end;

Procedure Init_All;
begin
  InitHardware;
  Cls;
  Load_Walls;
  Load_HiScores;
end;

procedure Init_Game;
var
  a:integer;
begin
  Clrline(24);
  WriteXY(19,24,inverse,' Press Shift to start, Ctrl+Alt to end. ');
  Print_HiScores;
  repeat
    Scroll_message;
  until abs(get_direction)>0;
  wall_no:=1;
  if get_direction=2 then begin
      write('Press enter');
      a:=ord(readkey)-ord('0'); if a>0 then wall_no:=a;
  end;
  balls_left:=5;
  score:=0;
  Cls;
  Print_Wall;
  gotoxy(1,25);
end;

procedure Init_Specials;
begin
  moving:=false;
  hit_count:=0;
  bonus:=1;
end;

procedure Init_Ball;
begin
  WriteXY(2,24,normal,' SCORE '+strs(score,7)+'  BALLS'+strs(balls_left,2));
  writexy(0,24,inverse,strs(1 shl pred(bonus),1)+'X');
  WriteXY(30,24,normal,walls[wall_no].msg);
  Paddle_x:=130;
  Ball_x:=80+random(160);
  Ball_y:=100;
  if random(2)=1 then Ball_x_inc:=4 else Ball_x_inc:=-4;
  Ball_y_inc:=2;
  Missed:=false;
  May_Turn:=true;
  FX:=false;
  put_ball(ball_x,ball_y,1);
  put_paddle(paddle_x);
  for a:=500 to 1000 do
    begin sound_on(a); delay(1) end;
  beep(300,50);
  brick_hit_count:=0;
end;

Procedure End_Move;
begin
  if moving then put_brick(brick_x,brick_y,0);
  moving:=false;
end;

Procedure End_Short_Special;
{ End special effects which work only until first hit into the paddle. }
begin
  if Paddle_move_dir>0 then Ball_x_inc:=4 else Ball_x_inc:=-4;
  Ball_y_inc:=2;
  Sound_off;
  FX:=false;
end;

Procedure End_Ball;
{ End special effects which work until the ball is missed. }
begin
  clrline(23); Beep(100,400);
  end_move;
  Sound_off;
end;

Procedure Do_Shooter;
 begin
   ball_y_inc:=11-Ball_y shr 3;
   Ball_x_inc:=0;
   fx:=true;
 end;

Procedure Do_bonus;
begin
  end_move;
  brick_hit_count:=0;
  if bonus<5 then bonus:=succ(bonus);
  writexy(0,24,inverse,strs(1 shl pred(bonus),1)+'X');
end;

Procedure Do_Extra_Ball;
begin
  end_move;
  hit_count:=0;
  balls_left:=succ(balls_left);
  writexy(24,24,normal,strs(balls_left,2));
end;

Procedure Move_Paddle;
var
  a:integer;
begin
  a:=Get_Direction;
  if a=0 then
    Paddle_Move_Dir:=0
  else
    begin
      if a>0 then
        if Paddle_x+a<284 then Paddle_Move_Dir:=a
              else Paddle_Move_Dir:=284-Paddle_x
      else
        if Paddle_x+a>0 then Paddle_Move_Dir:=a
            else Paddle_Move_Dir:= -Paddle_x;
      if HasMouse then
          Paddle_x:=Paddle_x+Paddle_Move_Dir
      else
          Paddle_x:=Paddle_x+Paddle_Move_Dir shl 1;
    end;
  Put_Paddle(Paddle_x);
end;

Procedure Start_Moving(brk:integer);
begin
  moving:=true;
  brick_x:=paddle_x shr 1 + 80; brick_y:=0;
  if get_brick(brick_x,0)<>0 then brick_x:=0;
  if sgn(paddle_move_dir)>0 then brick_move_dir:=1 else brick_move_dir:=-1;
  Brick_type:=brk;
end;

Procedure Move_Brick;
var
  a:integer;
begin
  if brick_x<303 then
    if brick_x>16 then
      if get_brick((brick_x+brick_move_dir shl 4), brick_y)=0 then
        begin
          a:=brick_x;
          brick_x:=brick_x+brick_move_dir;
          put_brick(brick_x, brick_y, brick_type);
          if brick_x shr 4<>a shr 4 then put_brick(a, brick_y, 0);
        end
      else
        brick_move_dir:=-brick_move_dir
    else
      begin
        brick_move_dir:=-brick_move_dir;
        brick_x:=17;
      end
  else
    begin
      brick_move_dir:=-brick_move_dir;
      brick_x:=302;
    end;
end;

procedure move_bricks;
begin
  If moving then
    Move_brick
  else
    if brick_hit_count > 40 then
      begin
        if bonus<5 then
          Start_moving(Bonus_brick)
      end
    else
      if hit_count > 100 then
        Start_moving(Extra_Ball_Brick)
      else
        delay(2);
end;

Procedure Move_Ball;
var
  a,tx,ty,brick:integer;
begin

{*** Hit into Side Walls ***}
  tx:=Ball_x+Ball_x_inc;
  if tx>319 then
    begin
      Ball_x_inc:=-Ball_x_inc;
      tx:=319;
      ty:=ty and $fc
    end else
  if tx<0 then
    begin
      ball_x_inc:=-ball_x_inc;
      tx:=0;
      ty:=ty and $fc
    end;

{*** Hit into Paddle or Roof ***}
  ty:=Ball_y+Ball_y_inc;
  if ty>183 then
    if (tx>=Paddle_x) and (tx<=Paddle_x+40) then
      begin
        if FX then End_Short_Special;
        Ball_y_inc:=-Ball_y_inc;
        if Paddle_move_dir<>0 then
          if sgn(paddle_move_dir)=sgn(ball_x_inc) then
          begin
            ball_y_inc:=pred(ball_y_inc);
            if ball_y_inc<-4 then
              begin
                ball_y_inc:=-4;
              end;
          end
          else
          begin
            ball_y_inc:=succ(ball_y_inc);
            if ball_y_inc>-1 then
              begin
                ball_y_inc:=-1;
              end;
          end;
        ty:=183;
        beep(200,5);
        if not moving then
          begin
            brick_hit_count:=succ(brick_hit_count);
            hit_count:=succ(hit_count);
          end
      end
    else
      begin
        Missed:=true;
        Balls_Left:=Pred(Balls_Left);
      end
  else
  if ty<0 then
    begin
      ball_y_inc:=-ball_y_inc;
      ty:=0;
    end;

{*** Hit into Brick ***}
  if ty<64 then
  begin
    brick:=get_brick(tx,ty);
    if brick<>0 then
    begin
      Put_Brick(tx,ty,0);
      score:=score+brick shl bonus;
      WriteXY(9,24,normal,strs(score,7));
      if brick<10 then
      begin
        bricks_hit:=succ(bricks_hit);
        if bricks_hit>=walls[wall_no].count then
        begin
          for a:=300 to 500 do beep(a,2);
          wall_no:=succ(wall_no);
          if wall_no>max_walls_read then wall_no:=1;
          print_wall;
          init_ball;
          exit;
        end;
        if may_turn or (ball_y_inc>0) then Ball_y_inc:=-Ball_y_inc;
        may_turn:=false;
        ty:=ty and $f8+7;
        if brick=9 then Do_Shooter;
      end
      else
      Case brick of
        Bonus_Brick      : Do_Bonus;
        Extra_Ball_Brick : Do_extra_ball;
        else beep(1000+200*brick,200)
      end;
      beep(440+70*brick,10);
    end else may_turn:=true;
  end;

  if fx then sound_on(400+ball_y*100);
  Put_Ball(tx,ty,1);
  if (tx shr 2 <> ball_x shr 2) or (ty shr 3 <> ball_y shr 3)
    then Put_Ball(ball_x,ball_y,0);
  Ball_x:=tx; Ball_y:=ty;
end;

Procedure Game_Over;
var
  a:integer;
begin
  for a:=22 downto 9 do
  begin
    sound_on(40*a);
    WriteXY(29,a,inverse,'>>>> Game  Over <<<<');
    delay(50);
    sound_on(40*a+20);
    clrline(succ(a))
  end;
  for a:=44 to 88 do beep(a*10,5);
end;


{ *****   Main loop   ***** }

begin
  if paramstr(1)='/q' then Quiet := true else Quiet := false;
  Init_All;
  repeat
    Init_Game;
    repeat
      Init_Specials;
      Init_Ball;
      repeat
        Move_Paddle;
        Move_Ball;
        Move_Paddle;
        Move_Bricks;
        Delay(30);
      until Missed;
      End_Ball;
    until Balls_left=0;
    Game_Over;
    if Score>HiScores[max_his].score then
      Insert_HiScore(Score)
    else
      begin
        Pause(5000);
        cls;
      end;
  until false;
end.