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.
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.
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