Category : Files from Magazines
Archive   : PJ65.ZIP
Filename : OBJDRAW.PAS
PROGRAM ObjDraw;
{ Raw beginnings of an object-oriented graphics program,
demonstrating a practical use for variable-length data structures.
Written for Programmer's Journal by Tom Swan, Swan Software, P.O. Box
206, Lititz PA 17543. }
USES Crt, Graph;
CONST
FileName = 'OBJECTS.TXT'; { Graphics objects file name }
GrPath = 'C:\TPAS4'; { Pathname to BGI drivers }
MaxWord = 65535; { Maximum Word value }
TYPE
ObjType = ( {0} ObjPoint, {1} ObjLine, {2} ObjRect, {3} ObjCircle );
PointRec = { Single-pixel points }
RECORD
x, y : Integer; { Location of point }
pointColor : Word { Color of point }
END;
LineRec = { Straight lines }
RECORD
x1, y1, x2, y2 : Integer; { Line endpoints }
lineColor : Word { Line color }
END;
RectRec = { Squares and rectangles }
RECORD
x1, y1, x2, y2 : Integer; { Rectangle corners }
lineColor : Word; { Outline color }
fillColor : Word { Interior color (0=none) }
END;
CircleRec = { Circles }
RECORD
x, y : Integer; { Center coordinate }
radius : Word; { Length of radius in pixels }
lineColor : Word; { Outline color }
fillColor : Word { Interior color (0=none) }
END;
ObjPtr = ^ObjRec; { Pointer to various graphics objects }
ObjRec =
RECORD CASE objKind : ObjType OF
ObjPoint : ( onePoint : PointRec );
ObjLine : ( oneLine : LineRec );
ObjRect : ( oneRect : RectRec );
ObjCircle : ( oneCircle : CircleRec )
END;
ObjListPtr = ^ObjList; { Pointer to list of graphics objects }
ObjList =
RECORD
numObjects : Word; { Number of objects }
objects : ARRAY[ 0 .. 0 ] OF ObjPtr { Variable-length array }
END;
VAR
obj : ObjListPtr; { Pointer to list of objects }
PROCEDURE NewObjList( n : Word; VAR obj : ObjListPtr );
{ Return pointer obj to an ObjList record large enough to hold n
ObjPtr pointers in the obj^.objects array field. If obj=Nil on
return, then 1) n=0; or 2) bytes requested > MaxWord; or 3) enough
memory for n items is not available. }
VAR size : LongInt; { Number of bytes to allocate }
BEGIN
size := SizeOf( Word ) + ( LongInt(n) * SizeOf( ObjRec ) );
IF ( size = 0 ) OR ( size > MaxWord ) THEN obj := Nil ELSE
BEGIN
GetMem( obj, size ); { Out-of-memory error sets obj to Nil }
IF obj <> Nil
THEN obj^.numObjects := n
END { if }
END; { NewObjList }
PROCEDURE NewObj( n : Word; VAR obj : ObjPtr );
{ Return pointer obj to an ObjRec record large enough to hold n
bytes plus the record tag field. Out-of-memory error returns
obj = Nil. }
BEGIN
GetMem( obj, n + SizeOf( ObjType ) )
END; { NewObj }
FUNCTION NextObject( VAR f : Text ) : ObjPtr;
{ Read next object data from disk, creating an ObjRec record large
enough to hold the data, and returning the address of this record
as the function result. Out-of-memory error returns Nil. }
VAR objCode : Word; { Object code number (from data file) }
p : ObjPtr; { Temporary single object pointer }
FUNCTION LoadPoint : ObjPtr;
{ Load one point object }
BEGIN
NewObj( SizeOf( PointRec ), p ); { Allocate memory }
IF p <> Nil THEN WITH p^.onePoint DO
Read( f, x, y, pointColor ); { Read data }
LoadPoint := p { Return function result }
END; { LoadPoint }
FUNCTION LoadLine : ObjPtr;
{ Load one line object }
BEGIN
NewObj( SizeOf( LineRec ), p );
IF p <> Nil THEN WITH p^.oneLine DO
Read( f, x1, y1, x2, y2, lineColor );
LoadLine := p
END; { LoadLine }
FUNCTION LoadRect : ObjPtr;
{ Load one rectangle object }
BEGIN
NewObj( SizeOf( RectRec ), p );
IF p <> Nil THEN WITH p^.oneRect DO
Read( f, x1, y1, x2, y2, lineColor, fillColor );
LoadRect := p
END; { LoadRect }
FUNCTION LoadCircle : ObjPtr;
{ Load one circle object }
BEGIN
NewObj( SizeOf( CircleRec ), p );
IF p <> Nil THEN WITH p^.oneCircle DO
Read( f, x, y, radius, lineColor, fillColor );
LoadCircle := p
END; { LoadCircle }
BEGIN
Read( f, objCode ); { Read object code number }
CASE ObjType( objCode ) OF
ObjPoint : p := LoadPoint; { Read point data }
ObjLine : p := LoadLine; { Read line data }
ObjRect : p := LoadRect; { Read rectangle data }
ObjCircle : p := LoadCircle { Read circle data }
END; { case }
IF p <> Nil
THEN p^.objKind := ObjType( objCode ); { Save code as tag field }
NextObject := p { Return function result }
END; { NextObject }
PROCEDURE LoadFile( VAR obj : ObjListPtr );
{ Read graphics objects from a disk file. Halts on errors. }
VAR f : Text; { Text file variable }
n : Word; { Number of objects }
i : Word; { For-loop control variable }
BEGIN
Assign( f, FileName ); { Assign file name to file variable }
Reset( f ); { Open file for input }
Read( f, n ); { Read number of objects }
NewObjList( n, obj ); { Create array to hold list of n objects }
IF obj = Nil THEN { Check for bad n or short memory }
BEGIN
Writeln;
Writeln( 'Cannot allocate space for ', n, ' objects' );
Writeln( 'Memory available = ', MemAvail );
Halt(1)
END; { if }
FOR i := 1 TO n DO { Read n objects from disk }
obj^.objects[i-1] { Read next object and }
:= NextObject( f ); { assign to variable-length array }
Close( f )
END; { LoadFile }
PROCEDURE ShowOneObj( obj : ObjListPtr; n : Word );
{ Display object number n in object list addressed by obj pointer.
Assumes obj is not Nil. Ignores any Nil pointers in obj^.objects
array. }
VAR p : ObjPtr; { Holds copy of obj^.objects[n] }
PROCEDURE ShowPoint( VAR onePoint : PointRec );
{ Display point object }
BEGIN
WITH onePoint DO
PutPixel( x, y, pointColor )
END; { ShowPoint }
PROCEDURE ShowLine( VAR oneLine : LineRec );
{ Display Line object }
BEGIN
WITH oneLine DO
BEGIN
SetColor( lineColor );
Line( x1, y1, x2, y2 )
END { with }
END; { ShowLine }
PROCEDURE ShowRect( VAR oneRect : RectRec );
{ Display Rect object }
BEGIN
WITH oneRect DO
BEGIN
IF fillColor > 0 THEN
BEGIN
SetFillStyle( SolidFill, fillColor );
Bar( x1, y1, x2, y2 )
END; { if }
SetColor( lineColor );
Rectangle( x1, y1, x2, y2 )
END { with }
END; { ShowRect }
PROCEDURE ShowCircle( VAR oneCircle : CircleRec );
{ Display Circle object }
BEGIN
WITH oneCircle DO
BEGIN
SetColor( lineColor );
Circle( x, y, radius );
IF fillColor > 0 THEN
BEGIN
SetFillStyle( SolidFill, fillColor );
FloodFill( x, y, lineColor )
END { if }
END { with }
END; { ShowCircle }
BEGIN
WITH obj^ DO
IF ( 0 <= n ) AND ( n < numObjects ) THEN
BEGIN
p := objects[n];
IF p <> Nil THEN WITH p^ DO
CASE objKind OF
ObjPoint : ShowPoint( onePoint );
ObjLine : ShowLine( oneLine );
ObjRect : ShowRect( oneRect );
ObjCircle : ShowCircle( oneCircle )
END { case }
END { if }
END; { ShowOneObj }
PROCEDURE ShowAllObjects( obj : ObjListPtr );
{ Display all objects addressed by object list pointer obj. Assumes
that obj is not Nil. }
VAR i : Word; { For-loop control variable }
BEGIN
FOR i := 1 TO obj^.numObjects DO
ShowOneObj( obj, i - 1 );
END; { ShowAllObjects }
PROCEDURE DoGraphics( obj : ObjListPtr );
{ Initialize graphics screen and display objects addressed by obj. }
VAR grDriver, grMode, grError : Integer; { BGI graphics variables }
ch : Char; { Holds keypresses }
BEGIN
grDriver := Detect;
InitGraph( grDriver, grMode, grPath );
grError := GraphResult;
IF grError <> GrOk
THEN
Writeln( 'Graphics error : ', GraphErrorMsg( grError ) )
ELSE
BEGIN
ShowAllObjects( obj );
REPEAT
ch := ReadKey;
ShowOneObj( obj, ( Ord(ch) - Ord('0') ) - 1 )
UNTIL ch = Chr(27);
CloseGraph
END { else }
END; { DoGraphics }
{ The following custom heap-error trap function lets GetMem and New
return Nil pointers if memory allocation requests fail due to
insufficient memory. }
{$F+} { Switch on far-procedure generation }
FUNCTION HeapErrorTrap( size : Word ) : Integer;
BEGIN
HeapErrorTrap := 1 { New & GetMem: return Nil if out-of-memory }
END; { HeapErrorTrap }
{$F-} { Switch off far-procedure generation }
BEGIN
HeapError := @HeapErrorTrap; { Assign custom heap-error trap address }
Writeln;
Writeln( 'Welcome to ObjDraw' );
Writeln;
Writeln( 'Reads data from file ', FileName );
Writeln( 'Press digit keys to bring objects to the front' );
Writeln( 'Press Esc to quit' );
Writeln;
Write( 'Press Enter to begin...' );
Readln;
LoadFile( obj ); { Load objects from disk }
DoGraphics( obj ) { Display objects }
END.
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/