Code examples in IP Pascal

 


Directory Print Application Using Command Line Mode

Here are the source and executable files for Windows XP or better systems

ls.pas The source

ls.exe The executable

 

{******************************************************************************

*                                                                             *

*                         DIRECTORY LIST PROGRAM                              *

*                                                                             *

*                       Copyright 1996 S. A. Moore                            *

*                                                                             *

* An example directory listing program using the extlib functions. Lists all  *

* the files in the current directory. Should be extended to accept a          *

* directory path, and options about what to list.                             *

*                                                                             *

******************************************************************************}

 

program ls(output);

 

uses extlib;

 

var fp: filptr;  { file entry pointer }

    fl: filptr;  { file entry list }

    ml: integer; { maximum length of filenames }

    i:  integer; { index for filename }

 

procedure permis(pm: permset);

 

begin

 

   if pmread in pm then write('r') else write('-');

   if pmwrite in pm then write('w') else write('-');

   if pmexec in pm then write('e') else write('-');

   if pmdel in pm then write('d') else write('-');

   if pmvis in pm then write('v') else write('-');

   if pmcopy in pm then write('c') else write('-');

   if pmren in pm then write('r') else write('-');

   write(' ')

   

end;

 

procedure tim(t: integer);

 

begin

 

   if t <> -maxint then begin { time is valid }

 

      writedate(output, t); { write creation date }

      write(' ');

      writetime(output, t); { write creation time }

      write(' ')

 

   end

 

end;

   

begin

 

   { get list of files }

   list('*.*', fl);

   { find maximum length of filenames }

   fp := fl; { index top of list }

   ml := 0; { clear maximum }

   while fp <> nil do begin

 

      { check new max found, and register if so }

      if max(fp^.name^) > ml then ml := max(fp^.name^);

      fp := fp^.next { link next entry }

 

   end;

   { list all files }

   fp := fl; { index top of list }

   while fp <> nil do begin

 

      write(fp^.name^);

      { pad out to maximum filename }

      for i := 1 to ml-max(fp^.name^) do write(' ');

      write(' ', fp^.size, ' ');

      if fp^.alloc <> fp^.size then begin

 

         { allocation not redundant with size }

         write(fp^.alloc);

         write(' ')

 

      end;

      if atexec in fp^.attr then write('e') else write('-');

      if atarc in fp^.attr then write('a') else write('-');

      if atsys in fp^.attr then write('s') else write('-');

      if atdir in fp^.attr then write('d') else write('-');

      write(' ');

      { tim(fp^.create); } { write creation time }

      tim(fp^.modify); { write modify date }

      { tim(fp^.access); } { write access date }

      { tim(fp^.backup); } { write backup date }

      permis(fp^.user); { write user permissions }

      { permis(fp^.group); } { write group permissions }

      { permis(fp^.other); } { write global permissions }

      writeln;

      fp := fp^.next { next entry }

 

   end

 

end.

 

The ls.pas program is a fairly simple directory lister based on "extlib", which includes a function "list". The list function returns a list of records representing each directory entry that is formatted in such a way as to be OS independent. In fact, it is fairly close to an amalgamation of the data returned in DOS/Windows, and the data returned in Unix/Linux/BSD.


Snake Game Using Text Mode

Here are the source and executable files for Windows XP or better systems

snake.pas The source

snake.exe The executable

 

{******************************************************************************

 

SNAKE GAME PROGRAM

 

84 S. A. MOORE

 

Plays a moving target game were the player is a snake, winding it's body around

the screen, eating score producing digit 'targets' and trying to avoid the wall

and itself. The snake's movements are dictated by up, down, east and west

keys. for play details examine the program or simply activate the game (it has

instruction banners). This game is a fairly literal copy (functionality wise)

of the unix 'worm' program.

Adjustments; the following may be adjusted:

 

     Maximum size of snake: Change maxsn if the snake needs more or less

     possible positions.

 

     Size of score: adjust scrnum.

 

     Time between moves: adjust maxtim.

 

     If accumulated score overflows: adjust maxlft.

 

*******************************************************************************}

 

program snake(input, output); { user input (for break checking ) }

 

uses trmlib; { terminal standard library }

 

label 88, 99; { end game terminations }

 

