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;
&nbs