const maxsn  = 1000;  { total snake positions }

      timmax = 5000; { time between forced moves (1 second) }

      blntim = 1000;  { delay time for blinker }

      maxlft = 100;   { maximum amount of score achevable before

                        being registered without overflow }

      { instruction message at top of screen; s/b maxx

        characters long }

      scrnum = 4;    { number of score digits }

      scroff = 45;   { location of first (high) digit of score

                       (should correspond with 'msgstr' above }

      maxscn = 100; { maximum screen demention }

 

type

 

     word   = 0..65535; { 16 bit word }

     string = packed array of char; { general string type }

     scrinx = 1..scrnum; { index for score save }

     sninx  = 1..maxsn;  { index for snake array }

     scnpos = record     { index set for screen }

 

                 scnx: integer;

                 scny: integer

 

              end;

 

var

 

    timcnt:  integer;      { move countdown }

    snakel:  array[sninx] of scnpos; { snake's positions }

    sntop:   sninx;        { current snake array top }

    lstmov:  evtcod;       { player move type }

    rndseq:  integer;      { random number sequencer }

    scrsav:  packed array [1..scrnum] of char; { screen score counter }

    scrlft:  0..maxlft;    { units of score left to add }

    scrloc:  integer; { location of score digits }

    fblink:  boolean; { crash blinker }

    er:      evtrec; { event record }

    image:   array [1..maxscn, 1..maxscn] of char; { screen image }

    crash:   boolean; { crash occurred flag }

    i:       integer;

    x:       integer;

    tx, ty:  integer;

 

{******************************************************************************

 

Check digit

 

We verify  that the passed digit lies in the set ['0'..'9'].

Of course this is done because of our lack of sets.

 

*******************************************************************************}

 

function digit(c : char)  { character to check }

              : boolean;  { is character digit ? }

 

begin

 

   digit := (c >= '0') and (c <= '9')

 

end;

 

{******************************************************************************

 

Write single character to screen

 

Writes the given character to the given X and Y point on the

screen. Also saves a copy to our screen image.

 

*******************************************************************************}

 

procedure writescreen(x, y: integer; { position to place character }

                      c:    char);   { write screen }

 

begin

 

   cursor(output, x, y); { position to the given location }

   if c <> image[x, y] then begin { filter redundant placements }

 

      write(c); { write the character }

      image[x, y] := c { place character in image }

 

   end

 

end;

 

{******************************************************************************

 

Write centered string

 

Writes a string that is centered on the line given. Returns the

starting position of the string.

 

*******************************************************************************}

 

procedure wrtcen(     y:   integer;  { y position of string }

                 view s:   string;   { string to write }

                 var  off: integer); { returns string offset }

 

var i: integer; { index for string }

 

begin

 

   off := maxx(output) div 2-max(s) div 2;

   { write out contents }

   for i := 1 to max(s) do writescreen(i+off, y, s[i])

 

end;

 

{******************************************************************************

 

Clear screen

 

Places the banner at the top of screen, then clears and sets

the border on the screen below. This is done in top to

bottom order (no skipping about) to avoid any text mixing

with characters already on the screen (looks cleaner).

This is a concern because the screen clear is not quite

instantaineous.

 

*******************************************************************************}

 

procedure clrscn;

 

var y: integer; { index y }

    x: integer; { index x }

 

begin

 

   page; { clear display screen }

   for x := 1 to maxx(output) do { clear image }

      for y := 1 to maxy(output) do image[x, y] := ' ';

   { place top }

   for x := 1 to maxx(output) do writescreen(x, 1, '*');

   { place sides }

   for y := 2 to maxy(output) - 1 do begin { lines }

 

      writescreen(1, y, '*'); { place left border }

      writescreen(maxx(output), y, '*') { place right border }

 

   end;

   { place bottom }

   for x := 1 to maxx(output) do writescreen(x, maxy(output), '*');

   { size and place banners }

   wrtcen(1, ' -> FUNCTION 1 RESTARTS <-   SCORE - 0000 ', x);

   scrloc := x+38;

   wrtcen(maxy(output), ' SNAKE VS. 2.0 ', x)

 

end;

 

{******************************************************************************

 

Random number generator

 

This generator was designed after the technequies in 'The Art

Of Programming'. Despite considerable testing, the damm thing

is largely arbitrary. Note that in the below version overflow

occurs.

A 'top' integer is required, which indicates the size of the

requested result.

If time permits, an overhaul of this business would be helpful.

 

*******************************************************************************}

 

function rand(top : integer): integer;

 

begin

 

   rndseq := (11 * rndseq + 6) mod 1000;

   rand := rndseq mod top + 1

 

end;

 

{******************************************************************************

 

Place target

 

Places a digit on the screen for use as a target. Both the

location of the target and it's value (0-9) are picked at

random. Multiple tries are used to avoid colisions.

 

*******************************************************************************}

 

procedure plctrg;

 

var x: integer; { index x }

    y: integer; { index y }

    c: char;

 

begin

 

   repeat { pick postions and check if the're free }

 

      { find x, y locations, not on a border using

        a zero - n random function }

      y := rand(maxy(output) - 2) + 1;

      x := rand(maxx(output) - 2) + 1;

      c := image[x, y]; { get character at position }

 

   until c = ' '; { area is unoccupied }

   { place target integer }

   writescreen(x, y, chr(rand(9) + ord('0')))

 

end;

 

{******************************************************************************

 

Next score

 

Increments the displayed score counter. This overflow is not

checked. Note that the 'scrloc' global constant tells us

where to place the score on screen, and scrnum indicates the

number of score digits.

 

*******************************************************************************}

 

procedure nxtscr;

 

var i     : scrinx;  { score save index }

    carry : boolean; { carry out for addition }

 

begin

 

   i := scrnum; { index LSD }

   carry := true; { initalize carry }

   repeat { process digit add }

 

      if scrsav[i] = '9' then begin

 

         scrsav[i] := '0'; { carry out digit }

         i := pred(i) { next digit }

 

      end else begin

 

         scrsav[i] := succ(scrsav[i]); { add single turnover }

         carry := false { stop }

 

      end

 

   until (i < 1) or not carry; { last digit is processed,

                                 no digit carry }

   { place score on screen }

   for i := 1 to scrnum do writescreen(scrloc + i - 1, 1, scrsav[i])

 

end;

 

{******************************************************************************

 

Move snake

 

Since this game is pretty much solitary, the movement of the

snake (activated by a player or automatically) evokes most

game behavor.

A move character is accepted, the new position calculated, and

the following may happen:

 

     1. The new position is inside a wall or border

        (game terminates, user loss).

 

     2. The new position crosses the snake itself

        (same result).

 

     3. A score tolken is found. The score value is

        added to the 'bank' of acculate score. The score

        is later removed from the bank one value at a time.

 

After the new position is found, the decision is make to

'grow' the snake (make it longer by the new position), or

'move' the snake (eliminate the last positon opposite the

new one).

 

*******************************************************************************}

 

procedure movesnake(usrmov: evtcod);

 

label 1; { exit label }

 

var sn: sninx;   { index for snake array }

    c:  char;

    x:  integer; { index x }

    y:  integer; { index y }

 

begin

 

   if (usrmov = etdown) or (usrmov = etup) or

      (usrmov = etleft) or (usrmov = etright) then begin

 

      x := snakel[sntop].scnx; { save present top }

      y := snakel[sntop].scny;

      case usrmov of

 

         etdown:  y := succ(y); { move down }

         etup:    y := pred(y); { move up }

         etleft:  x := pred(x); { move left }

         etright: x := succ(x)  { move right }

 

      end;

      c := image[x, y]; { load new character }

      { check terminate }

      if (y = 1) or (y = maxy(output)) or (x = 1) or (x = maxx(output)) or

         ((c <> ' ') and not digit(c)) then begin

 

         crash := true; { set crash occurred }

         goto 1 { exit }

 

      end;

      writescreen(x, y, '@'); { place new head }

      if digit(c) then begin

 

         plctrg; { place new target }

         { set digit score }

         scrlft := scrlft + (ord(c) - ord('0'));

 

      end;

      if scrlft <> 0 then begin

 

         sntop := succ(sntop); { 'grow' snake }

         if sntop > maxsn then begin { snake to big }

 

            crash := true; { set crash occurred }

            goto 1 { exit }

 

         end;

         nxtscr; { increment score }

         scrlft := pred(scrlft) { decrement score to add }

 

      end else begin

 

         writescreen(snakel[1].scnx, snakel[1].scny, ' ');

         for sn := 1 to sntop - 1 do { copy old positions }

         snakel[sn] := snakel[sn + 1]

 

      end;

      snakel[sntop].scnx := x; { update coordinates }

      snakel[sntop].scny := y;

      lstmov := usrmov { set the last move }

 

   end;

 

   1: { terminate move }

 

end;

 

{******************************************************************************

 

Event loop

 

Waits for interesting events, processes them, and if a move is performed,

executes that. We include a flag to reject timer forced moves, because we

may be waiting for the user to start the game.

We treat the joystick as being direction arrows, so we in fact convert it to

direction events here. I don't care which joystick is being used.

The joystick is deadbanded to 1/10 of it's travel (it must be moved more than

1/10 away from center to register a move). If the user is trying to give

us two axies at once, one is picked ad hoc. Because the joystick dosen't

dictate speed, we just set up the default move with it.

The advanced mode for the joystick would be to pick a rate for it that is

proportional to it's deflection, ie., move it farther, go faster.

 

*******************************************************************************}

 

procedure getevt(tim: boolean); { accept timer events }

 

var accept: boolean; { accept event flag }

 

begin

 

   repeat { process rejection loop }

 

      repeat { event rejection loop }

 

         event(input, er) { get event }

 

      until er.etype in [etleft, etright, etup, etdown, etterm, ettim, etfun,

                         etjoymov];

      accept := true; { set event accepted by default }

      if er.etype = etjoymov then begin { handle joystick }

 

         { change joystick to default move directions }

         if er.joypx > maxint div 10 then lstmov := etright

         else if er.joypx < -maxint div 10 then lstmov := etleft

         else if er.joypy > maxint div 10 then lstmov := etdown

         else if er.joypy < -maxint div 10 then lstmov := etup;

         accept := false { these events don't exit }

 

      end else if er.etype = ettim then begin { timer }

 

         if tim then begin

 

            if er.timnum = 1 then { time's up..default move }

               movesnake(lstmov) { move the same as last }

            else accept := false { suppress exit }

 

         end else accept := false { suppress exit }

 

      end else if not (er.etype in [etfun, etterm]) then { movement }

         movesnake(er.etype) { process user move }

 

   until accept

 

end;

 

{******************************************************************************

 

Main program

 

Various set-ups are performed, then the move loop is activated.

The user is given n chances in the loop to enter a move

character (and therefore a certain time), after which the snake

moves automatically in the same direction as it last moved.

This, of course, requires that the user have moved before the

game starts !

This problem is handled by requiring a user move to start the

play.

Besides the direction keys, the user has avalible restart

and cancel game keys.

 

*******************************************************************************}

 

begin { snake }

 

   select(output, 2, 2); { switch screens }

   curvis(output, false); { remove drawing cursor }

   auto(output, false); { remove automatic scrolling }

   bcolor(output, cyan); { on cyan background }

   rndseq := 5; { initalize random number generator }

   for i := 1 to 58 do x := rand(1); { stablize generator }

   timer(input, 1, timmax, true); { set move timer }

   timer(input, 2, blntim, true); { set blinker timer }

   repeat { game }

 

      88: { start new game }

 

      scrlft := 0; { clear score add count }

      clrscn;

      snakel[1].scnx := maxx(output) div 2; { set snake position middle }

      snakel[1].scny := maxy(output) div 2;

      sntop := 1; { set top snake character }

      writescreen(maxx(output) div 2, maxy(output) div 2, '@'); { place snake }

      timcnt := timmax;

      for i := 1 to scrnum do scrsav[i] := '0'; { zero score }

      nxtscr;

      getevt(false); { get the next event, without timers }

      if er.etype = etterm then goto 99 { immediate termination }

      else if er.etype = etfun then goto 88; { start new game }

      plctrg; { place starting target }

      crash := false; { set no crash occurred }

      repeat { game loop }

 

         getevt(true); { get next event, with timers }

         if er.etype = etterm then goto 99; { immediate termination }

         if er.etype = etfun then goto 88 { start new game }

 

      until crash; { we crash into an object }

      { not a voluntary cancel, must have *** crashed *** }

      tx := snakel[sntop].scnx;

      ty := snakel[sntop].scny;

      { blink the head off and on (so that snakes

        behind us won't run into us) }

      fblink := false; { clear crash blinker }

      repeat { blink cycles }

 

         { wait for an interesting event }

         repeat event(input, er) until er.etype in [ettim, etterm, etfun];

         if er.etype = etterm then goto 99; { immediate termination }

         if er.etype = etfun then goto 88; { restart game }

         { must be timer }

         if er.timnum = 2 then begin { blink cycle }

 

            if fblink then { turn back on }

               writescreen(tx, ty, '@')

            else { turn off }

               writescreen(tx, ty, ' ');

            fblink := not fblink { invert blinker status }

 

         end

 

      until false { forever }

 

   until false; { forever }

 

   99: { terminate program }

 

   curvis(output, true); { restore drawing cursor }

   auto(output, true); { restore automatic scrolling }

   select(output, 1, 1) { back to original screen }

 

end.

Snake is a decades old game where a "snake" appears on the screen, moving continuously in a direction selected by the arrow keys, but cannot be stopped. The snake is pointed towards numbers on the screen from 1-9, which it "eats". Each number increases both the score, and the length of the snake. The snakes body trails behind it wherever it goes, and after the score mounts, it becomes hard for the snake to avoid hitting a wall or itself. If that happens, the game is over.

Snake demonstrates the screen independent terminal level calls, and the event queue that is used to manage the interface. The program gets all user keys and a timer event via the event system, and draws accordingly. Those output calls are not special ! Note that standard writes to the output file are used. The difference is that cursor position sets are used between writes. Terminal mode is completely upward compatible with standard line oriented mode.

Note that the program can size itself to any screen. Note also that this is shown running in a Windows XP command window ! It is using the console terminal calls in Windows XP. The same program could be compiled under full Windows graphical mode, but of course would not look any different, since it does not use any of the graphical commands. But since terminal level calls are completely upward compatible with the graphical system, porting old terminal mode programs is not a problem.


Breakout Game Using Graphical Mode And Sound

Here are the source and executable files for Windows XP or better systems

breakout.pas The source

breakout.exe The executable

 

{******************************************************************************

*                                                                             *

*                                BREAKOUT GAME                                *

*                                                                             *

*                       COPYRIGHT (C) 2002 S. A. MOORE                        *

*                                                                             *

* Plays breakout in graphical mode.                                           *

*                                                                             *

******************************************************************************}

 

program brkout(input, output);

 

uses gralib,

     sndlib;

 

label newgame, endgame; { loop and termination labels }

 

const

 

   second      = 10000;           { one second }

   osec        = second div 8;    { 1/8 second }

   balmov      = 50;              { ball move timer }

   newbal      = second;          { wait for new ball time }  

   wall        = 21;              { wall thickness }

   hwall       = wall div 2;      { half wall thickness }

   padw        = 81;              { width of paddle }

   padhw       = padw div 2;      { half paddle }

   padqw       = padw div 4;      { quarter paddle }

   padh        = 15;              { height of paddle }

   hpadw       = padw div 2;      { half paddle width }

   pwdis       = 5;               { distance of paddle from bottom wall }

   balls       = 21;              { size of the ball }

   hballs      = balls div 2;     { half ball size }

   ballclr     = blue;            { ball color }

   wallclr     = cyan;            { wall color }

   padclr      = green;           { paddle color }

   bouncetime  = 250;             { time to play bounce note }

   wallnote    = note_d+octave_6; { note to play off wall }

   bricknote   = note_e+octave_7; { note to play off brick }

   failtime    = 1500;            { note to play on failure }

   failnote    = note_c+octave_4; { note to play on fail }

   brkrow      = 6;               { number of brick rows }

   brkcol      = 10;              { number of brick collumns }

   brkh        = 15;              { brick height }

   brkbrd      = 3;               { brick border }

 

type rectangle = record { rectangle }

 

        x1, y1, x2, y2: integer

 

     end;

 

var

 

   padx:         integer;   { paddle position x }

   bdx:          integer;   { ball direction x }

   bdy:          integer;   { ball direction y }

   bsx:          integer;   { ball position save x }

   bsy:          integer;   { ball position save y }

   baltim:       integer;   { ball start timer }

   er:           evtrec;    { event record }

   jchr:         integer;   { number of pixels to joystick movement }

   score:        integer;   { score }

   scrsiz:       integer;   { score size }

   scrchg:       boolean;   { score has changed }

   bac:          integer;   { ball accelerator }

   paddle:       rectangle; { paddle rectangle }

   ball, balsav: rectangle; { ball rectangle }

   wallt, walll, wallr, wallb: rectangle; { wall rectangles }

   bricks:       array [1..brkrow, 1..brkcol] of rectangle; { brick array }

   brki:         boolean;   { brick was intersected }

   fldbrk:       integer;   { bricks hit this field }

 

   debug:      text;    { debugger output file }

 

{******************************************************************************

 

Write string to screen

 

Writes a string to the indicated position on the screen.

 

*******************************************************************************}

 

procedure writexy(     x, y: integer; { position to write to }

                  view s:    string); { string to write }

 

begin

 

   cursorg(output, x, y); { position cursor }

   write(s) { output string }

 

end;

 

{******************************************************************************

 

Write centered string

 

Writes a string that is centered on the line given. Returns the

starting position of the string.

 

*******************************************************************************}

 

procedure wrtcen(     y:   integer;  { y position of string }

                 view s:   string);  { string to write }

 

var off: integer; { string offset }

 

begin

 

   off := maxxg(output) div 2-strsiz(output, s) div 2;

   writexy(off, y, s) { write out contents }

 

end;

 

{******************************************************************************

 

Translate color code

 

Translates a logical color to an RGB color. Returns the RGB color in three

variables.

 

******************************************************************************}

 

procedure log2rgb(c: color; var r, g, b: integer);

 

begin

 

   { translate color number }

   case c of { color }

 

      black:   begin r := 0;      g:= 0;       b := 0      end;

      white:   begin r := maxint; g := maxint; b := maxint end;

      red:     begin r := maxint; g := 0;      b := 0      end;

      green:   begin r := 0;      g := maxint; b := 0      end;

      blue:    begin r := 0;      g := 0;      b := maxint end;

      cyan:    begin r := 0;      g := maxint; b := maxint end;

      yellow:  begin r := maxint; g := maxint; b := 0      end;

      magenta: begin r := maxint; g := 0;      b := maxint end

 

   end

 

end;

 

{******************************************************************************

 

Draw rectangle

 

Draws a filled rectangle, in the given color.

 

*******************************************************************************}

 

procedure drwrect(var r: rectangle; c: color);

 

begin

 

   fcolor(output, c); { set color }

   frect(output, r.x1, r.y1, r.x2, r.y2)

 

end;

 

{******************************************************************************

 

Draw bordered rectangle

 

Draws a filled rectangle with border, in the given color.

 

*******************************************************************************}

 

procedure drwbrect(var r: rectangle; c: color);

 

var i:          integer;

    hr, hg, hb: integer; { rgb value of highlight }

    mr, mg, mb: integer; { rbg value of midlight }

    lr, lg, lb: integer; { rbg value of lowlight }

 

procedure dim(dv: real; var r, g, b: integer);

 

begin

 

   r := trunc(r*dv);

   g := trunc(g*dv);

   b := trunc(b*dv)

 

end;

 

begin

 

   log2rgb(c, hr, hg, hb); { find actual color }

   mr := hr; { copy }

   mg := hg;

   mb := hb;

   lr := hr;

   lg := hg;

   lb := hb;

   dim(0.80, mr, mg, mb); { dim midlight to %75 }

   dim(0.60, lr, lg, lb); { dim lowlight to %50 }

   fcolorg(output, mr, mg, mb); { set brick body to midlight }

   frect(output, r.x1, r.y1, r.x2, r.y2); { draw brick }

   fcolorg(output, hr, hg, hb); { set hilight }

   frect(output, r.x1, r.y1, r.x1+brkbrd-1, r.y2); { border left }

   frect(output, r.x1, r.y1, r.x2, r.y1+brkbrd-1); { top }

   { set lowlight border color }

   fcolorg(output, lr, lg, lb);

   { border right }

   for i := 1 to brkbrd do frect(output, r.x2-i+1, r.y1+i-1, r.x2, r.y2);

   { border bottom }

   for i := 1 to brkbrd do frect(output, r.x1+i-1, r.y2-i+1, r.x2, r.y2)

 

end;

 

{******************************************************************************

 

Offset rectangle

 

Offsets a rectangle by an x and y difference.

 

*******************************************************************************}

 

procedure offrect(var r: rectangle; x, y: integer);

 

begin

 

   r.x1 := r.x1+x;

   r.y1 := r.y1+y;

   r.x2 := r.x2+x;

   r.y2 := r.y2+y

 

end;

 

{******************************************************************************

 

Rationalize a rectangle

 

Rationalizes a rectangle, that is, arranges the points so that the 1st point

is lower in x and y than the second.

 

*******************************************************************************}

 

procedure ratrect(var r: rectangle);

 

var t: integer; { swap temp }

 

begin

 

   if r.x1 > r.x2 then begin { swap x }

 

      t := r.x1;

      r.x1 := r.x2;

      r.x2 := t

 

   end;

   if r.y1 > r.y2 then begin { swap y }

 

      t := r.y1;

      r.y1 := r.y2;

      r.y2 := t

 

   end

 

end;

 

{******************************************************************************

 

Find intersection of rectangles

 

Checks if two rectangles intersect. Returns true if so.

 

*******************************************************************************}

 

function intersect(r1, r2: rectangle): boolean;

 

begin

 

   { rationalize the rectangles }

   ratrect(r1);

   ratrect(r2);

   intersect := (r1.x2 >= r2.x1) and (r1.x1 <= r2.x2) and

                (r1.y2 >= r2.y1) and (r1.y1 <= r2.y2)

 

end;

 

{******************************************************************************

 

Set rectangle

 

Sets the rectangle to the given values.

 

*******************************************************************************}

 

procedure setrect(var r: rectangle; x1, y1, x2, y2: integer);

 

begin

 

   r.x1 := x1;

   r.y1 := y1;

   r.x2 := x2;

   r.y2 := y2

 

end;

 

{******************************************************************************

 

Clear rectangle

 

Clear rectangle points to zero. Usually used to flag the rectangle invalid.

 

*******************************************************************************}

 

procedure clrrect(var r: rectangle);

 

begin

 

   r.x1 := 0;

   r.y1 := 0;

   r.x2 := 0;

   r.y2 := 0

 

end;

 

{******************************************************************************

 

Draw screen

 

Draws a new screen, with borders.

 

*******************************************************************************}

 

procedure drwscn;

 

begin

 

   page; { clear screen }

   { draw walls }

   drwrect(wallt, wallclr); { top }

   drwrect(walll, wallclr); { left }

   drwrect(wallr, wallclr); { right }

   drwrect(wallb, wallclr); { bottom }

   fcolor(output, black);

   wrtcen(maxyg(output)-wall+1, 'BREAKOUT VS. 1.0')

 

end;

 

{******************************************************************************

 

Draw wall

 

Redraws the brick wall.

 

*******************************************************************************}

 

procedure drwwall;

 

var r, c: integer; { brick array indexes }

    clr:  color;   { brick color }

 

begin

 

   clr := red; { set 1st pure color }

   for r := 1 to brkrow do

      for c := 1 to brkcol do begin

 

      drwbrect(bricks[r, c], clr);

      if clr < magenta then clr := succ(clr)

      else clr := red

 

   end;

 

end;

 

{******************************************************************************

 

Set new paddle position

 

Places the paddle at the given position.

 

*******************************************************************************}

 

procedure padpos(x: integer);

 

begin

 

   if x-hpadw <= walll.x2 then x := walll.x2+hpadw+1; { clip to ends }

   if x+hpadw >= wallr.x1 then x := wallr.x1-hpadw-1;

   { erase old location }

   fcolor(output, white);

   frect(output, padx-hpadw, maxyg(output)-wall-padh-pwdis,

                 padx+hpadw, maxyg(output)-wall-pwdis);

   padx := x; { set new location }

   setrect(paddle, x-hpadw, maxyg(output)-wall-padh-pwdis,

                   x+hpadw, maxyg(output)-wall-pwdis);

   drwrect(paddle, padclr) { draw paddle }

 

end;

 

{******************************************************************************

 

Set brick wall

 

Initalizes the bricks in the wall coordinates.

 

*******************************************************************************}

 

procedure setwall;

 

var r, c:   integer; { brick array indexes }

    brkw:   integer; { brick width }

    brkr:   integer; { brick remainder }

    brkoff: integer; { brick wall offset }

    co:     integer; { collumn offset }

    rd:     integer; { remainder distributor }

 

begin

 

   brkw := (maxxg(output)-2*wall) div brkcol; { find brick width }

   brkr := (maxxg(output)-2*wall) mod brkcol - 1; { find brick remainder }

   brkoff := maxyg(output) div 4; { find brick wall offset }

   for r := 1 to brkrow do begin

 

      co := 0; { clear collumn offset }

      rd := brkr; { set remainder distributor }

      for c := 1 to brkcol do begin

 

         setrect(bricks[r, c], 1+co+wall, 1+(r-1)*brkh+brkoff,

                               1+co+brkw-1+wall+ord(rd > 0),

                               1+(r-1)*brkh+brkh-1+brkoff);

         co := co+brkw+ord(rd > 0); { offset to next brick }

         if brkr > 0 then rd := rd-1 { reduce remainder }

 

      end

 

   end

 

end;

 

{*******************************************************************************

 

Find brick intersection

 

Searches for a brick that intersects with the ball, and if found, erases the

brick and returns true. Note that if more than one brick intersects, they all

disappear.

 

*******************************************************************************}

 

procedure interbrick;

 

var r, c: integer; { brick array indexes }

 

begin

 

   brki := false; { set no brick intersection }

   for r := 1 to brkrow do

      for c := 1 to brkcol do if intersect(ball, bricks[r, c]) then begin

 

      brki := true; { set intersected }

      drwrect(bricks[r, c], white); { erase from screen }

      clrrect(bricks[r, c]); { clear brick data }

      score := score+1; { count hits }

      scrchg := true; { set changed }

      fldbrk := fldbrk+1 { add to bricks this field }

 

   end

 

end;

 

begin

 

   opensynthout(synth_out); { open synthesizer }

   instchange(synth_out, 0, 1, inst_lead_1_square);

   starttime; { start sequencer running }

   jchr := maxint div ((maxxg(output)-2) div 2); { find basic joystick increment }

   curvis(output, false); { remove drawing cursor }

   auto(output, false); { turn off scrolling }

   font(output, font_sign); { sign font }

   bold(output, true);

   fontsiz(output, wall-2); { font fits in the wall }

   binvis(output); { no background writes }

   timer(output, 1, balmov, true); { enable timer }

   newgame: { start new game }

   padx := maxxg(output) div 2; { find intial paddle position }

   padpos(padx); { display paddle }

   clrrect(ball); { set ball not on screen }

   baltim := 0; { set ball ready to start }

   { set up wall rectangles }

   setrect(wallt, 1, 1, maxxg(output), wall); { top }

   setrect(walll, 1, 1, wall, maxyg(output)); { left }

   { right }

   setrect(wallr, maxxg(output)-wall, 1, maxxg(output), maxyg(output));

   { bottom }

   setrect(wallb, 1, maxyg(output)-wall, maxxg(output), maxyg(output));

   scrsiz := strsiz(output, 'SCORE 0000'); { set nominal size of score string }

   scrchg := true; { set score changed }

   drwscn; { draw game screen }

   score := 0; { clear score }

   baltim := newbal div balmov; { set starting ball time }

   repeat { game loop }

 

      setwall; { initalize bricks }

      drwwall; { redraw the wall }

      fldbrk := 0; { clear bricks hit this field }

      repeat { fields }

 

         if (ball.x1 = 0) and (baltim = 0) then begin

 

            { ball not on screen, and time to wait expired, send out ball }

            setrect(ball, wall+1, maxyg(output)-4*wall-balls,

                          wall+1+balls, maxyg(output)-4*wall);

            bdx := +1; { set direction of travel }

            bdy := -2;

            { draw the ball }

            fcolor(output, ballclr);

            drwrect(ball, ballclr);

            scrchg := true { set changed }

 

         end;

         if scrchg then begin { process score change }

 

            { erase score }

            fcolor(output, wallclr);

            frect(output, maxxg(output) div 2-scrsiz div 2, 1,

                          maxxg(output) div 2+scrsiz div 2, wall);

            { place updated score on screen }

            fcolor(output, black);

            cursorg(output, maxxg(output) div 2-scrsiz div 2, 2);

            writeln('SCORE ', score:5);

            scrchg := false { reset score change flag }

 

         end;

         repeat event(input, er) { wait relivant events }

         until er.etype in [etterm, etleft, etright, etfun, ettim, etjoymov];

         if er.etype = etterm then goto endgame; { game exits }

         if er.etype = etfun then goto newgame; { restart game }

         { process paddle movements }

         if er.etype = etleft then padpos(padx-5) { move left }

              else if er.etype = etright then padpos(padx+5) { move right }

         else if er.etype = etjoymov then { move joystick }

            padpos(maxxg(output) div 2+er.joypx div jchr)

         else if er.etype = ettim then begin { move timer }

 

            if er.timnum = 1 then begin { ball timer }

 

               if ball.x1 > 0 then begin { ball on screen }

 

                  balsav := ball; { save ball position }

                  offrect(ball, bdx, bdy); { move the ball }

                  { check off screen motions }

                  if intersect(ball, walll) or intersect(ball, wallr) then begin

 

                     { hit left or right wall }

                     ball := balsav; { restore }

                     bdx := -bdx; { change direction }

                     offrect(ball, bdx, bdy); { recalculate }

                     { start bounce note }

                     noteon(synth_out, 0, 1, wallnote, maxint);

                     noteoff(synth_out, curtime+bouncetime, 1, wallnote, maxint)

 

                  end else if intersect(ball, wallt) then begin { hits top }

 

                     ball := balsav; { restore }

                     bdy := -bdy; { change direction }

                     offrect(ball, bdx, bdy); { recalculate }

                     { start bounce note }

                     noteon(synth_out, 0, 1, wallnote, maxint);

                     noteoff(synth_out, curtime+bouncetime, 1, wallnote, maxint)

 

                  end else if intersect(ball, paddle) then begin

 

                     ball := balsav; { restore }

                     { find which 5th of the paddle was struck }

                     case (ball.x1+hballs-paddle.x1) div (padw div 5) of

 

                        0: bdx := -2; { left hard }

                        1: bdx := -1; { soft soft }

                        2: ;          { center reflects }

                        3: bdx := +1; { right soft }

                        4: bdx := +2; { right hard }

                        5: bdx := +2  { right hard }

 

                     end;

                     bdy := -bdy; { reflect y }

                     offrect(ball, bdx, bdy); { recalculate }

                     { if the ball is still below the paddle plane, move it up

                       until it is not }

                     if ball.y2 >= paddle.y1 then

                        offrect(ball, 0, -(ball.y2-paddle.y1+1));

                     { start bounce note }

                     noteon(synth_out, 0, 1, wallnote, maxint);

                     noteoff(synth_out, curtime+bouncetime, 1, wallnote, maxint)

 

                  end else begin { check brick hits }

 

                     interbrick; { check brick intersection }

                     if brki then begin { there was a brick hit }

 

                        ball := balsav; { restore }

                        bdy := -bdy; { change direction }

                        offrect(ball, bdx, bdy); { recalculate }

                        { start bounce note }

                        noteon(synth_out, 0, 1, bricknote, maxint);

                        noteoff(synth_out, curtime+bouncetime, 1, bricknote, maxint)

 

                     end

 

                  end;

                  if intersect(ball, wallb) then begin { ball out of bounds }

 

                     drwrect(balsav, white);

                     clrrect(ball); { set ball not on screen }

                     { start time on new ball wait }

                     baltim := newbal div balmov;

                     { start fail note }

                     noteon(synth_out, 0, 1, failnote, maxint);

                     noteoff(synth_out, curtime+failtime, 1, failnote, maxint)

 

                  end else begin { ball in play }

 

                      { erase only the leftover part of the old ball }

                      fcolor(output, white);

                      if bdx < 0 then { ball move left }

                         frect(output, ball.x2+1, balsav.y1,

                                       balsav.x2, balsav.y2)

                      else { move move right }

                         frect(output, balsav.x1, balsav.y1,

                                       ball.x1-1, balsav.y2);

                      if bdy < 0 then { ball move up }

                         frect(output, balsav.x1, ball.y2+1,

                                       balsav.x2, balsav.y2)

                      else { move move down }

                         frect(output, balsav.x1, balsav.y1,

                                       balsav.x2, ball.y1-1);

                      drwrect(ball, ballclr) { redraw the ball }

 

                  end

 

               end;

               { if the ball timer is running, decrement it }

               if baltim > 0 then baltim := baltim-1

 

            end

 

         end

 

      until fldbrk = brkrow*brkcol; { until bricks are cleared }

      noteon(synth_out,  0,               1, note_c+octave_6, maxint);

      noteoff(synth_out, curtime+osec*2,  1, note_c+octave_6, maxint);

      noteon(synth_out,  curtime+osec*3,  1, note_d+octave_6, maxint);

      noteoff(synth_out, curtime+osec*4,  1, note_d+octave_6, maxint);

      noteon(synth_out,  curtime+osec*5,  1, note_e+octave_6, maxint);

      noteoff(synth_out, curtime+osec*6,  1, note_e+octave_6, maxint);

      noteon(synth_out,  curtime+osec*7,  1, note_f+octave_6, maxint);

      noteoff(synth_out, curtime+osec*8,  1, note_f+octave_6, maxint);

      noteon(synth_out,  curtime+osec*9,  1, note_e+octave_6, maxint);

      noteoff(synth_out, curtime+osec*10, 1, note_e+octave_6, maxint);

      noteon(synth_out,  curtime+osec*11, 1, note_d+octave_6, maxint);

      noteoff(synth_out, curtime+osec*13, 1, note_d+octave_6, maxint);

      baltim := (osec*13+newbal) div balmov; { wait fanfare }

      drwrect(ball, white); { clear ball }

      clrrect(ball) { set ball not on screen }

 

   until false; { forever }

 

   endgame: { exit game }

 

   closesynthout(synth_out) { close synthesizer }

 

end.

 

Breakout uses both graphics and sound. If some of the calls in this graphical program look similar to the "snake" game above, its no accident. Graphical mode is upward compatible to the terminal mode. If you pull a terminal mode program forward to graphical mode, it will draw characters on a standard spaced grid with the Windows system fixed font. You'll notice that one of the first things breakout does is select a more attractive proportional font (using an OS independent name, "sign" or Sans Serif).

The sound is created via sndlib and calls that will be familiar to any MIDI user. sndlib contains a full sequencer, so breakout can simply output time stamped notes to it and continue with the game while they play. We could have also used wave recording files for the sound effects, or a mixture of the two.


 For more information contact: Scott A. Moore samiam@moorecad.com