Macintosh-SW
/
macintosh_cookbook
mirror of https://git.sr.ht/~rabbits/macintosh_cookbook
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

Updated readme

This commit is contained in:
neauoire 2020-05-07 18:47:11 +09:00
commit e592018aeb
79 changed files with 68122 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
README.md Normal file
View File

@ -0,0 +1,7 @@
# The Macintosh Cookbook
This is a collection of tools and example files to make classic Macintosh applications using the [THINK Pascal](https://wiki.xxiivv.com/site/pascal.html) environment.
More details shortly.
⌘

63071
docs/macintosh inside.html Normal file
View File

File diff suppressed because it is too large Load Diff

222
docs/pascal quickdraw.html Normal file
View File

@ -0,0 +1,222 @@
<h1>Summary of QuickDraw Drawing</h1>
<pre>
srcCopy = 0; {where source pixel is black, force destination }
{ pixel black; where source pixel is white, force }
{ destination pixel white}
srcOr = 1; {where source pixel is black, force destination }
{ pixel black; where source pixel is white, leave }
{ destination pixel unaltered}
srcXor = 2; {where source pixel is black, invert destination }
{ pixel; where source pixel is white, leave }
{ destination pixel unaltered}
srcBic = 3; {where source pixel is black, force destination }
{ pixel white; where source pixel is white, leave }
{ destination pixel unaltered}
notSrcCopy = 4; {where source pixel is black, force destination }
{ pixel white; where source pixel is white, force }
{ destination pixel black}
notSrcOr = 5; {where source pixel is black, leave destination }
{ pixel unaltered; where source pixel is white, }
{ force destination pixel black}
notSrcXor = 6; {where source pixel is black, leave destination }
{ pixel unaltered; where source pixel is white, }
{ invert destination pixel}
notSrcBic = 7; {where source pixel is black, leave destination }
{ pixel unaltered; where source pixel is white, }
{ force destination pixel white}
{pattern modes}
patCopy = 8; {where pattern pixel is black, apply foreground }
{ color to destination pixel; where pattern pixel }
{ is white, apply background color to destination }
{ pixel}
patOr = 9; {where pattern pixel is black, invert destination }
{ pixel; where pattern pixel is white, leave }
{ destination pixel unaltered}
patXor = 10; {where pattern pixel is black, invert destination }
{ pixel; where pattern pixel is white, leave }
{ destination pixel unaltered}
patBic = 11; {where pattern pixel is black, apply background }
{ color to destination pixel; where pattern pixel }
{ is white, leave destination pixel unaltered}
notPatCopy = 12; {where pattern pixel is black, apply background }
{ color to destination pixel; where pattern pixel }
{ is white, apply foreground color to destination }
{ pixel}
notPatOr = 13; {where pattern pixel is black, leave destination }
{ pixel unaltered; where pattern pixel is white, }
{ apply foreground color to destination pixel}
notPatXor = 14; {where pattern pixel is black, leave destination }
{ pixel unaltered; where pattern pixel is white, }
{ invert destination pixel}
notPatBic = 15; {where pattern pixel is black, leave destination }
{ pixel unaltered; where pattern pixel is white, }
{ apply background color to destination pixel}
ditherCopy = 64; {add to source mode for dithering}
</pre>
<h3>Routines</h3>
<h4>Managing the Graphics Pen</h4>
<pre>PROCEDURE HidePen;
PROCEDURE ShowPen;
PROCEDURE GetPen (VAR pt: Point);
PROCEDURE GetPenState (VAR pnState: PenState);
PROCEDURE SetPenState (pnState: PenState);
PROCEDURE PenSize (width,height: Integer);
PROCEDURE PenMode (mode: Integer);
PROCEDURE PenPat (pat: Pattern);
PROCEDURE PenNormal;
</pre>
<h4>Changing the Background Bit Pattern</h4>
<pre>PROCEDURE BackPat (pat: Pattern);
</pre>
<h4>Drawing Lines</h4>
<pre>PROCEDURE MoveTo (h,v: Integer);
PROCEDURE Move (dh,dv: Integer);
PROCEDURE LineTo (h,v: Integer);
PROCEDURE Line (dh,dv: Integer);
</pre>
<h4>Creating and Managing Rectangles</h4>
<pre>PROCEDURE SetRect (VAR r: Rect; left,top,right,bottom: Integer);
PROCEDURE OffsetRect (VAR r: Rect; dh,dv: Integer);
PROCEDURE InsetRect (VAR r: Rect; dh,dv: Integer);
PROCEDURE UnionRect (src1,src2: Rect; VAR dstRect: Rect);
PROCEDURE Pt2Rect (pt1,pt2: Point; VAR dstRect: Rect);
PROCEDURE PtToAngle (r: Rect; pt: Point; VAR angle: Integer);
FUNCTION SectRect (src1,src2: Rect; VAR dstRect: Rect): Boolean;
FUNCTION PtInRect (pt: Point; r: Rect): Boolean;
FUNCTION EqualRect (rect1,rect2: Rect): Boolean;
FUNCTION EmptyRect (r: Rect): Boolean;
</pre>
<h4>Drawing Rectangles</h4>
<pre>PROCEDURE FrameRect (r: Rect);
PROCEDURE PaintRect (r: Rect);
PROCEDURE FillRect (r: Rect; pat: Pattern);
PROCEDURE EraseRect (r: Rect);
PROCEDURE InvertRect (r: Rect);
</pre>
<h4>Drawing Rounded Rectangles</h4>
<pre>PROCEDURE FrameRoundRect (r: Rect; ovalWidth,ovalHeight: Integer);
PROCEDURE PaintRoundRect (r: Rect; ovalWidth,ovalHeight: Integer);
PROCEDURE FillRoundRect (r: Rect; ovalWidth,ovalHeight: Integer; pat: Pattern);
PROCEDURE EraseRoundRect (r: Rect; ovalWidth,ovalHeight: Integer);
PROCEDURE InvertRoundRect (r: Rect; ovalWidth,ovalHeight: Integer);
</pre>
<h4>Drawing Ovals</h4>
<pre>PROCEDURE FrameOval (r: Rect);
PROCEDURE PaintOval (r: Rect);
PROCEDURE FillOval (r: Rect; pat: Pattern);
PROCEDURE EraseOval (r: Rect);
PROCEDURE InvertOval (r: Rect);
</pre>
<h4>Drawing Arcs and Wedges</h4>
<pre>PROCEDURE FrameArc (r: Rect; startAngle,arcAngle: Integer);
PROCEDURE PaintArc (r: Rect; startAngle,arcAngle: Integer);
PROCEDURE FillArc (r: Rect; startAngle,arcAngle: Integer; pat: Pattern);
PROCEDURE EraseArc (r: Rect; startAngle,arcAngle: Integer);
PROCEDURE InvertArc (r: Rect; startAngle,arcAngle: Integer);
</pre>
<h4>Creating and Managing Polygons</h4>
<pre>FUNCTION OpenPoly : PolyHandle;
PROCEDURE ClosePoly;
PROCEDURE OffsetPoly (poly: PolyHandle; dh,dv: Integer);
PROCEDURE KillPoly (poly: PolyHandle);
</pre>
<h4>Drawing Polygons</h4>
<pre>PROCEDURE FramePoly (poly: PolyHandle);
PROCEDURE PaintPoly (poly: PolyHandle);
PROCEDURE FillPoly (poly: PolyHandle; pat: Pattern);
PROCEDURE ErasePoly (poly: PolyHandle);
PROCEDURE InvertPoly (poly: PolyHandle);
</pre>
<h4>Creating and Managing Regions</h4>
<pre>FUNCTION NewRgn : RgnHandle;
PROCEDURE OpenRgn;
PROCEDURE CloseRgn (dstRgn: rgnHandle);
PROCEDURE DisposeRgn (rgn: RgnHandle);
PROCEDURE CopyRgn (srcRgn,dstRgn: RgnHandle);
PROCEDURE SetEmptyRgn (rgn: RgnHandle);
PROCEDURE SetRectRgn (rgn: RgnHandle; left,top,right,bottom: Integer);
PROCEDURE RectRgn (rgn: RgnHandle; r: Rect);
PROCEDURE OffsetRgn (rgn: RgnHandle; dh,dv: Integer);
PROCEDURE InsetRgn (rgn: RgnHandle; dh,dv: Integer);
PROCEDURE SectRgn (srcRgnA,srcRgnB,dstRgn: RgnHandle);
PROCEDURE UnionRgn (srcRgnA,srcRgnB,dstRgn: RgnHandle);
PROCEDURE DiffRgn (srcRgnA,srcRgnB,dstRgn: RgnHandle);
PROCEDURE XorRgn (srcRgnA,srcRgnB,dstRgn: RgnHandle);
FUNCTION PtInRgn (pt: Point; rgn: RgnHandle): Boolean;
FUNCTION RectInRgn (r: Rect; rgn: RgnHandle): Boolean;
FUNCTION EqualRgn (rgnA,rgnB: RgnHandle): Boolean;
FUNCTION EmptyRgn (rgn: RgnHandle): Boolean;
</pre>
<h4>Drawing Regions</h4>
<pre>PROCEDURE FrameRgn (rgn: RgnHandle);
PROCEDURE PaintRgn (rgn: RgnHandle);
PROCEDURE FillRgn (rgn: RgnHandle; pat: Pattern);
PROCEDURE EraseRgn (rgn: RgnHandle);
PROCEDURE InvertRgn (rgn: RgnHandle);
</pre>
<h4>Scaling and Mapping Points, Rectangles, Polygons, and Regions</h4>
<pre>PROCEDURE ScalePt (VAR pt: Point; srcRect,dstRect: Rect);
PROCEDURE MapPt (VAR pt: Point; srcRect,dstRect: Rect);
PROCEDURE MapRect (VAR r: Rect; srcRect,dstRect: Rect);
PROCEDURE MapRgn (rgn: RgnHandle; srcRect,dstRect: Rect);
PROCEDURE MapPoly (poly: PolyHandle; srcRect,dstRect: Rect);
</pre>
<h4>Calculating Black-and-White Fills</h4>
<pre>PROCEDURE SeedFill (srcPtr,dstPtr: Ptr; srcRow,dstRow,height,words,seedH,seedV: Integer);
PROCEDURE CalcMask (srcPtr,dstPtr: Ptr; srcRow,dstRow,height,words: Integer);
</pre>
<h4>Copying Images</h4>
<pre>PROCEDURE CopyBits (srcBits,dstBits: BitMap; srcRect,dstRect: Rect; mode: Integer; maskRgn: RgnHandle);
PROCEDURE CopyMask (srcBits,maskBits,dstBits: BitMap; srcRect,maskRect,dstRect: Rect);
PROCEDURE CopyDeepMask (srcBits: BitMap; maskBits: BitMap; dstBits: BitMap; srcRect: Rect; maskRect: Rect; dstRect: Rect; mode: Integer; maskRgn: RgnHandle);
</pre>
<h4>Drawing With the Eight-Color System</h4>
<pre>PROCEDURE ForeColor (color: LongInt);
PROCEDURE BackColor (color: LongInt);
PROCEDURE ColorBit (whichBit: Integer);
</pre>
<h4>Determining Whether QuickDraw Has Finished Drawing</h4>
<pre>FUNCTION QDDone (port: GrafPtr): Boolean;
</pre>
<h4>Getting Pattern Resources</h4>
<pre>FUNCTION GetPattern (patID: Integer): PatHandle;
PROCEDURE GetIndPattern (VAR thePattern: Pattern; patListID: Integer; index: Integer);
</pre>
<h4>Customizing QuickDraw Operations</h4>
<pre>PROCEDURE SetStdProcs (VAR procs: QDProcs);
PROCEDURE StdText (byteCount: Integer; textBuf: Ptr; numer,denom: Point);
PROCEDURE StdLine (newPt: Point);
PROCEDURE StdRect (verb: GrafVerb; r: Rect);
PROCEDURE StdRRect (verb: GrafVerb; r: Rect; ovalwidth,ovalHeight: Integer);
PROCEDURE StdOval (verb: GrafVerb; r: Rect);
PROCEDURE StdArc (verb: GrafVerb; r: Rect; startAngle,arcAngle: Integer);
PROCEDURE StdPoly (verb: GrafVerb; poly: PolyHandle);
PROCEDURE StdRgn (verb: GrafVerb; rgn: RgnHandle);
PROCEDURE StdBits (VAR srcBits: BitMap; VAR srcRect,dstRect: Rect; mode: Integer; maskRgn: RgnHandle);
PROCEDURE StdComment (kind,dataSize: Integer; dataHandle: Handle);
FUNCTION StdTxtMeas (byteCount: Integer; textAddr: Ptr; VAR numer, denom: Point; VAR info: FontInfo): Integer;
PROCEDURE StdGetPic (dataPtr: Ptr; byteCount: Integer);
PROCEDURE StdPutPic (dataPtr: Ptr; byteCount: Integer);
</pre>

186
examples/3d.box.pas Normal file
View File

@ -0,0 +1,186 @@
program Boxes;
uses
FixMath, Graf3D;
type
Link3D = record
a: Integer;
b: Integer;
end;
var
w: WindowPtr; {A window to draw in}
r: Rect; {A window Size}
myPort: GrafPort;
myPort3D: Port3D;
pa, pb: Point3D;
hangle, vangle: Longint;
{cursor}
cursor, prev: Point;
isDown: Boolean;
{cube}
shape: array[1..9] of Point3D;
links: array[1..13] of Link3D;
{>>}
procedure SetLk3D (var lk3D: Link3D; a, b: Integer);
begin
lk3D.a := a;
lk3D.b := b;
end;
{>>}
procedure CreateCube;
begin
SetPt3D(shape[1], Long2Fix(20), Long2Fix(20), Long2Fix(20));
SetPt3D(shape[2], Long2Fix(20), Long2Fix(20), Long2Fix(-20));
SetPt3D(shape[3], Long2Fix(-20), Long2Fix(20), Long2Fix(-20));
SetPt3D(shape[4], Long2Fix(-20), Long2Fix(20), Long2Fix(20));
SetPt3D(shape[5], Long2Fix(20), Long2Fix(-20), Long2Fix(20));
SetPt3D(shape[6], Long2Fix(20), Long2Fix(-20), Long2Fix(-20));
SetPt3D(shape[7], Long2Fix(-20), Long2Fix(-20), Long2Fix(-20));
SetPt3D(shape[8], Long2Fix(-20), Long2Fix(-20), Long2Fix(20));
SetLk3D(links[1], 1, 2);
SetLk3D(links[2], 2, 3);
SetLk3D(links[3], 3, 4);
SetLk3D(links[4], 4, 1);
SetLk3D(links[5], 5, 6);
SetLk3D(links[6], 6, 7);
SetLk3D(links[7], 7, 8);
SetLk3D(links[8], 8, 5);
SetLk3D(links[9], 1, 5);
SetLk3D(links[10], 2, 6);
SetLk3D(links[11], 3, 7);
SetLk3D(links[12], 4, 8);
end;
{>>}
procedure PaintCube;
var
i: Integer;
begin
for i := 1 to 12 do
begin
MoveTo3D(shape[links[i].a].x, shape[links[i].a].y, shape[links[i].a].z);
LineTo3D(shape[links[i].b].x, shape[links[i].b].y, shape[links[i].b].z);
end;
end;
{>>}
procedure PaintFace;
var
tempRgn: RgnHandle;
begin
tempRgn := NewRgn;
OpenRgn;
MoveTo3D(shape[1].x, shape[1].Y, shape[1].Z);
LineTo3D(shape[2].X, shape[2].Y, shape[2].Z);
LineTo3D(shape[3].X, shape[3].Y, shape[3].Z);
LineTo3D(shape[4].X, shape[4].Y, shape[4].Z);
LineTo3D(shape[1].X, shape[1].Y, shape[1].Z);
CloseRgn(tempRgn);
FillRgn(tempRgn, gray);
end;
{>>}
procedure PaintAxis (size: Integer);
begin
PenPat(black);
MoveTo3D(0, 0, 0);
LineTo3D(Long2Fix(size), 0, 0);
WriteDraw('x');
MoveTo3D(0, 0, 0);
LineTo3D(0, Long2Fix(size), 0);
WriteDraw('y');
MoveTo3D(0, 0, 0);
LineTo3D(0, 0, Long2Fix(size));
WriteDraw('z');
end;
{>>}
procedure WindowInit;
begin
SetRect(r, 100, 50, 300, 250);
w := NewWindow(nil, r, 'Study', true, zoomDocProc, WindowPtr(-1), false, 0);
SetPort(w);
end;
{>>}
procedure ClearScreen;
var
size: Rect;
begin
SetRect(size, 0, 0, 200, 200);
FillRect(size, white);
end;
{>>}
procedure Redraw;
begin
ClearScreen;
LookAt(Long2Fix(-50), Long2Fix(50), Long2Fix(50), Long2Fix(-50));
ViewAngle(Long2Fix(20));
Identity;
Roll(Long2Fix(hangle));
Pitch(Long2Fix(vangle)); { roll and pitch the plane }
PaintFace;
PaintCube;
PaintAxis(10);
end;
{>>}
procedure WhenDownChanged;
var
hoff, voff: Integer;
begin
hoff := prev.h - cursor.h;
hangle := hangle + hoff;
voff := prev.v - cursor.v;
vangle := vangle + voff;
Redraw;
GetMouse(prev);
end;
{>>}
procedure WhenDown;
begin
GetMouse(cursor);
if cursor.h <> prev.h then
if cursor.v <> prev.v then
WhenDownChanged;
end;
{>>}
procedure MainLoop;
begin
repeat {Until we click outside screen}
while button do
begin
GetMouse(cursor);
GetMouse(prev);
repeat {Tight loop until button up}
WhenDown;
until not Button;
end;
until cursor.h < 0;
end;
begin
WindowInit;
InitGrf3D(nil);
Open3DPort(@myPort3D);
ViewPort(thePort^.portRect);
CreateCube;
Redraw;
MainLoop;
end.

248
examples/3d.checkboard.pas Normal file
View File

@ -0,0 +1,248 @@
program Boxes;
uses
FixMath, Graf3D;
type
Link3D = record
a: Integer;
b: Integer;
end;
var
w: WindowPtr; {A window to draw in}
r: Rect; {A window Size}
myPort: GrafPort;
myPort3D: Port3D;
pa, pb: Point3D;
hangle, vangle: Longint;
{cursor}
cursor, prev: Point;
isDown: Boolean;
{cube}
shape: array[1..9] of Point3D;
links: array[1..13] of Link3D;
{>>}
procedure SetLk3D (var lk3D: Link3D; a, b: Integer);
begin
lk3D.a := a;
lk3D.b := b;
end;
{>>}
procedure CreateCube;
begin
SetPt3D(shape[1], Long2Fix(20), Long2Fix(20), Long2Fix(20));
SetPt3D(shape[2], Long2Fix(20), Long2Fix(40), Long2Fix(-20));
SetPt3D(shape[3], Long2Fix(-20), Long2Fix(20), Long2Fix(-20));
SetPt3D(shape[4], Long2Fix(-20), Long2Fix(20), Long2Fix(20));
SetPt3D(shape[5], Long2Fix(20), Long2Fix(-20), Long2Fix(20));
SetPt3D(shape[6], Long2Fix(20), Long2Fix(-20), Long2Fix(-20));
SetPt3D(shape[7], Long2Fix(-20), Long2Fix(-20), Long2Fix(-20));
SetPt3D(shape[8], Long2Fix(-20), Long2Fix(-20), Long2Fix(20));
SetLk3D(links[1], 1, 2);
SetLk3D(links[2], 2, 3);
SetLk3D(links[3], 3, 4);
SetLk3D(links[4], 4, 1);
SetLk3D(links[5], 5, 6);
SetLk3D(links[6], 6, 7);
SetLk3D(links[7], 7, 8);
SetLk3D(links[8], 8, 5);
SetLk3D(links[9], 1, 5);
SetLk3D(links[10], 2, 6);
SetLk3D(links[11], 3, 7);
SetLk3D(links[12], 4, 8);
end;
{>>}
procedure PaintCube;
var
i: Integer;
begin
for i := 1 to 12 do
begin
MoveTo3D(shape[links[i].a].x, shape[links[i].a].y, shape[links[i].a].z);
LineTo3D(shape[links[i].b].x, shape[links[i].b].y, shape[links[i].b].z);
end;
end;
{>>}
function Interpolate (a, b, t: Fixed): Fixed;
begin
Interpolate := a + FixMul(b - a, t);
end;
{>>}
function HasPixel3D (col, row: Integer): Boolean;
begin
HasPixel3D := ((col + (row mod 2 + 1)) mod 2 = 0)
end;
{>>}
procedure LerpPt (var dest, a, b: Point3D; t: Fixed);
begin
SetPt3D(dest, Interpolate(a.x, b.x, t), Interpolate(a.y, b.y, t), Interpolate(a.z, b.z, t))
end;
{>>}
procedure ToPlane (var dest, a, b, c, d: Point3D; col, row, limit: Integer);
var
top, bottom, left, right, result1, result2: Point3D;
begin
LerpPt(top, a, b, FixRatio(row, limit));
LerpPt(bottom, d, c, FixRatio(row, limit));
LerpPt(left, a, d, FixRatio(col, limit));
LerpPt(right, b, c, FixRatio(col, limit));
LerpPt(result1, top, bottom, FixRatio(col, limit));
LerpPt(result2, left, right, FixRatio(row, limit));
LerpPt(dest, result1, result2, FixRatio(col, 2));
end;
{>>}
procedure PaintFace (a, b, c, d: Point3D);
var
tempRgn: RgnHandle;
row, col: Integer;
hpt, vpt, minia, minib, minic, minid: Point3D;
x, y, z: Fixed;
limit: Integer;
begin
limit := 10;
tempRgn := NewRgn;
OpenRgn;
for col := 0 to limit - 1 do
begin
row := 0;
for row := 0 to limit - 1 do
begin
if HasPixel3D(col, row) then
begin
ToPlane(minia, a, b, c, d, row, col, limit);
ToPlane(minib, a, b, c, d, row + 1, col, limit);
ToPlane(minic, a, b, c, d, row, col + 1, limit);
ToPlane(minid, a, b, c, d, row + 1, col + 1, limit);
MoveTo3D(minia.x, minia.y, minia.z);
LineTo3D(minib.x, minib.y, minib.z);
LineTo3D(minid.x, minid.y, minid.z);
LineTo3D(minic.x, minic.y, minic.z);
LineTo3D(minia.x, minia.y, minia.z);
end;
end;
end;
CloseRgn(tempRgn);
PaintRgn(tempRgn);
DisposeRgn(tempRgn);
end;
{>>}
procedure PaintAxis (size: Integer);
begin
PenPat(black);
MoveTo3D(0, 0, 0);
LineTo3D(Long2Fix(size), 0, 0);
WriteDraw('x');
MoveTo3D(0, 0, 0);
LineTo3D(0, Long2Fix(size), 0);
WriteDraw('y');
MoveTo3D(0, 0, 0);
LineTo3D(0, 0, Long2Fix(size));
WriteDraw('z');
end;
{>>}
procedure WindowInit;
begin
SetRect(r, 100, 50, 300, 250);
w := NewWindow(nil, r, 'Mapping', true, zoomDocProc, WindowPtr(-1), false, 0);
SetPort(w);
end;
{>>}
procedure ClearScreen;
var
size: Rect;
begin
SetRect(size, 0, 0, 200, 200);
FillRect(size, white);
end;
{>>}
procedure Redraw;
begin
ClearScreen;
LookAt(Long2Fix(-50), Long2Fix(50), Long2Fix(50), Long2Fix(-50));
ViewAngle(Long2Fix(20));
Identity;
Roll(Long2Fix(hangle));
Pitch(Long2Fix(vangle)); { roll and pitch the plane }
PaintAxis(10);
PaintFace(shape[1], shape[2], shape[3], shape[4]);
PaintCube;
end;
{>>}
procedure WhenDownChanged;
var
hoff, voff: Integer;
begin
hoff := prev.h - cursor.h;
hangle := hangle + hoff;
voff := prev.v - cursor.v;
vangle := vangle + voff;
Redraw;
GetMouse(prev);
end;
{>>}
procedure WhenDown;
begin
GetMouse(cursor);
if cursor.h <> prev.h then
if cursor.v <> prev.v then
WhenDownChanged;
end;
{>>}
procedure MainLoop;
begin
repeat {Until we click outside screen}
while button do
begin
GetMouse(cursor);
GetMouse(prev);
repeat {Tight loop until button up}
WhenDown;
until not Button;
end;
until cursor.h < 0;
end;
begin
WindowInit;
InitGrf3D(nil);
Open3DPort(@myPort3D);
ViewPort(thePort^.portRect);
CreateCube;
hangle := 145;
vangle := 65;
Redraw;
MainLoop;
end.

195
examples/3d.interpolate.pas Normal file
View File

@ -0,0 +1,195 @@
program Boxes;
uses
FixMath, Graf3D;
type
Link3D = record
a: Integer;
b: Integer;
end;
var
w: WindowPtr; {A window to draw in}
r: Rect; {A window Size}
myPort: GrafPort;
myPort3D: Port3D;
pa, pb: Point3D;
hangle, vangle: Longint;
{cursor}
cursor, prev: Point;
isDown: Boolean;
{cube}
shape: array[1..9] of Point3D;
links: array[1..13] of Link3D;
{>>}
procedure SetLk3D (var lk3D: Link3D; a, b: Integer);
begin
lk3D.a := a;
lk3D.b := b;
end;
{>>}
procedure CreateCube;
begin
SetPt3D(shape[1], Long2Fix(20), Long2Fix(20), Long2Fix(20));
SetPt3D(shape[2], Long2Fix(20), Long2Fix(20), Long2Fix(-20));
SetPt3D(shape[3], Long2Fix(-20), Long2Fix(20), Long2Fix(-20));
SetPt3D(shape[4], Long2Fix(-20), Long2Fix(20), Long2Fix(20));
SetPt3D(shape[5], Long2Fix(20), Long2Fix(-20), Long2Fix(20));
SetPt3D(shape[6], Long2Fix(20), Long2Fix(-20), Long2Fix(-20));
SetPt3D(shape[7], Long2Fix(-20), Long2Fix(-20), Long2Fix(-20));
SetPt3D(shape[8], Long2Fix(-20), Long2Fix(-20), Long2Fix(20));
SetLk3D(links[1], 1, 2);
SetLk3D(links[2], 2, 3);
SetLk3D(links[3], 3, 4);
SetLk3D(links[4], 4, 1);
SetLk3D(links[5], 5, 6);
SetLk3D(links[6], 6, 7);
SetLk3D(links[7], 7, 8);
SetLk3D(links[8], 8, 5);
SetLk3D(links[9], 1, 5);
SetLk3D(links[10], 2, 6);
SetLk3D(links[11], 3, 7);
SetLk3D(links[12], 4, 8);
end;
{>>}
procedure PaintCube;
var
i: Integer;
begin
for i := 1 to 12 do
begin
MoveTo3D(shape[links[i].a].x, shape[links[i].a].y, shape[links[i].a].z);
LineTo3D(shape[links[i].b].x, shape[links[i].b].y, shape[links[i].b].z);
end;
end;
{>>}
function Interpolate (a, b, t: Fixed): Fixed;
begin
Interpolate := a + FixMul(b - a, t);
end;
{>>}
procedure LerpPt (var dest, a, b: Point3D; t: Fixed);
begin
SetPt3D(dest, Interpolate(a.x, b.x, t), Interpolate(a.y, b.y, t), Interpolate(a.z, b.z, t))
end;
{>>}
procedure PaintFace (a, b, c, d: Point3D);
var
tempRgn: RgnHandle;
id, row, col, subs: Integer;
minia: Point3D;
begin
LerpPt(minia, a, b, FixRatio(2, 4));
MoveTo3D(minia.x, minia.y, minia.z);
LineTo3D(c.x, c.y, c.z);
end;
{>>}
procedure PaintAxis (size: Integer);
begin
PenPat(black);
MoveTo3D(0, 0, 0);
LineTo3D(Long2Fix(size), 0, 0);
WriteDraw('x');
MoveTo3D(0, 0, 0);
LineTo3D(0, Long2Fix(size), 0);
WriteDraw('y');
MoveTo3D(0, 0, 0);
LineTo3D(0, 0, Long2Fix(size));
WriteDraw('z');
end;
{>>}
procedure WindowInit;
begin
SetRect(r, 100, 50, 300, 250);
w := NewWindow(nil, r, 'Study', true, zoomDocProc, WindowPtr(-1), false, 0);
SetPort(w);
end;
{>>}
procedure ClearScreen;
var
size: Rect;
begin
SetRect(size, 0, 0, 200, 200);
FillRect(size, white);
end;
{>>}
procedure Redraw;
begin
ClearScreen;
LookAt(Long2Fix(-50), Long2Fix(50), Long2Fix(50), Long2Fix(-50));
ViewAngle(Long2Fix(20));
Identity;
Roll(Long2Fix(hangle));
Pitch(Long2Fix(vangle)); { roll and pitch the plane }
PaintFace(shape[1], shape[2], shape[3], shape[4]);
PaintCube;
PaintAxis(10);
end;
{>>}
procedure WhenDownChanged;
var
hoff, voff: Integer;
begin
hoff := prev.h - cursor.h;
hangle := hangle + hoff;
voff := prev.v - cursor.v;
vangle := vangle + voff;
Redraw;
GetMouse(prev);
end;
{>>}
procedure WhenDown;
begin
GetMouse(cursor);
if cursor.h <> prev.h then
if cursor.v <> prev.v then
WhenDownChanged;
end;
{>>}
procedure MainLoop;
begin
repeat {Until we click outside screen}
while button do
begin
GetMouse(cursor);
GetMouse(prev);
repeat {Tight loop until button up}
WhenDown;
until not Button;
end;
until cursor.h < 0;
end;
begin
WindowInit;
InitGrf3D(nil);
Open3DPort(@myPort3D);
ViewPort(thePort^.portRect);
CreateCube;
Redraw;
MainLoop;
end.

268
examples/3d.macintosh.pas Normal file
View File

@ -0,0 +1,268 @@
program Boxes;
uses
FixMath, Graf3D;
type
Link3D = record
a: Integer;
b: Integer;
end;
var
w: WindowPtr; {A window to draw in}
r: Rect; {A window Size}
myPort: GrafPort;
myPort3D: Port3D;
pa, pb: Point3D;
hangle, vangle: Longint;
{cursor}
cursor, prev: Point;
isDown: Boolean;
{cube}
shape: array[1..42] of Point3D;
links: array[1..56] of Link3D;
{>>}
procedure SetLk3D (var lk3D: Link3D; a, b: Integer);
begin
lk3D.a := a;
lk3D.b := b;
end;
{>>}
procedure CreateCube;
begin
SetPt3D(shape[1], Long2Fix(-60), Long2Fix(-80), Long2Fix(45));
SetPt3D(shape[2], Long2Fix(-60), Long2Fix(-50), Long2Fix(65));
SetPt3D(shape[3], Long2Fix(-60), Long2Fix(80), Long2Fix(65));
SetPt3D(shape[4], Long2Fix(-60), Long2Fix(80), Long2Fix(-55));
SetPt3D(shape[5], Long2Fix(-60), Long2Fix(60), Long2Fix(-55));
SetPt3D(shape[6], Long2Fix(-60), Long2Fix(60), Long2Fix(-70));
SetPt3D(shape[7], Long2Fix(60), Long2Fix(-80), Long2Fix(-70));
SetPt3D(shape[8], Long2Fix(60), Long2Fix(-80), Long2Fix(45));
SetPt3D(shape[9], Long2Fix(60), Long2Fix(-50), Long2Fix(65));
SetPt3D(shape[10], Long2Fix(60), Long2Fix(80), Long2Fix(65));
SetPt3D(shape[11], Long2Fix(60), Long2Fix(80), Long2Fix(-55));
SetPt3D(shape[12], Long2Fix(60), Long2Fix(60), Long2Fix(-55));
SetPt3D(shape[13], Long2Fix(60), Long2Fix(60), Long2Fix(-70));
SetPt3D(shape[14], Long2Fix(-25), Long2Fix(-50), Long2Fix(65));
SetPt3D(shape[15], Long2Fix(-25), Long2Fix(-60), Long2Fix(-10));
SetPt3D(shape[16], Long2Fix(-25), Long2Fix(-80), Long2Fix(-10));
SetPt3D(shape[17], Long2Fix(-25), Long2Fix(-80), Long2Fix(45));
SetPt3D(shape[18], Long2Fix(25), Long2Fix(-50), Long2Fix(65));
SetPt3D(shape[19], Long2Fix(25), Long2Fix(-60), Long2Fix(-10));
SetPt3D(shape[20], Long2Fix(25), Long2Fix(-80), Long2Fix(-10));
SetPt3D(shape[21], Long2Fix(25), Long2Fix(-80), Long2Fix(45));
SetPt3D(shape[22], Long2Fix(-50), Long2Fix(-65), Long2Fix(-70));
SetPt3D(shape[23], Long2Fix(50), Long2Fix(-65), Long2Fix(-70));
SetPt3D(shape[24], Long2Fix(50), Long2Fix(10), Long2Fix(-70));
SetPt3D(shape[25], Long2Fix(-50), Long2Fix(10), Long2Fix(-70));
SetPt3D(shape[26], Long2Fix(-45), Long2Fix(-60), Long2Fix(-63));
SetPt3D(shape[27], Long2Fix(45), Long2Fix(-60), Long2Fix(-63));
SetPt3D(shape[28], Long2Fix(45), Long2Fix(5), Long2Fix(-63));
SetPt3D(shape[29], Long2Fix(-45), Long2Fix(5), Long2Fix(-63));
SetPt3D(shape[30], Long2Fix(50), Long2Fix(22), Long2Fix(-70));
SetPt3D(shape[31], Long2Fix(30), Long2Fix(22), Long2Fix(-70));
SetPt3D(shape[32], Long2Fix(30), Long2Fix(25), Long2Fix(-70));
SetPt3D(shape[33], Long2Fix(-5), Long2Fix(25), Long2Fix(-70));
SetPt3D(shape[34], Long2Fix(-5), Long2Fix(32), Long2Fix(-70));
SetPt3D(shape[35], Long2Fix(30), Long2Fix(32), Long2Fix(-70));
SetPt3D(shape[36], Long2Fix(30), Long2Fix(35), Long2Fix(-70));
SetPt3D(shape[37], Long2Fix(50), Long2Fix(35), Long2Fix(-70));
SetPt3D(shape[38], Long2Fix(-50), Long2Fix(32), Long2Fix(-70));
SetPt3D(shape[39], Long2Fix(-37), Long2Fix(32), Long2Fix(-70));
SetPt3D(shape[40], Long2Fix(-37), Long2Fix(45), Long2Fix(-70));
SetPt3D(shape[41], Long2Fix(-50), Long2Fix(45), Long2Fix(-70));
SetPt3D(shape[42], Long2Fix(-60), Long2Fix(-80), Long2Fix(-70));
SetLk3D(links[1], 42, 1);
SetLk3D(links[2], 1, 2);
SetLk3D(links[3], 2, 3);
SetLk3D(links[4], 3, 4);
SetLk3D(links[5], 4, 5);
SetLk3D(links[6], 5, 6);
SetLk3D(links[7], 6, 42);
SetLk3D(links[8], 7, 8);
SetLk3D(links[9], 8, 9);
SetLk3D(links[10], 9, 10);
SetLk3D(links[11], 10, 11);
SetLk3D(links[12], 11, 12);
SetLk3D(links[13], 12, 13);
SetLk3D(links[14], 13, 7);
SetLk3D(links[15], 42, 7);
SetLk3D(links[16], 2, 9);
SetLk3D(links[17], 3, 10);
SetLk3D(links[18], 4, 11);
SetLk3D(links[19], 5, 12);
SetLk3D(links[20], 6, 13);
SetLk3D(links[21], 14, 15);
SetLk3D(links[22], 15, 16);
SetLk3D(links[23], 16, 17);
SetLk3D(links[24], 17, 14);
SetLk3D(links[25], 18, 19);
SetLk3D(links[26], 19, 20);
SetLk3D(links[27], 20, 21);
SetLk3D(links[28], 21, 18);
SetLk3D(links[29], 17, 1);
SetLk3D(links[30], 21, 8);
SetLk3D(links[31], 15, 19);
SetLk3D(links[32], 16, 20);
SetLk3D(links[33], 22, 23);
SetLk3D(links[34], 23, 24);
SetLk3D(links[35], 24, 25);
SetLk3D(links[36], 25, 22);
SetLk3D(links[37], 26, 27);
SetLk3D(links[38], 27, 28);
SetLk3D(links[39], 28, 29);
SetLk3D(links[40], 29, 26);
SetLk3D(links[41], 22, 26);
SetLk3D(links[42], 23, 27);
SetLk3D(links[43], 24, 28);
SetLk3D(links[44], 25, 29);
SetLk3D(links[45], 30, 31);
SetLk3D(links[46], 31, 32);
SetLk3D(links[47], 32, 33);
SetLk3D(links[48], 33, 34);
SetLk3D(links[49], 34, 35);
SetLk3D(links[50], 35, 36);
SetLk3D(links[51], 36, 37);
SetLk3D(links[52], 37, 30);
SetLk3D(links[53], 38, 39);
SetLk3D(links[54], 39, 40);
SetLk3D(links[55], 40, 41);
SetLk3D(links[56], 41, 38);
end;
{>>}
procedure PaintCube;
var
i: Integer;
begin
for i := 1 to 56 do
begin
MoveTo3D(shape[links[i].a].x, shape[links[i].a].y, shape[links[i].a].z);
LineTo3D(shape[links[i].b].x, shape[links[i].b].y, shape[links[i].b].z);
end;
end;
{>>}
procedure PaintFace;
var
tempRgn: RgnHandle;
begin
tempRgn := NewRgn;
OpenRgn;
MoveTo3D(shape[26].x, shape[26].Y, shape[26].Z);
LineTo3D(shape[27].X, shape[27].Y, shape[27].Z);
LineTo3D(shape[28].X, shape[28].Y, shape[28].Z);
LineTo3D(shape[29].X, shape[29].Y, shape[29].Z);
LineTo3D(shape[26].X, shape[26].Y, shape[26].Z);
CloseRgn(tempRgn);
FillRgn(tempRgn, ltgray);
DisposeRgn(tempRgn);
end;
{>>}
procedure PaintInspector (pt3D: Point3D);
begin
MoveTo3D(pt3D.x, pt3D.y, pt3D.z);
Line2D(pt3D.x + 5, pt3D.y);
end;
{>>}
procedure PaintAxis (size: Integer);
begin
PenPat(black);
MoveTo3D(0, 0, 0);
LineTo3D(Long2Fix(size), 0, 0);
WriteDraw('x');
MoveTo3D(0, 0, 0);
LineTo3D(0, Long2Fix(size), 0);
WriteDraw('y');
MoveTo3D(0, 0, 0);
LineTo3D(0, 0, Long2Fix(size));
WriteDraw('z');
end;
{>>}
procedure WindowInit;
begin
SetRect(r, 100, 50, 300, 250);
w := NewWindow(nil, r, 'Study', true, zoomDocProc, WindowPtr(-1), false, 0);
SetPort(w);
end;
{>>}
procedure ClearScreen;
var
size: Rect;
begin
SetRect(size, 0, 0, 200, 200);
FillRect(size, white);
end;
{>>}
procedure Redraw;
begin
ClearScreen;
LookAt(Long2Fix(-200), Long2Fix(200), Long2Fix(200), Long2Fix(-200));
ViewAngle(Long2Fix(50));
Identity;
Roll(Long2Fix(hangle));
Pitch(Long2Fix(vangle)); { roll and pitch the plane }
PaintFace;
PaintCube;
end;
{>>}
procedure WhenDownChanged;
var
hoff, voff: Integer;
begin
hoff := prev.h - cursor.h;
hangle := hangle + hoff;
voff := prev.v - cursor.v;
vangle := vangle + voff;
Redraw;
GetMouse(prev);
end;
{>>}
procedure WhenDown;
begin
GetMouse(cursor);
if cursor.h <> prev.h then
if cursor.v <> prev.v then
WhenDownChanged;
end;
{>>}
procedure MainLoop;
begin
repeat {Until we click outside screen}
while button do
begin
GetMouse(cursor);
GetMouse(prev);
repeat {Tight loop until button up}
WhenDown;
until not Button;
end;
until cursor.h < 0;
end;
begin
WindowInit;
InitGrf3D(nil);
Open3DPort(@myPort3D);
ViewPort(thePort^.portRect);
CreateCube;
Redraw;
MainLoop;
end.

99
examples/3d.normals.pas Normal file
View File

@ -0,0 +1,99 @@
program ExampleNormals;
uses
FixMath, Graf3D;
var
w: WindowPtr; {A window to draw in}
r: Rect; {A window Size}
myPort: GrafPort;
myPort3D: Port3D;
i: INTEGER;
dummy: EventRecord;
pa, pb: Point3D;
{>>}
procedure WindowInit;
begin
SetRect(r, 100, 50, 550, 400);
w := NewWindow(nil, r, 'Color Cube', true, zoomDocProc, WindowPtr(-1), false, 0);
SetPort(w);
end;
{>>}
procedure MainLoop;
begin
repeat
until button;
end;
{>>}
procedure DrawBrick (pt1, pt2: Point3D);
var
tempRgn: RgnHandle;
begin
tempRgn := NewRgn;
ForeColor(blueColor);
BackColor(yellowColor);
OpenRgn;
MoveTo3D(pt1.X, pt1.Y, pt1.Z); { front face, y=y1 }
LineTo3D(pt1.X, pt1.Y, pt2.Z);
LineTo3D(pt2.X, pt1.Y, pt2.Z);
LineTo3D(pt2.X, pt1.Y, pt1.Z);
LineTo3D(pt1.X, pt1.Y, pt1.Z);
CloseRgn(tempRgn);
FillRgn(tempRgn, ltgray);
ForeColor(redColor);
BackColor(cyanColor);
OpenRgn;
MoveTo3D(pt1.X, pt1.Y, pt2.Z); { top face, z=z2 }
LineTo3D(pt1.X, pt2.Y, pt2.Z);
LineTo3D(pt2.X, pt2.Y, pt2.Z);
LineTo3D(pt2.X, pt1.Y, pt2.Z);
LineTo3D(pt1.X, pt1.Y, pt2.Z);
CloseRgn(tempRgn);
FillRgn(tempRgn, ltgray);
ForeColor(greenColor);
BackColor(magentaColor);
OpenRgn;
MoveTo3D(pt2.X, pt1.Y, pt1.Z); { right face, x=x2 }
LineTo3D(pt2.X, pt1.Y, pt2.Z);
LineTo3D(pt2.X, pt2.Y, pt2.Z);
LineTo3D(pt2.X, pt2.Y, pt1.Z);
LineTo3D(pt2.X, pt1.Y, pt1.Z);
CloseRgn(tempRgn);
FillRgn(tempRgn, ltgray);
PenPat(white);
MoveTo3D(pt2.X, pt2.Y, pt2.Z); { outline right }
LineTo3D(pt2.X, pt2.Y, pt1.Z);
LineTo3D(pt2.X, pt1.Y, pt1.Z);
PenNormal;
DisposeRgn(tempRgn);
end;
begin
WindowInit;
InitGrf3D(nil);
Open3DPort(@myPort3D);
{ camera }
ViewPort(thePort^.portRect);
LookAt(Long2Fix(-100), Long2Fix(100), Long2Fix(100), Long2Fix(-100));
ViewAngle(Long2Fix(20));
Identity;
Roll(Long2Fix(20));
Pitch(Long2Fix(70)); { roll and pitch the plane }
SetPt3D(pa, Long2Fix(20), Long2Fix(20), Long2Fix(20));
SetPt3D(pb, Long2Fix(-20), Long2Fix(-20), Long2Fix(-20));
DrawBrick(pa, pb);
MainLoop;
end.

169
examples/3d.rotate.pas Normal file
View File

@ -0,0 +1,169 @@
program Boxes;
uses
FixMath, Graf3D;
type
Link3D = record
a: Integer;
b: Integer;
end;
var
w: WindowPtr; {A window to draw in}
r: Rect; {A window Size}
myPort: GrafPort;
myPort3D: Port3D;
pa, pb: Point3D;
hangle, vangle: Longint;
{cursor}
cursor, prev: Point;
isDown: Boolean;
{cube}
shape: array[1..9] of Point3D;
links: array[1..13] of Link3D;
{>>}
procedure SetLk3D (var lk3D: Link3D; a, b: Integer);
begin
lk3D.a := a;
lk3D.b := b;
end;
{>>}
procedure CreateCube;
begin
SetPt3D(shape[1], Long2Fix(20), Long2Fix(20), Long2Fix(20));
SetPt3D(shape[2], Long2Fix(20), Long2Fix(20), Long2Fix(-20));
SetPt3D(shape[3], Long2Fix(-20), Long2Fix(20), Long2Fix(-20));
SetPt3D(shape[4], Long2Fix(-20), Long2Fix(20), Long2Fix(20));
SetPt3D(shape[5], Long2Fix(20), Long2Fix(-20), Long2Fix(20));
SetPt3D(shape[6], Long2Fix(20), Long2Fix(-20), Long2Fix(-20));
SetPt3D(shape[7], Long2Fix(-20), Long2Fix(-20), Long2Fix(-20));
SetPt3D(shape[8], Long2Fix(-20), Long2Fix(-20), Long2Fix(20));
SetLk3D(links[1], 1, 2);
SetLk3D(links[2], 2, 3);
SetLk3D(links[3], 3, 4);
SetLk3D(links[4], 4, 1);
SetLk3D(links[5], 5, 6);
SetLk3D(links[6], 6, 7);
SetLk3D(links[7], 7, 8);
SetLk3D(links[8], 8, 5);
SetLk3D(links[9], 1, 5);
SetLk3D(links[10], 2, 6);
SetLk3D(links[11], 3, 7);
SetLk3D(links[12], 4, 8);
end;
{>>}
procedure PaintCube;
var
i: Integer;
begin
for i := 1 to 12 do
begin
MoveTo3D(shape[links[i].a].x, shape[links[i].a].y, shape[links[i].a].z);
LineTo3D(shape[links[i].b].x, shape[links[i].b].y, shape[links[i].b].z);
end;
end;
{>>}
procedure PaintAxis (size: Integer);
begin
PenPat(black);
MoveTo3D(0, 0, 0);
LineTo3D(Long2Fix(size), 0, 0);
WriteDraw('x');
MoveTo3D(0, 0, 0);
LineTo3D(0, Long2Fix(size), 0);
WriteDraw('y');
MoveTo3D(0, 0, 0);
LineTo3D(0, 0, Long2Fix(size));
WriteDraw('z');
end;
{>>}
procedure WindowInit;
begin
SetRect(r, 100, 50, 300, 250);
w := NewWindow(nil, r, 'Study', true, zoomDocProc, WindowPtr(-1), false, 0);
SetPort(w);
end;
{>>}
procedure ClearScreen;
var
size: Rect;
begin
SetRect(size, 0, 0, 200, 200);
FillRect(size, white);
end;
{>>}
procedure Redraw;
begin
ClearScreen;
LookAt(Long2Fix(-50), Long2Fix(50), Long2Fix(50), Long2Fix(-50));
ViewAngle(Long2Fix(20));
Identity;
Roll(Long2Fix(hangle));
Pitch(Long2Fix(vangle)); { roll and pitch the plane }
PaintAxis(10);
PaintCube;
end;
{>>}
procedure WhenDownChanged;
var
hoff, voff: Integer;
begin
hoff := prev.h - cursor.h;
hangle := hangle + hoff;
voff := prev.v - cursor.v;
vangle := vangle + voff;
Redraw;
GetMouse(prev);
end;
{>>}
procedure WhenDown;
begin
GetMouse(cursor);
if cursor.h <> prev.h then
if cursor.v <> prev.v then
WhenDownChanged;
end;
{>>}
procedure MainLoop;
begin
repeat {Until we click outside screen}
while button do
begin
GetMouse(cursor);
GetMouse(prev);
repeat {Tight loop until button up}
WhenDown;
until not Button;
end;
until cursor.h < 0;
end;
begin
WindowInit;
InitGrf3D(nil);
Open3DPort(@myPort3D);
ViewPort(thePort^.portRect);
CreateCube;
Redraw;
MainLoop;
end.

26
examples/angle.pas Normal file
View File

@ -0,0 +1,26 @@
program ExampleAngle;
var
ax, ay, bx, by, angle, length, t: Real;
begin
angle := 45;
length := 100;
ax := 50;
ay := 50;
t := angle * PI / 180;
bx := ax + length * cos(t);
by := ay + length * sin(t);
ShowDrawing;
{ origin }
MoveTo(round(ax), round(ay));
LineTo(round(ax + 100), round(ay));
{ offset }
MoveTo(round(ax), round(ay));
LineTo(round(bx), round(by));
end.

26
examples/around.pas Normal file
View File

@ -0,0 +1,26 @@
program ExampleAround;
var
count, countup, countdown: Integer;
box: rect;
begin
{ Create the window rect }
SetRect(box, 100, 100, 320, 320);
SetDrawingRect(box);
ShowDrawing;
{ Draw lines }
for count := 0 to 20 do
begin
countup := count * 4;
countdown := 200 - countup;
Moveto(countup, 0);
Lineto(200, countup);
Lineto(countdown, 200);
Lineto(0, countdown);
Lineto(countup, 0);
end
end.

49
examples/ball.pas Normal file
View File

@ -0,0 +1,49 @@
program ExampleBall;
const
PICTURE_HEIGHT = 100;
PICTURE_WIDTH = 400;
BALL_SIZE = 8;
GRAVITY = -0.5;
BOUNCINESS = 0.9;
COURT_LEVEL = 100;
var
Horizontal_Position: Integer;
Vertical_Position, Velocity: Real;
drawingRect, ovalRect: Rect;
procedure DrawBall (Vertical_Position: Integer);
var
Top, Left, Bottom, Right: Integer;
begin
Top := COURT_LEVEL - Vertical_Position - BALL_SIZE;
Left := Horizontal_Position - BALL_SIZE;
Bottom := COURT_LEVEL - Vertical_Position + BALL_SIZE;
Right := Horizontal_Position + BALL_SIZE;
SetRect(ovalRect, Left, Top, Right, Bottom);
FrameOval(ovalRect);
end;
begin {bouncing ball}
ShowDrawing;
SetRect(drawingRect, 60, 60, 80 + PICTURE_WIDTH, 80 + PICTURE_HEIGHT);
SetDrawingRect(drawingRect);
Horizontal_Position := BALL_SIZE + 1;
Vertical_Position := PICTURE_HEIGHT - BALL_SIZE - 1;
Velocity := 0;
DrawBall(round(Vertical_Position));
repeat
Horizontal_Position := Horizontal_Position + 2;
Velocity := Velocity + GRAVITY;
Vertical_Position := Vertical_Position + Velocity;
if Vertical_Position <= 0 then
begin
Vertical_Position := Abs(Vertical_Position);
Velocity := -(BOUNCINESS * Velocity);
end;
DrawBall(round(Vertical_Position));
until Horizontal_Position >= PICTURE_WIDTH;
end.

113
examples/bezier.pas Normal file
View File

@ -0,0 +1,113 @@
program ExampleBezier;
type
mat = array[1..4, 1..4] of Real;
var
Px, Py, Cx, Cy: mat;
Tv, Mb, x, y: mat;
i, j, k, xx, yy: Integer;
window: rect;
t, dt: Real;
P: point;
procedure matmlt (var d, a, b: mat; n, m: integer);
var
i, j, k: Integer;
sum: Real;
temp: mat;
begin
for i := 1 to n do
begin
for j := 1 to m do
begin
sum := 0.0;
for k := 1 to 4 do
sum := sum + a[i, k] * b[k, j];
temp[i, j] := sum;
end;
end;
for i := 1 to n do
for j := 1 to m do
d[i, j] := temp[i, j];
end;
procedure getPoints;
var
i, x, y: Integer;
begin
SetRect(window, 30, 30, 400, 300);
setDrawingRect(window);
ShowDrawing;
penSize(2, 2);
Moveto(40, 20); {Print heading }
textSize(18);
textFont(2);
writeDraw('Bezier Parametric Cubic Curve');
textSize(12);
ForeColor(409); {Set pen to blue.}
for i := 1 to 4 do
begin
SetRect(window, 90, 30, 255, 50);
eraseRect(window);
Moveto(100, 45);
writeDraw('Please click in point', I : 3);
FrameRect(window);
repeat
getMouse(P)
until button;
repeat
until (not button);
Px[i, 1] := P.h;
Py[i, 1] := P.v;
SetRect(window, (P.h - 2), (P.v - 2), (P.h + 4), (P.v + 4));
PaintOval(window);
end;
end;
procedure set_BezMat;
begin
Mb[1, 1] := -1;
Mb[1, 2] := 3;
Mb[1, 3] := -3;
Mb[1, 4] := 1;
Mb[2, 1] := 3;
Mb[2, 2] := -6;
Mb[2, 3] := 3;
Mb[2, 4] := 0;
Mb[3, 1] := -3;
Mb[3, 2] := 3;
Mb[3, 3] := 0;
Mb[3, 4] := 0;
Mb[4, 1] := 1;
Mb[4, 2] := 0;
Mb[4, 3] := 0;
Mb[4, 4] := 0;
end;
begin
set_BezMat;
getPoints;
matmlt(Cx, Mb, Px, 4, 1);
matmlt(Cy, Mb, Py, 4, 1);
t := -0.01;
xx := round(Px[1, 1]);
yy := round(Py[1, 1]);
Moveto(xx, yy);
ForeColor(137); {Set pen to magenta.}
for i := 1 to 101 do
begin
t := t + 0.01;
Tv[1, 4] := 1;
Tv[1, 3] := t * Tv[1, 4];
Tv[1, 2] := t * Tv[1, 3];
Tv[1, 1] := t * Tv[1, 2];
matmlt(x, Tv, Cx, 1, 1);
matmlt(y, Tv, Cy, 1, 1);
xx := round(x[1, 1]);
yy := round(y[1, 1]);
Lineto(xx, yy);
end;
end.

21
examples/bitwise.pas Normal file
View File

@ -0,0 +1,21 @@
program ExampleBitwise;
var
value, mask: Integer;
begin
ShowText;
Writeln(BAnd(20, 123));
Writeln(Btst(20, 16));
{ compare }
Writeln(Bxor(20, 123));
Writeln(Bor(20, 123));
{bit shift }
Writeln(Bsl(20, 1));
Writeln(Bsr(20, 1));
end.

78
examples/bresenham.pas Normal file
View File

@ -0,0 +1,78 @@
program ExampleBresenham;
{Program to draw a straight }
{ line from (x1,y1) to (x2,y2) }
{using Bresenham's Algorithm }
var
i, irange, xp, yp, dxs, dys: Integer;
x1, y1, x2, y2: Real;
dx, dy, x, y, range: Real;
errp: Real;
axis: char;
procedure point (x, y: integer);
{Procedure to plot point at (x,y)}
begin
Moveto(xp, yp);
Lineto(xp, yp);
end;
begin
{Query the user for two points}
Writeln('Bresenham''s Straight-Line Algorithm');
Writeln('Input point 1 (x1,y1):');
Readln(x1, y1);
Writeln('Input point 2 (x2,y2):');
Readln(x2, y2);
range := abs(x2 - x1);
axis := 'x';
{Test for axis of more rapid motion}
if abs(y2 - y1) > range then
begin
range := abs(y2 - y1);
axis := 'y';
end;
irange := round(range);
dx := (x2 - x1);
dy := (y2 - y1);
errp := 2 * dy - dx;
dxs := 1;
{Test for direction of x motion}
if dx < 0 then
dxs := -1;
dys := 1;
{Test for direction of y motion}
if dy < 0 then
dys := -1;
xp := round(x1);
yp := round(y1);
ShowDrawing;
{This part steps along x axis}
case axis of
'x':
begin
for i := 1 to irange do
begin
point(xp, yp);
if errp > 0 then
begin
yp := yp + dys;
errp := errp - 2 * dx * dxs
end;
xp := xp + dxs;
errp := errp + 2 * dy * dys;
end;
end;
'y': {This part steps along y axis}
begin
for i := 1 to irange do
begin
point(xp, yp);
if errp > 0 then
begin
xp := xp + dxs;
errp := errp - 2 * dy * dys
end;
yp := yp + dys;
errp := errp + 2 * dx * dxs;
end;
end;
end;
end.

86
examples/chaos.pas Normal file
View File

@ -0,0 +1,86 @@
program ExampleEulerStorm;
const
A = -1;
B = 3;
C = -2;
D = 5;
eps = 0.05;
var
ds: real;
function f (x, y: real): real;
begin
f := y - x * x * x / 3
end;
function g (x, y: real): real;
begin
g := -x
end;
procedure segment (x, y: real);
begin
LineTo(round(510 * (x - A) / (B - A)), round(340 * (y - D) / (c - d)))
end;
procedure euler (S: integer; var err: boolean; x0, y0: real; var x1, y1: real);
var
dx, dy, dt: real;
begin
err := false;
dx := f(x0, y0);
dy := g(x0, y0);
if abs(dx) + abs(dy) < eps then
err := true
else
begin
dt := ds / sqrt(dx * dx + dy * dy);
x1 := x0 + S * dt * dx;
y1 := y0 + S * dt * dy
end
end;
procedure trajectory (x, y: real);
var
N, S: integer;
x0, y0, x1, y1: real;
msg: boolean;
begin
for S := 0 to 1 do
begin
x0 := x;
y0 := y;
N := 1;
MoveTo(round(510 * (x - A) / (B - A)), round(340 * (y - D) / (C - D)));
repeat
euler(2 * S - 1, msg, x0, y0, x1, y1);
if not (msg) then
begin
segment(x1, y1);
N := N + 1;
x0 := x1;
y0 := y1
end
until msg or (N > 50) or (x1 < A) or (x1 > B) or (y1 < C) or (y1 > D)
end
end;
procedure DrawPicture;
var
i, j, diviseur: integer;
begin
diviseur := 10;
for j := 2 to 5 do
for i := 1 to diviseur do
trajectory((B + A) / 2 + (B - A) * cos(2 * pi * i / diviseur) / j, (C + D) / 2 + (D - C) * sin(2 * pi * i / diviseur) / j)
end;
begin
ds := (B - A) / 50;
ShowDrawing;
DrawPicture;
end.

39
examples/circle.pas Normal file
View File

@ -0,0 +1,39 @@
program ExampleCircle;
type
Vector2 = record
x, y: real
end;
var
r: Real;
procedure Circle (r: real);
var
theta, thinc: Real;
i: Integer;
pt: Vector2;
begin
theta := 0.0;
thinc := 2 * pi / 100.0;
pt.x := r;
pt.y := 0.0;
Moveto(round(pt.x), round(pt.y));
for i := 1 to 100 do
begin
theta := theta + thinc;
pt.x := r * cos(theta);
pt.y := r * sin(theta);
Lineto(round(pt.x), round(pt.y));
end
end;
begin
Writeln('Radius:');
Readln(r);
ShowDrawing;
Circle(r);
end.

25
examples/circlefill.pas Normal file
View File

@ -0,0 +1,25 @@
program ExampleCircleFill;
procedure Fillcircle (xc, yc, radius: integer);
var
x, y: Integer;
begin
for y := -radius to radius do
begin
for x := -radius to radius do
begin
if (x * x + y * y <= radius * radius) then
begin
Moveto(xc + x, yc + y);
Lineto(xc + x, yc + y);
end;
end;
end;
end;
begin
ShowDrawing;
Fillcircle(60, 60, 40);
end.

25
examples/clone.pas Normal file
View File

@ -0,0 +1,25 @@
program ExampleClone;
const
size = 50;
var
a, b: Rect;
begin
ShowDrawing;
SetRect(a, 0, size, size * 2, size * 3);
PaintArc(a, 0, 90);
SetRect(a, size, size, size * 2, size * 2);
b := a;
OffSetRect(b, size, 0);
CopyBits(thePort^.portBits, thePort^.portBits, a, b, srcCopy, nil);
OffSetRect(b, 0, size);
CopyBits(thePort^.portBits, thePort^.portBits, a, b, srcCopy, nil);
FrameRect(b);
end.

22
examples/console.pas Normal file
View File

@ -0,0 +1,22 @@
program ExampleConsole;
const
message = ' Welcome to the world of Pascal ';
type
name = String;
var
firstname, surname: name;
begin
ShowText;
Writeln('Please enter your first name: ');
Readln(firstname);
Writeln('Please enter your surname: ');
Readln(surname);
Writeln;
Writeln(message, ' ', firstname, ' ', surname);
end.

19
examples/const.pas Normal file
View File

@ -0,0 +1,19 @@
program const_circle (input, output);
const
PI = 3.141592654;
var
r, d, c: Real; {variable declaration: radius, dia, circumference}
begin
ShowText;
Writeln('Enter the radius of the circle');
Readln(r);
d := 2 * r;
c := PI * d;
Writeln('The circumference of the circle is ', c : 7 : 2);
end.

170
examples/cursor.pas Normal file
View File

@ -0,0 +1,170 @@
program Showing_Cursors (input, output);
type
Port = GrafPtr;
Rect_Table = array[1..3] of Rect;
var
Rectangle: Rect_Table;
Window: Port;
J: Integer;
Area: array[1..3] of RgnHandle;
Smile, Frown, Justso: Cursor;
Mousepoint: Point;
procedure Open_Window (var Viewport: Port);
begin
new(Viewport);
OpenPort(Viewport)
end;
procedure Initialize_Rectangles (var Box: Rect_Table);
begin
SetRect(Box[1], 0, 0, 512, 342);
SetRect(Box[2], 40, 40, 250, 250);
SetRect(Box[3], 300, 120, 500, 320);
end;
procedure Dispose_of_Window (var Viewport: Port);
begin
ClosePort(Viewport);
Dispose(Viewport)
end;
procedure Pushbutton;
var
Time: Longint;
begin
while not Button do { nothing }
;
Delay(10, Time);
end;
begin
HideAll;
HideCursor;
{ Initialize the data arrays for the three cursors. }
Smile.data[0] := 1;
Smile.data[1] := -32767;
Smile.data[2] := -32767;
Smile.data[3] := -26599;
Smile.data[4] := -26599;
Smile.data[5] := -32767;
Smile.data[6] := -32767;
Smile.data[7] := -32511;
Smile.data[8] := -31871;
Smile.data[9] := -32511;
Smile.data[10] := -28655;
Smile.data[11] := -30687;
Smile.data[12] := -31679;
Smile.data[13] := -31871;
Smile.data[14] := -32767;
Smile.data[15] := -1;
Smile.hotspot.v := 8;
Smile.hotspot.h := 8;
Frown.data[0] := -1;
Frown.data[1] := -32767;
Frown.data[2] := -32767;
Frown.data[3] := -26599;
Frown.data[4] := -26599;
Frown.data[5] := -32767;
Frown.data[6] := -32767;
Frown.data[7] := -32511;
Frown.data[8] := -31871;
Frown.data[9] := -32511;
Frown.data[10] := -32767;
Frown.data[11] := -31871;
Frown.data[12] := -31679;
Frown.data[13] := -30687;
Frown.data[14] := -32767;
Frown.data[15] := -1;
Frown.hotspot.v := 8;
Frown.hotspot.h := 8;
Justso.data[0] := -1;
Justso.data[1] := -32767;
Justso.data[2] := -32767;
Justso.data[3] := -26599;
Justso.data[4] := -26599;
Justso.data[5] := -32767;
Justso.data[6] := -32767;
Justso.data[7] := -32511;
Justso.data[8] := -31871;
Justso.data[9] := -32511;
Justso.data[10] := -32767;
Justso.data[11] := -32767;
Justso.data[12] := -24591;
Justso.data[13] := -32767;
Justso.data[14] := -32767;
Justso.data[15] := -1;
Justso.hotspot.v := 8;
Justso.hotspot.h := 8;
{ Initialize the three rectangles. }
Initialize_Rectangles(Rectangle);
for J := 1 to 3 do
Area[J] := NewRgn;
Open_Window(Window);
PenSize(2, 2);
{ Establish each of the three regions. }
begin { first region }
OpenRgn;
FrameRect(Rectangle[1]);
CloseRgn(Area[1]);
FillRgn(Area[1], white);
end;
begin { second region }
OpenRgn;
FrameRoundRect(Rectangle[2], 90, 90);
CloseRgn(Area[2]);
FrameRgn(Area[2]);
MoveTo(100, 200);
DrawString('Happy Region');
end;
begin { third region }
OpenRgn;
FrameOval(Rectangle[3]);
CloseRgn(Area[3]);
FrameRgn(Area[3]);
MoveTo(360, 280);
DrawString('Sad Region');
end;
{ Prompt the user to continue. }
MoveTo(266, 50);
Drawstring(' Press mouse button to stop: ');
{ Establish a new cursor, and then obscure the new cursor until }
{ the mouse is moved. }
SetCursor(Justso);
ShowCursor;
ObscureCursor;
while not button do
begin
GetMouse(Mousepoint);
if PtInRgn(Mousepoint, Area[2]) then
SetCursor(Smile)
else if PtinRgn(Mousepoint, Area[3]) then
SetCursor(Frown)
else
SetCursor(Justso);
end;
{ Erase the complete screen with a gray background. }
BackPat(gray);
EraseRgn(Area[1]);
{ Dispose of storage for the window and the areas. }
Dispose_of_Window(Window);
for J := 1 to 3 do
DisposeRgn(Area[J]);
end.

96
examples/date-print.pas Normal file
View File

@ -0,0 +1,96 @@
program ExampleDate;
type
Date = record
Month: string[8];
Dayname: string[9];
Day: 1..31;
Year: Integer;
Time: longint
end;
var
Access_Date: Date;
Temp_Date: DateTimeRec;
function Present_Month (Number: integer): string;
begin
case Number of
1:
Present_Month := 'Jan';
2:
Present_Month := 'Feb';
3:
Present_Month := 'Mar';
4:
Present_Month := 'Apr';
5:
Present_Month := 'May';
6:
Present_Month := 'Jun';
7:
Present_Month := 'Jul';
8:
Present_Month := 'Aug';
9:
Present_Month := 'Sep';
10:
Present_Month := 'Oct';
11:
Present_Month := 'Nov';
12:
Present_Month := 'Dec';
end;
end;
function Present_Dayname (Number: integer): string;
begin
case Number of
1:
Present_Dayname := 'Sun';
2:
Present_Dayname := 'Mon';
3:
Present_Dayname := 'Tue';
4:
Present_Dayname := 'Wed';
5:
Present_Dayname := 'Thu';
6:
Present_Dayname := 'Fri';
7:
Present_Dayname := 'Sat';
end;
end;
procedure Convert_Date (var Out_Date: Date; In_Date: DateTimeRec);
begin
Out_Date.Month := Present_Month(In_Date.Month);
Out_date.Dayname := Present_Dayname(In_Date.DayOfWeek);
Out_date.Day := In_date.Day;
Out_Date.Year := In_Date.Year;
Out_Date.Time := In_Date.Hour * 10000 + In_Date.Minute * 100 + In_Date.Second;
end;
procedure Report_Date_Time (In_Date: Date);
var
Hour, Minute, Second: Integer;
begin
{ date }
Write(In_Date.dayname, ', ', In_Date.Month);
Writeln(In_Date.Day : 3, ', ', In_Date.Year : 4);
{ time }
Hour := 12 + In_Date.Time div 10000;
Minute := (In_Date.Time - Hour * 10000) div 100;
Second := In_Date.Time - (Hour * 10000 + Minute * 100);
Writeln(hour : 2, ':', Minute : 2, ':', Second : 2);
end;
begin
showText;
GetTime(Temp_Date);
Convert_Date(Access_Date, Temp_Date);
Report_Date_Time(Access_Date);
end.

13
examples/date.pas Normal file
View File

@ -0,0 +1,13 @@
program ExampleDate;
var
date: DateTimeRec;
begin
ShowText;
GetTime(date);
Writeln('The current date is:');
Writeln(date.year : 4, '-', date.month : 2, '-', date.day : 2);
end.

49
examples/draw-mirror.pas Normal file
View File

@ -0,0 +1,49 @@
program ExampleDraw;
const
radius = 10;
var
cursor, prev: Point;
isDown: Boolean;
procedure WhenDownChanged;
begin
MoveTo(prev.h, prev.v);
LineTo(cursor.h, cursor.v);
MoveTo(300 - prev.h, prev.v);
LineTo(300 - cursor.h, cursor.v);
GetMouse(prev);
end;
procedure WhenDown;
begin
GetMouse(cursor);
if cursor.h <> prev.h then
if cursor.v <> prev.v then
WhenDownChanged;
end;
procedure MainLoop;
begin
repeat {Until we click outside screen}
while button do
begin
GetMouse(cursor);
GetMouse(prev);
MoveTo(cursor.h, cursor.v);
LineTo(prev.h, prev.v);
repeat {Tight loop until button up}
WhenDown;
until not Button;
end;
until cursor.h > 300;
end;
begin
ShowDrawing;
Writeln('Started');
MainLoop;
Writeln('stopped');
end.

45
examples/draw.pas Normal file
View File

@ -0,0 +1,45 @@
program ExampleDraw;
var
cursor, prev: Point;
isDown: Boolean;
procedure WhenDownChanged;
begin
MoveTo(prev.h, prev.v);
LineTo(cursor.h, cursor.v);
GetMouse(prev);
end;
procedure WhenDown;
begin
GetMouse(cursor);
if cursor.h <> prev.h then
if cursor.v <> prev.v then
WhenDownChanged;
end;
procedure MainLoop;
begin
repeat {Until we click outside screen}
while button do
begin
GetMouse(cursor);
GetMouse(prev);
MoveTo(cursor.h, cursor.v);
LineTo(prev.h, prev.v);
repeat {Tight loop until button up}
WhenDown;
until not Button;
end;
until cursor.h < 0;
end;
begin
ShowDrawing;
Writeln('Started');
MainLoop;
Writeln('stopped');
end.

32
examples/euler.pas Normal file
View File

@ -0,0 +1,32 @@
program EulerSpiral;
const
l = 4;
a = 11;
var
wx, wy, wa: Real;
i: Integer;
procedure DrawAngle;
var
t: Real;
begin
MoveTo(round(wx), round(wy));
t := wa * PI / 180;
wx := wx + l * cos(t);
wy := wy + l * sin(t);
wa := wa + (i * a);
LineTo(round(wx), round(wy));
end;
begin
wx := 100;
wy := 300;
i := 0;
ShowDrawing;
repeat
DrawAngle;
i := i + 1;
until i > 20000;
end.

53
examples/events.pas Normal file
View File

@ -0,0 +1,53 @@
program ExampleEvents;
{Program to demonstrate detection of button events }
{and use of button for program control. }
var
tic1, tic2: Longint;
begin
{Open Drawing Window and label screen.}
ShowDrawing;
MoveTo(20, 20);
TextSize(18);
WriteDraw('Button Event Test');
MoveTo(35, 40);
TextSize(12);
WriteDraw('Double-Click to QUIT');
MoveTo(40, 70);
WriteDraw('Now the Button is: ');
{Use XOR pattern to erase and rewrite output}
TextMode(srcXor);
MoveTo(80, 100);
TextSize(24);
TextFace([bold]);
repeat {Until we double-click}
while button do {Button down message detector}
begin
WriteDraw('down');
MoveTo(80, 100);
repeat {Tight loop until button up}
until not Button;
WriteDraw('down'); {Erase "down" text}
MoveTo(80, 100);
tic1 := TickCount; {Sample system clock: }
end; {1/60 sec ticks}
while not button do { Button up message detector}
begin
WriteDraw('up');
MoveTo(80, 100);
repeat {Tight loop until button down}
until button;
WriteDraw('up'); {Erase "up" text}
MoveTo(80, 100);
tic2 := TickCount; {Sample system clock}
end;
until abs(tic2 - tic1) < 30; {Double click message detector}
end.

24
examples/file.bin.pas Normal file
View File

@ -0,0 +1,24 @@
program ExampleFileBinary;
type
Number_File = file of real;
var
Data_Block: Number_File;
Counter: integer;
A: array[1..10] of real;
begin
for Counter := 1 to 10 do
A[Counter] := random;
Open(Data_Block, 'data');
Rewrite(Data_Block);
for Counter := 1 to 10 do
Write(Data_Block, A[Counter]);
Close(Data_Block);
end.

28
examples/file.get.pas Normal file
View File

@ -0,0 +1,28 @@
program ExampleFileBinary;
var
globalRef: Integer;
procedure GetFile;
var
where: point;
prompt: Str255;
origName: Str255;
err: OSErr;
theReply: SFReply;
myEOF: longint;
begin
setpt(where, 0, 0);
prompt := 'Get resource File from';
origName := 'unknownFile';
SFGetFile(where, prompt, nil, -1, nil, nil, theReply);
err := FSOpen(theReply.fname, theReply.vRefNum, globalRef);
err := GetEOF(globalRef, myEOF);
err := FSClose(globalRef);
end;
begin
GetFile;
end.

24
examples/file.read.pas Normal file
View File

@ -0,0 +1,24 @@
program ExampleFileRead;
procedure ReadFile;
var
i: Integer;
data: string;
infile: Text;
begin
i := 0;
Open(infile, OldFileName('Open txt file?'));
repeat
i := i + 1;
Readln(infile, data);
Writeln(data);
until eof(infile);
Reset(infile);
end;
begin
ShowText;
ReadFile;
end.

19
examples/file.write.pas Normal file
View File

@ -0,0 +1,19 @@
program ExampleFile;
const
FILENAME = 'data.txt';
var
outfile: Text;
begin
ShowText;
ReWrite(outfile, FILENAME);
Writeln(outfile, 'hello world');
Writeln(outfile, 'foo bar');
Writeln('Writing ', FILENAME, ' complete.');
end.

35
examples/fontface.pas Normal file
View File

@ -0,0 +1,35 @@
program ExampleFontface;
begin
ShowDrawing;
MoveTo(70, 40);
DrawString('Text');
TextFace([bold]);
MoveTo(70, 55);
DraWString('Bold');
TextFace([Italic]);
MoveTo(70, 70);
Drawstring('Italic');
TextFace([underline]);
MoveTo(70, 85);
DrawString('Underline');
TextFace([outline]);
MoveTo(70, 100);
DrawString('Outline');
MoveTo(70, 100);
TextFace([Shadow]);
MoveTo(70, 115);
Drawstring('Shadow');
{restore to normal }
TextFace([]);
end.

14
examples/forloop.pas Normal file
View File

@ -0,0 +1,14 @@
program ExampleLoop;
var
a: Integer;
begin
ShowText;
for a := 10 to 20 do
begin
Writeln('value of a: ', a);
end;
end.

51
examples/fractal.pas Normal file
View File

@ -0,0 +1,51 @@
program ExampleFractal;
{ Program to play the Chaos Game }
{ Algorithm: }
{ 1. Pick a point in a triangle at random & plot it }
{ 2. Pick a vertex of the triangle at random }
{ 3. Move 1/2 way from present point to this vertex }
{ 4. Plot point and loop from (2) until mouse pressed.}
var
xp, yp, i: integer;
x, y: array[1..3] of real;
function Rndint (n: integer): integer;
{Function to return random integer on range 1 --> n}
var
rr: longint;
r: real;
begin
rr := random; {Intrinsic routine}
r := (rr + 32767) / (32767 + 32768);
Rndint := trunc(n * r) + 1;
end;
begin
ShowDrawing;
{Set corners of triangle centered at (110,125),}
{with sides 200 pixels long}
x[1] := 110 - 100;
y[1] := 125 + 57.73503;
x[2] := 110;
y[2] := 125 - 115.470;
x[3] := 110 + 100;
y[3] := y[1];
{Pick first point at random in box containing triangle}
xp := Rndint(200) + 10;
yp := Rndint(173) + 10;
DrawLine(xp, yp, xp, yp); {Plot point}
repeat {until Mouse button is pressed}
i := Rndint(3); {Pick random corner}
xp := round((x[i] - xp) / 2 + xp); {Go half way}
yp := round((y[i] - yp) / 2 + yp); {Go half way}
DrawLine(xp, yp, xp, yp); {Plot point}
until button;
end.

13
examples/function.pas Normal file
View File

@ -0,0 +1,13 @@
program ExampleFunction;
function Add (a, b: integer): Integer;
begin
Add := a + b;
end;
begin
ShowText;
Writeln('5+6=', Add(5, 6));
end.

40
examples/gui0.pas Normal file
View File

@ -0,0 +1,40 @@
program ExampleGui0;
var
w: WindowPtr; {A window to draw in}
r: Rect; {The bounding box of the window}
{>>}
procedure MainLoop;
begin
repeat
until button;
end;
begin
{Create the window}
SetRect(r, 50, 50, 300, 100);
w := NewWindow(nil, r, '', true, zoomDocProc, WindowPtr(-1), false, 0);
{Make it the current drawing port}
SetPort(w);
{Draw a string!}
MoveTo(20, 20);
DrawString('Hello world!');
{Wait for a mouse-click, then stop.}
MainLoop;
end.
{ window types }
{ documentProc: movable, sizable window, no zoom box }
{ dBoxProc: alert box or modal dialog box }
{ plainDBox: plain box }
{ altDBoxProc: plain box with shadow }
{ noGrowDocProc: movable window, no size box or zoom box }
{ movableDBoxProc: movable modal dialog box }
{ zoomDocProc: standard document window }
{ zoomNoGrow: zoomable, nonresizable window }

28
examples/gui1.pas Normal file
View File

@ -0,0 +1,28 @@
program ExampleGui1;
var
w: WindowPtr; {A window to draw in}
r: Rect; {The bounding box of the window}
procedure WindowInit;
begin
SetRect(r, 50, 50, 300, 100);
w := NewWindow(nil, r, '', true, zoomDocProc, WindowPtr(-1), false, 0);
SetPort(w);
end;
procedure MainLoop;
begin
TextSize(24);
MoveTo(20, 20);
DrawString('Hello world!');
repeat
until button;
end;
begin
WindowInit;
MainLoop;
end.

59
examples/gui2.pas Normal file
View File

@ -0,0 +1,59 @@
program ExampleGui2;
const
everyEvent = 8; { Exit on key}
var
w: WindowPtr; {A window to draw in}
r: Rect; {A window Size}
gTheEvent: EventRecord;
gDone: BOOLEAN;
procedure WindowInit;
begin
SetRect(r, 50, 50, 300, 100);
w := NewWindow(nil, r, '', true, zoomDocProc, WindowPtr(-1), false, 0);
SetPort(w);
end;
procedure HandleEvent;
var
gotOne: BOOLEAN;
begin
SystemTask;
gotOne := GetNextEvent(everyEvent, gTheEvent);
if gotOne then
begin
gDone := TRUE;
end;
end;
procedure MainLoop;
begin
gDone := FALSE;
while gDone = FALSE do
HandleEvent;
end;
begin
WindowInit;
MainLoop;
end.
{ mDownMask 2 }
{ mUpMask 4 }
{ keyDownMask 8 }
{ keyUpMask 16 }
{ autoKeyMask 32 }
{ updateMask 64 }
{ diskMask 128 }
{ activMask 256 }
{ networkMask 1024 }
{ driverMask 2048 }
{ app1 Mask4096 }
{ app2Mask 8192 }
{ app3Mask 16384 }
{ app4Mask =32768 }
{ everyEvent =1 }

88
examples/ifs.pas Normal file
View File

@ -0,0 +1,88 @@
program ExampleIFS;
const
pixdim = 120;
type
pic = array[1..pixdim, 1..pixdim] of Boolean;
vec = array[1..4] of Real;
dimvec = array[1..4] of Integer;
var
s, t: pic;
a, b, c, d, e, f, p: vec;
x, y: dimvec;
i, j, k, dpix: Integer;
box: rect;
procedure pset (x, y: integer);
begin
Moveto(x, y);
Lineto(x, y);
end;
procedure DefineObject (var t: pic);
var
i, j: Integer;
begin
for i := 1 to pixdim do
for j := 1 to pixdim do
if j < i then
begin
t[i, j] := true;
pset(i, j);
end;
SetRect(box, 1, 1, pixdim, pixdim);
end;
procedure SetCoef (var a, b, c, d, e, f: vec);
var
i: Integer;
begin
for i := 1 to 3 do
begin
a[i] := 0.5;
b[i] := 0;
c[i] := 0;
d[i] := 0.5;
e[i] := pixdim / 2;
f[i] := 1;
end;
e[1] := 1;
f[3] := pixdim / 2;
end;
begin
ShowDrawing;
DefineObject(t);
SetCoef(a, b, c, d, e, f);
dpix := pixdim div 2;
repeat
for i := 1 to pixdim do
for j := 1 to pixdim do
if t[i, j] then
begin
for k := 1 to 3 do
begin
x[k] := trunc(a[k] * i + b[k] * j + e[k]);
y[k] := trunc(c[k] * i + d[k] * j + f[k]);
s[x[k], y[k]] := true;
end;
end;
EraseRect(box);
for i := 1 to pixdim do
for j := 1 to pixdim do
begin
t[i, j] := s[i, j];
s[i, j] := false;
if t[i, j] then
pset(i, j);
end;
dpix := dpix div 2;
WriteLn('dpix = ', dpix);
until button or (dpix < 1)
end.

63
examples/julia.pas Normal file
View File

@ -0,0 +1,63 @@
program ExampleJulia;
{Program to compute and plot Julia set.}
const
scale = 0.01;
R = 10;
type
complex = record
r: Real;
i: real
end;
var
i, j, k, n, row, col, Nit: Integer;
x, y: Real;
z, znew, c: complex;
done, gone: Boolean;
procedure prod (a, b: complex; var c: complex);
{Does complex multiplication: c = a bullet b}
begin
c.r := a.r * b.r - a.i * b.i;
c.i := a.r * b.i + a.i * b.r;
end;
procedure add (a, b: complex; var c: complex);
{Does complex addition: c = a + b}
begin
c.r := a.r + b.r;
c.i := a.i + b.i;
end;
procedure plot (c, r: integer);
{Procedure to pixel (c.r).}
begin
Moveto(c, r);
Lineto(c, r);
end;
begin
ShowText;
writeLn('How many iterations at each point?');
readLn(Nit);
writeLn('Value of C: (Cr,Ci)?');
ReadLn(c.r, c.i);
showdrawing;
ForeColor(blackColor);
n := 0;
for col := 1 to 400 do
for row := 1 to 400 do
begin
z.r := (col - 200) * scale;
z.i := (row - 200) * scale;
repeat
prod(z, z, znew);
add(znew, c, z);
gone := (z.r * z.r + z.i * z.i > R);
n := n + 1;
done := (n > Nit);
until done or gone or button;
if done then
plot(col, row);
n := 0;
end;
end.

15
examples/keyboard.pas Normal file
View File

@ -0,0 +1,15 @@
program ExampleKeyboard;
var
Key: char;
begin
ShowText;
repeat
Write('Press a key. ');
Readln(Key);
Writeln('The ordinal value of this key is ', ord(Key), '.');
until ord(Key) = 22;
end.

33
examples/line.pas Normal file
View File

@ -0,0 +1,33 @@
program ExampleLines;
begin
ShowDrawing;
MoveTo(100, 70);
WriteDraw('A');
MoveTo(140, 110);
WriteDraw('B');
MoveTo(125, 140);
WriteDraw('C');
MoveTo(60, 140);
WriteDraw('D');
MoveTo(90, 110);
WriteDraw('E');
{Draw a line from point A to point B.}
DrawLine(100, 70, 140, 110);
{Draw a line from point B to point C.}
LineTo(125, 140);
{Draw a line from point c to point D.}
LineTo(65, 140);
{Draw a line from point D to point E.}
LineTo(90, 110);
{Draw a line from point E to point B.}
LineTo(140, 110);
{Finish drawing the remaining lines.}
DrawLine(100, 70, 125, 140);
DrawLine(100, 70, 65, 140);
DrawLine(100, 70, 90, 110);
end.

19
examples/logic.pas Normal file
View File

@ -0,0 +1,19 @@
program ExampleLogic;
{Comment}
var
name: String;
begin
ShowText;
name := 'alice';
if (name = 'alice') then
Writeln('The name is alice.')
else if (name = 'bob') then
Writeln('The name is bob.')
else
Writeln('The name is not alice nor bob.');
end.

26
examples/logo.pas Normal file
View File

@ -0,0 +1,26 @@
program Rabbits;
procedure Draw (row, col, size, pad: integer);
var
bounds: Rect;
begin
SetRect(bounds, col * size + pad, row * size + pad, (col * size + pad) + 8, (row * size + pad) + 8);
PaintOval(bounds);
end;
var
row, col: Integer;
begin
ShowDrawing;
repeat
col := 0;
repeat
Draw(row, col, 10, 60);
col := col + 1;
until col = 10;
row := row + 1;
until row = 10;
end.

99
examples/mandelbrot.pas Normal file
View File

@ -0,0 +1,99 @@
program ExampleMandelbrot;
const
Nit = 100;
scale = 0.005;
R = 10;
type
complex = record
r: Real;
i: real
end;
var
i, j, k, n, row, col: Integer;
x, y: Real;
z, znew, c: complex;
done, gone: Boolean;
render: Rect;
procedure prod (a, b: complex; var c: complex);
{Does complex multiplication: c = a bullet b}
begin
c.r := a.r * b.r - a.i * b.i;
c.i := a.r * b.i + a.i * b.r;
end;
procedure sub (a, b: complex; var c: complex);
{Does complex subtraction: c = a - b}
begin
c.r := a.r - b.r;
c.i := a.i - b.i;
end;
procedure plot (c, r, n: integer);
{Procedure to pixel (c.r) in color code n.}
begin
case n of
0..4:
ForeColor(blueColor);
5:
ForeColor(cyanColor);
6:
ForeColor(greenColor);
7:
ForeColor(magentaColor);
8..11:
ForeColor(redColor);
12..20:
ForeColor(yellowColor);
21..99:
ForeColor(whiteColor);
100:
ForeColor(blackColor);
otherwise
ForeColor(blackColor);
end;
Moveto(c, r);
Lineto(c, r);
r := 400 - r;
Moveto(c, r);
Lineto(c, r);
end;
begin
SetRect(render, 60, 60, 500, 440);
SetDrawingRect(render);
ShowDrawing;
for col := 1 to 400 do
for row := 1 to 200 do
begin
z.r := 0.0;
z.i := 0.0;
c.r := (col - 100) * scale;
c.i := (200 - row) * scale;
repeat
n := n + 1;
prod(z, z, znew);
sub(znew, c, z);
done := (n > Nit);
gone := (z.r * z.r + z.i * z.i > R);
until done or gone or button;
plot(col, row, n);
n := 0;
end;
end.

35
examples/mouse.pas Normal file
View File

@ -0,0 +1,35 @@
program ExampleMouse;
var
Pt: Point;
begin
ShowDrawing;
ShowText;
repeat {Until we double-click}
GetMouse(Pt);
{Button down message detector}
while button do
begin
Writeln('down', Pt.h, Pt.v);
repeat {Tight loop until button up}
until not Button;
end;
{ Button up message detector}
while not button do
begin
Writeln('up', Pt.h, Pt.v);
repeat {Tight loop until button down}
until button;
end;
until 1 > 1; { forever}
end.

26
examples/patterns.pas Normal file
View File

@ -0,0 +1,26 @@
program ExamplePatterns;
var
rblack, rdkgray, rgray, rltgray, rwhite: Rect;
begin
ShowDrawing;
SetRect(rblack, 10 + (50 * 0), 10, 10 + (50 * 1), 50);
SetRect(rdkgray, 10 + (50 * 1), 10, 10 + (50 * 2), 50);
SetRect(rgray, 10 + (50 * 2), 10, 10 + (50 * 3), 50);
SetRect(rltgray, 10 + (50 * 3), 10, 10 + (50 * 4), 50);
SetRect(rwhite, 10 + (50 * 4), 10, 10 + (50 * 5), 50);
FillRect(rblack, black);
FillRect(rdkgray, dkgray);
FillRect(rgray, gray);
FillRect(rltgray, ltgray);
FillRect(rwhite, white);
FrameRect(rblack);
FrameRect(rdkgray);
FrameRect(rgray);
FrameRect(rltgray);
FrameRect(rwhite);
end.

25
examples/pen.pas Normal file
View File

@ -0,0 +1,25 @@
program ExamplePen;
var
x, y: Integer;
Pt: Point;
begin
ShowDrawing;
PenSize(10, 1);
while true do
begin
repeat
until Button;
GetMouse(Pt);
MoveTo(Pt.h, Pt.v);
while Button do
begin
GetMouse(Pt);
LineTo(Pt.h, Pt.v);
end
end
end.

47
examples/picker.pas Normal file
View File

@ -0,0 +1,47 @@
program ExamplePicker;
var
Pt: Point;
procedure PaintPatterns;
var
selection: Rect;
begin
SetRect(selection, 10 + (50 * 0), 10, 10 + (50 * 1), 50);
FillRect(selection, black);
FrameRect(selection);
SetRect(selection, 10 + (50 * 1), 10, 10 + (50 * 2), 50);
FillRect(selection, dkgray);
FrameRect(selection);
SetRect(selection, 10 + (50 * 2), 10, 10 + (50 * 3), 50);
FillRect(selection, gray);
FrameRect(selection);
SetRect(selection, 10 + (50 * 3), 10, 10 + (50 * 4), 50);
FillRect(selection, ltgray);
FrameRect(selection);
SetRect(selection, 10 + (50 * 4), 10, 10 + (50 * 5), 50);
FillRect(selection, white);
FrameRect(selection);
end;
procedure MainLoop;
begin
repeat {Until we double-click}
GetMouse(Pt);
while button do
begin
Writeln('pixel:', Pt.h : 4, ',', Pt.v : 4, '=', GetPixel(pt.h, pt.v));
repeat {Tight loop until button up}
until not Button;
end;
until 1 > 1; { forever}
end;
begin
ShowText;
ShowDrawing;
PaintPatterns;
MainLoop;
end.

85
examples/pict.dialog.pas Normal file
View File

@ -0,0 +1,85 @@
program ExampleDrawingExport;
var
pic: PicHandle;
err: OSErr;
outputRefNum: Integer;
procedure Cleanup;
begin
if outputRefNum <> -1 then
begin
err := FSClose(outputRefNum);
outputRefNum := -1;
end;
end;
procedure CheckError;
begin
if err = noErr then
Exit(CheckError);
ShowText;
WriteLn('Error:', err);
Cleanup;
Halt;
end;
procedure PaintPicture;
var
clip, oval: rect;
begin
ShowDrawing;
SetRect(clip, 0, 0, 100, 100);
SetRect(oval, 20, 20, 80, 80);
pic := OpenPicture(clip);
FillOval(oval, ltgray);
ClosePicture;
DrawPicture(pic, clip);
end;
procedure WriteFile;
var
toWrite, bigZero: Longint;
i: integer;
begin
bigZero := 0;
toWrite := SizeOf(Longint);
for i := 1 to 512 div SizeOf(Longint) do
err := FSWrite(outputRefNum, toWrite, @bigZero);
CheckError;
toWrite := GetHandleSize(Handle(pic));
HLock(Handle(pic));
err := FSWrite(outputRefNum, toWrite, Pointer(pic^));
HUnlock(Handle(pic));
CheckError;
Cleanup;
CheckError;
KillPicture(pic);
pic := nil;
end;
procedure CreateFile;
var
wher: Point; { where to display dialog }
reply: SFReply;
begin
wher.h := 20;
wher.v := 20;
SFPutFile(wher, 'Save the PICT as:', 'untitled.pict', nil, reply);
if reply.good then
begin
err := Create(reply.fname, reply.vrefnum, '????', 'PICT');
if (err = noerr) | (err = dupfnerr) then
begin
err := FSOpen(reply.fname, reply.vrefnum, outputRefNum);
WriteFile;
end;
end;
end;
begin
PaintPicture;
CreateFile;
end.

69
examples/pict.export.pas Normal file
View File

@ -0,0 +1,69 @@
program ExampleDrawingExport;
var
oval, clip: Rect;
pic: PicHandle;
err: OSErr;
refNum, i: Integer;
toWrite, bigZero: Longint;
procedure Cleanup;
begin
if refNum <> -1 then
begin
err := FSClose(refNum);
refNum := -1;
end;
end;
procedure CheckError;
begin
if err = noErr then
Exit(CheckError);
ShowText;
WriteLn('Error:', err);
Cleanup;
Halt;
end;
procedure PaintPicture;
begin
ShowDrawing;
SetRect(oval, 20, 20, 80, 80);
pic := OpenPicture(clip);
FillOval(oval, black);
ClosePicture;
DrawPicture(pic, clip);
end;
begin
refNum := -1;
bigZero := 0;
SetRect(clip, 0, 0, 100, 100);
PaintPicture;
err := Create('export', 0, 'RS$$', 'PICT');
CheckError;
err := FSOpen('export', 0, refNum);
CheckError;
toWrite := SizeOf(Longint);
for i := 1 to 512 div SizeOf(Longint) do
err := FSWrite(refNum, toWrite, @bigZero);
CheckError;
toWrite := GetHandleSize(Handle(pic));
HLock(Handle(pic));
err := FSWrite(refNum, toWrite, Pointer(pic^));
HUnlock(Handle(pic));
CheckError;
Cleanup;
CheckError;
KillPicture(pic);
pic := nil;
end.

67
examples/pict.open.pas Normal file
View File

@ -0,0 +1,67 @@
program readPICT;
{the following variable must be at the top level}
var
globalRef: INTEGER; {refNum of the file to read from}
err: OSErr;
{the following procedure must be at the top level}
procedure GetPICTData (dataPtr: Ptr; byteCount: INTEGER);
var
err: OSErr;
longCount: LONGINT;
begin
longCount := byteCount;
err := FSRead(globalRef, longCount, dataPtr);
{can't check for an error because we don't know how to handle it}
end;
const
abortPICT = 128; {error code if DrawPicture aborted}
procedure GetDrawPICTFile; {read in a PICT FILE selected by the user}
var
wher: Point; {where to display dialog}
reply: SFReply; {reply record}
myFileTypes: SFTypeList; {more Standard FILE goodies}
numFileTypes: INTEGER;
savedProcs: QDProcsPtr;
myProcs: QDProcs; {use CQDProcs for a color window}
myPicture: PicHandle; {we need a picture handle for DrawPicture}
longCount: LONGINT;
myEOF: LONGINT;
myFilePos: longint;
begin
myFilePos := 0;
wher.h := 20;
wher.v := 20;
numFileTypes := 1; {display PICT files}
myFileTypes[0] := 'PICT';
SFGetFile(wher, '', nil, numFileTypes, nil, nil, reply);
if reply.good then
begin
SetStdProcs(myProcs); {use SetStdCProcs for a CGrafPort}
myProcs.getPicProc := @GetPICTData;
savedProcs := thePort^.grafProcs; {set the grafProcs to ours}
thePort^.grafProcs := @myProcs;
myPicture := PicHandle(NewHandle(SizeOf(myPicture)));
err := FSOpen(reply.fname, reply.vRefNum, globalRef);
err := GetEOF(globalRef, myEOF); {get EOF for later check}
err := SetFPos(globalRef, fsFromStart, 512); {skip header}
longCount := SizeOf(myPicture);
err := FSRead(globalRef, longCount, Ptr(myPicture^));
DrawPicture(myPicture, myPicture^^.picFrame); {draw the picture}
err := GetFPos(globalRef, myFilePos); {get position for check}
err := FSClose(globalRef);
DisposHandle(Handle(myPicture));
thePort^.grafProcs := savedProcs; {restore the procs}
if myFilePos <> myEOF then
err := abortPICT;
end;
end;
begin
end.

49
examples/pict.resource.pas Normal file
View File

@ -0,0 +1,49 @@
program ExamplePict;
const
BASE_RES_ID = 400;
var
gPictureWindow: WindowPtr;
gPictureWindowRect: Rect;
procedure CenterPict (thePicture: PicHandle; var myRect: Rect);
var
windRect, pictureRect: Rect;
begin
windRect := myRect;
pictureRect := thePicture^^.picFrame;
myRect.top := (windRect.bottom - windRect.top - (pictureRect.bottom - pictureRect.top)) div 2 + windRect.top;
myRect.bottom := myRect.top + (pictureRect.bottom - pictureRect.top);
myRect.left := (windRect.right - windRect.left - (pictureRect.right - pictureRect.left)) div 2 + windRect.left;
myRect.right := myRect.left + (pictureRect.right - pictureRect.left);
end;
procedure DrawMyPicture (pictureWindow: WindowPtr);
var
myRect: Rect;
thePicture: PicHandle;
begin
myRect := pictureWindow^.portRect;
thePicture := GetPicture(BASE_RES_ID);
CenterPict(thePicture, myRect);
DrawPicture(thePicture, myRect);
end;
procedure WindowInit;
begin
SetRect(gPictureWindowRect, 150, 50, 300, 360);
gPictureWindow := NewWindow(nil, gPictureWindowRect, 'Show Picture', true, zoomDocProc, WindowPtr(-1), false, 0);
SetPort(gPictureWindow);
end;
begin
WindowInit;
DrawMyPicture(gPictureWindow);
while (not Button) do
begin
end;
end.
{ note: You must create a PICT asset with 400 in ResEdit, and add the Resource to Run Options. }

88
examples/pict.spool.pas Normal file
View File

@ -0,0 +1,88 @@
program ExampleDrawingExport;
var
oval, clipin, clipout: Rect;
output: PicHandle;
var
PICTcount: LONGINT;
globalRef: INTEGER;
newPICThand: PicHandle;
procedure PutPICTData (dataPtr: Ptr; byteCount: INTEGER);
var
longCount: LONGINT;
err: INTEGER;
begin
longCount := byteCount;
PICTCount := PICTCount + byteCount;
err := FSWrite(globalRef, longCount, dataPtr);
if newPICTHand <> nil then
newPICTHand^^.picSize := PICTCount;
end;
procedure SpoolOutPICTFile (PICTHand: PicHandle );
var
err: OSErr;
i: INTEGER;
wher: Point; { where to display dialog }
reply: SFReply;
longCount, Zero: LONGINT;
pframe: Rect;
myProcs: QDProcs;
begin
wher.h := 20;
wher.v := 20;
SFPutFile(wher, 'Save the PICT as:', 'untitled', nil, reply);
if reply.good then
begin
err := Create(reply.fname, reply.vrefnum, '????', 'PICT');
if (err = noerr) | (err = dupfnerr) then
begin
err := FSOpen(reply.fname, reply.vrefnum, globalRef);
SetStdProcs(myProcs); {use SetStdCProcs for a CGrafPort}
thePort^.grafProcs := @myProcs;
myProcs.putPicProc := @putPICTdata;
Zero := 0;
longCount := 2;
PICTCount := SizeOf(Picture);
{now write out the 512 byte header}
for i := 1 to (512 + SizeOf(Picture)) div longCount do
err := FSWrite(globalRef, longCount, @Zero);
pFrame := PICThand^^.picFrame;
newPICTHand := nil;
newPICTHand := OpenPicture(pFrame);
DrawPicture(PICTHand, pFrame);
ClosePicture;
err := SetFPos(globalRef, fsFromStart, 512);
{skip the MacDraw header}
longCount := SizeOf(Picture);
{write out the correct (low word of the) size and the frame at the beginning}
err := FSWrite(globalRef, longCount, Ptr(newPICTHand^));
err := FSClose(globalRef);
thePort^.grafProcs := nil;
KillPicture(newPICTHand);
end
else
err := err;
end; {IF reply.good}
end; {OutPICT}
begin
ShowDrawing;
SetRect(clipin, 0, 0, 100, 100);
SetRect(clipout, 0, 0, 100, 100);
SetRect(oval, 20, 20, 180, 180);
output := OpenPicture(clipin);
PenPat(black);
PaintOval(oval);
ClosePicture;
DrawPicture(output, clipout);
SpoolOutPICTFile(output);
end.

42
examples/polygon.pas Normal file
View File

@ -0,0 +1,42 @@
program ExamplePolygon;
var
myPoly: PolyHandle;
myPattern: Pattern;
begin
ShowDrawing;
myPoly := OpenPoly;
MoveTo(30, 90);
LineTo(30, 80);
LineTo(50, 65);
LineTo(90, 65);
LineTo(80, 80);
LineTo(95, 90);
LineTo(30, 90);
ClosePoly;
FramePoly(myPoly);
OffsetPoly(myPoly, 25, 15);
PenSize(3, 2);
ErasePoly(myPoly);
FramePoly(myPoly);
OffsetPoly(myPoly, 25, 15);
PaintPoly(myPoly);
OffsetPoly(myPoly, 25, 15);
PaintPoly(myPoly);
PenNormal;
FillPoly(myPoly, gray);
OffsetPoly(myPoly, 25, 15);
FillPoly(myPoly, myPattern);
FramePoly(myPoly);
KillPoly(myPoly);
end.

41
examples/primitives.pas Normal file
View File

@ -0,0 +1,41 @@
program ExamplePrimitives;
{Program to demonstrate Pascal point & line primitives.}
begin
ShowDrawing; {Opens Drawing Window}
{First draw three points by three different functions}
PenSize(1, 1); {Sets pen size to 1 x 1 pixels}
DrawLine(50, 50, 50, 50);
WriteDraw(' Point at (50,50) using DrawLine');
PenSize(2, 2);
MoveTo(100, 75); {Absolute move}
LineTo(100, 75);
WriteDraw(' Point at (100,75) using LineTo');
PenSize(3, 3);
MoveTo(150, 100); {Absolute move}
Line(0, 0);
WriteDraw(' Point at (150,100) using Line');
{Now Draw three lines by three different functions}
MoveTo(150, 175); {Absolute move}
WriteDraw('Line drawn with DrawLine');
DrawLine(150, 125, 50, 225);
PenSize(2, 2);
Move(0, 25); {Relative move}
LineTo(150, 250);
WriteDraw('Line drawn by LineTo');
Pensize(1, 1);
Move(0, 25); {Relative move}
Line(-100, 50);
WriteDraw('Line drawn by Line');
end.

18
examples/procedure.pas Normal file
View File

@ -0,0 +1,18 @@
program ExampleProcedure;
procedure Tri (x, y, side: integer);
begin
MoveTo(x, y);
LineTo(x + side, y);
LineTo(x + side div 2, Round(y + Side / Sqrt(2)));
LineTo(x, y);
end;
begin
ShowDrawing;
Tri(10, 10, 100);
Tri(40, 40, 80);
Tri(80, 85, 180);
end.

22
examples/random.pas Normal file
View File

@ -0,0 +1,22 @@
program ExampleRandom;
var
x, ps, start1, start2, endpt1, endpt2: Integer;
begin
ShowDrawing;
for x := 1 to 20 do
begin
ps := Random mod 10;
start1 := Random mod 200;
start2 := Random mod 200;
endpt1 := Random mod 200;
endpt2 := Random mod 200;
PenSize(ps, ps);
Moveto(start1 + 200, start2 + 100);
Lineto(endpt1 + 200, endpt2 + 100);
end
end.

23
examples/recurse.pas Normal file
View File

@ -0,0 +1,23 @@
program ExampleRecurse;
var
i, left, top, right, bottom: Integer;
box: rect;
begin
ShowDrawing;
PenSize(9, 9);
PenMode(patXor);
for i := 1 to 50 do
begin
left := 110 - 1 * i;
top := 110 - 10 * i;
right := 120 + 10 * i;
bottom := 115 + 10 * i;
SetRect(box, left, top, right, bottom);
PaintOval(box);
end
end.

24
examples/rings.pas Normal file
View File

@ -0,0 +1,24 @@
program ExampleRings;
var
Top, Left, Bottom, Right: Integer;
Diam, Increase: Integer;
Box: Rect;
begin
Top := 0;
Left := 0;
Diam := 0;
Write('Type an integer between 1 and 25: ');
Read(Increase);
ShowDrawing;
repeat
Diam := Diam + Increase;
Bottom := Diam;
Right := Diam;
SetRect(box, Left, Top, Right, Bottom);
FrameOval(box);
until Diam > 400
end.

42
examples/rubberband.pas Normal file
View File

@ -0,0 +1,42 @@
program ExampleRubberBand;
var
x1, y1, x2, y2: Integer;
p: point;
begin
ShowDrawing; {Open Drawing Window}
MoveTo(20, 20); {Label graph and options}
TextSize(18);
WriteDraw('Rubber Band Program');
TextSize(10);
MoveTo(30, 40);
WriteDraw('* Button down to draw line');
MoveTo(30, 50);
WriteDraw('* Double-click left of window to QUIT');
PenMode(patXor); {Set Pen Mode to Xor}
{to erase and redraw line}
repeat {Keep working until exit}
if Button then {executes once/line}
begin
GetMouse(p); {Read first point on line}
x1 := p.h; {horizontal element of point}
y1 := p.v;
{ vertical element of point }
while Button do {Loop until button released}
begin
GetMouse(p); {Read second point}
x2 := p.h; {horizontal element}
y2 := p.v;
{ vertical element }
DrawLine(x1, y1, x2, y2); {Draw line}
DrawLine(x1, y1, x2, y2); {Erase line}
end; {Now redraw permanent line }
DrawLine(x1, y1, x2, y2);
end;
until (x1 < 0) and Button {Exit by clicking left}
end.

131
examples/saver.pas Normal file
View File

@ -0,0 +1,131 @@
program ExampleSaver;
type
Collider = object
x, y, dx, dy, speed: Real;
end;
Size = object
w, h: Integer;
end;
var
bounds: Size;
frame, delay: Integer;
view: Rect;
p1, p2, p3: Collider;
procedure Init;
begin
new(bounds);
bounds.w := 420;
bounds.h := 320;
SetRect(view, 100, 100, bounds.w + 120, bounds.h + 120);
setDrawingRect(view);
PenSize(1, 1);
ShowDrawing;
frame := 0;
new(p1);
p1.x := Random mod bounds.w + 220;
p1.y := Random mod bounds.h + 120;
p1.speed := 3.5;
p1.dx := p1.speed;
p1.dy := p1.speed;
new(p2);
p2.x := Random mod bounds.w + 220;
p2.y := Random mod bounds.h + 120;
p2.speed := 6.5;
p2.dx := -p2.speed;
p2.dy := p2.speed;
new(p3);
p3.x := Random mod bounds.w + 220;
p3.y := Random mod bounds.h + 120;
p3.speed := 7.5;
p3.dx := p3.speed;
p3.dy := -p3.speed;
end;
procedure Update;
begin
frame := frame + 1;
{ p1 }
if p1.x > bounds.w then
begin
p1.dx := -p1.speed;
end;
if p1.x < 0 then
begin
p1.dx := p1.speed;
end;
if p1.y > bounds.h then
begin
p1.dy := -p1.speed;
end;
if p1.y < 0 then
begin
p1.dy := p1.speed;
end;
{ p2 }
if p2.x > bounds.w then
begin
p2.dx := -p2.speed;
end;
if p2.x < 0 then
begin
p2.dx := p2.speed;
end;
if p2.y > bounds.h then
begin
p2.dy := -p2.speed;
end;
if p2.y < 0 then
begin
p2.dy := p2.speed;
end;
{ p3 }
if p3.x > bounds.w then
begin
p3.dx := -p3.speed;
end;
if p3.x < 0 then
begin
p3.dx := p3.speed;
end;
if p3.y > bounds.h then
begin
p3.dy := -p3.speed;
end;
if p3.y < 0 then
begin
p3.dy := p3.speed;
end;
p1.x := p1.x + p1.dx;
p1.y := p1.y + p1.dy;
p2.x := p2.x + p2.dx;
p2.y := p2.y + p2.dy;
p3.x := p3.x + p3.dx;
p3.y := p3.y + p3.dy;
end;
procedure Draw;
begin
MoveTo(round(p1.x), round(p1.y));
LineTo(round(p2.x), round(p2.y));
LineTo(round(p3.x), round(p3.y));
LineTo(round(p1.x), round(p1.y));
end;
begin
Init;
while frame < 200 do
begin
Update;
Draw;
end
end.

21
examples/scale.pas Normal file
View File

@ -0,0 +1,21 @@
program ExampleScale;
var
clip: Rect;
begin
ShowDrawing;
{ origine }
SetRect(clip, 10, 10, 100, 100);
PaintArc(clip, 0, 180);
FrameRect(clip);
{ scale }
EraseArc(clip, 0, 180);
InsetRect(clip, 20, 20);
PaintArc(clip, 0, 180);
FrameRect(clip);
end.

30
examples/shape.pas Normal file
View File

@ -0,0 +1,30 @@
program ExampleShape;
const
PI = 3.141592654;
R = 60.0;
DOTS = 10;
var
dot: Integer;
ax, ay, bx, by: Real;
center: Point;
begin
ShowDrawing;
dot := DOTS;
setPt(center, 100, 100);
repeat
ax := center.h + R * cos(2 * PI * dot / DOTS);
ay := center.v + R * sin(2 * PI * dot / DOTS);
bx := center.h + R * cos(2 * PI * (dot + 1) / DOTS);
by := center.v + R * sin(2 * PI * (dot + 1) / DOTS);
MoveTo(round(ax), round(ay));
LineTo(round(bx), round(by));
dot := dot - 1;
until dot < 1;
end.

33
examples/shapes.pas Normal file
View File

@ -0,0 +1,33 @@
program ExampleShapes;
procedure TraceShape (cx, cy, r, sides: real);
const
PI = 3.141592654;
var
side: Real;
ax, ay, bx, by: Real;
center: Point;
begin
side := sides;
setPt(center, 100, 100);
repeat
ax := center.h + r * cos(2 * PI * side / sides);
ay := center.v + r * sin(2 * PI * side / sides);
bx := center.h + r * cos(2 * PI * (side + 1) / sides);
by := center.v + r * sin(2 * PI * (side + 1) / sides);
MoveTo(round(ax), round(ay));
LineTo(round(bx), round(by));
side := side - 1;
until side < 1;
end;
begin
ShowDrawing;
TraceShape(100, 100, 60, 24);
TraceShape(100, 100, 60, 12);
TraceShape(100, 100, 60, 6);
TraceShape(100, 100, 60, 3);
end.

25
examples/sine.pas Normal file
View File

@ -0,0 +1,25 @@
program ExampleSine;
const
PI = 3.141592654;
AMP = 50;
var
x, y: Real;
begin
ShowDrawing;
x := 0;
repeat
y := sin((x / 300) * (2 * PI)) * AMP;
MoveTo(round(x), AMP + round(y));
LineTo(round(x), AMP + round(y));
x := x + 1;
until x > 400
end.
{ note: If this does not draw a sine in THINK Pascal on Mac II }
{ note: Project > Compile options : toggle 68881/ 68882 }

34
examples/sinefix.pas Normal file
View File

@ -0,0 +1,34 @@
program SineFix;
uses
FixMath;
var
amp, y: Fixed;
x, a: Longint;
r: Rect;
begin
ShowDrawing;
amp := Long2Fix(50);
a := 0;
repeat
x := -1;
ShowDrawing;
MoveTo(-1, -1);
repeat
y := FracSin((x + a) * 6000);
y := FixMul(Frac2Fix(y), amp);
LineTo(x, Fix2Long(y + amp));
x := x + 3;
until x > 250;
a := a + 10;
SetRect(r, 0, 0, 250, 50 * 2 + 1);
FillRect(r, white);
until False;
end.
{ note: This project requires the FixMath library. }

57
examples/spiral.pas Normal file
View File

@ -0,0 +1,57 @@
program ExampleSpiral;
{Program to build spiral pattern, using}
{relative line routine in a recursive loop}
var
sign: Integer;
procedure Spiral (x, y, sign: integer);
{Procedure to spiral into limbo}
var
temp: Integer;
begin
sign := (-1) * sign;
if (abs(x) < 10) and (abs(y) < 10) then
halt {Done recurring - ground case}
else {Spiral still sizable}
begin
line(x, y); {Plot relative line}
{Reduce magnitude of relative move by 5 pixels}
if abs(x) > abs(y) then
x := x - (x div abs(x) * 5)
else
y := y - (y div abs(y) * 5);
{Exchange x<--> y}
temp := x;
x := y;
y := temp;
{On even calls, change sign}
x := sign * x;
y := sign * y;
Spiral(x, y, sign); {Recur}
end;
end;
begin
ShowDrawing;
sign := 1;
PenSize(9, 9);
MoveTo(20, 20);
Spiral(200, 0, -1);
end.

19
examples/string.pas Normal file
View File

@ -0,0 +1,19 @@
program ExampleString;
var
foo: String;
begin
ShowText;
foo := 'foo';
Writeln(foo);
foo[1] := 'b';
foo[2] := 'a';
foo[3] := 'r';
Writeln(foo); { outputs: bar }
end.

25
examples/strings.pas Normal file
View File

@ -0,0 +1,25 @@
program ExampleStrings;
var
width, height: Integer;
ws, hs, combined: str255;
drawingRect: Rect;
begin
width := 220;
height := 140;
NumToString(width, ws);
NumToString(height, hs);
SetRect(drawingRect, 60, 60, 60 + width, 60 + height);
ShowDrawing;
SetDrawingRect(drawingRect);
MoveTo(20, 20);
WriteDraw('Window Size');
MoveTo(20, 40);
WriteDraw(concat(ws, 'x', hs));
end.

19
examples/time.pas Normal file
View File

@ -0,0 +1,19 @@
program ExampleTime;
var
date: DateTimeRec;
seconds: Longint;
begin
ShowText;
GetTime(date);
GetDateTime(seconds);
Writeln('The current time is:');
Writeln(date.hour : 2, ':', date.minute : 2, ':', date.second : 2);
Writeln;
Writeln('Seconds since midnight, January 1, 1904:');
Writeln(-seconds);
end.

24
examples/towerofhanoi.pas Normal file
View File

@ -0,0 +1,24 @@
program TowersOfHanoi (input, output);
var
disks: Integer;
procedure Hanoi (source, temp, destination: char; n: integer);
begin
if n > 0 then
begin
Hanoi(source, destination, temp, n - 1);
Writeln('Move disk ', n : 1, ' from peg ', source, ' to peg ', destination);
Hanoi(temp, source, destination, n - 1);
end;
end;
begin
Write('Enter the number of disks: ');
Readln(disks);
Writeln('Solution:');
Hanoi('A', 'B', 'C', disks);
end.

21
examples/translate.pas Normal file
View File

@ -0,0 +1,21 @@
program ExampleTranslate;
var
clip: Rect;
begin
ShowDrawing;
{ origine }
SetRect(clip, 10, 10, 100, 100);
PaintArc(clip, 0, 180);
FrameRect(clip);
{ translation }
EraseArc(clip, 0, 180);
OffSetRect(clip, 40, 40);
PaintArc(clip, 0, 180);
FrameRect(clip);
end.

15
examples/wedge.pas Normal file
View File

@ -0,0 +1,15 @@
program ExampleWedge;
var
whole, wedge: Rect;
begin
ShowDrawing;
SetRect(whole, 10, 10, 90, 90);
PaintArc(whole, 0, 144);
FillArc(whole, 144, 120, ltgray);
FrameOval(whole);
end.

267
projects/EventTutor/EventTutor.pas Normal file
View File

@ -0,0 +1,267 @@
program EventTutor;
const
BASE_RES_ID = 400;
LEAVE_WHERE_IT_IS = FALSE;
NORMAL_UPDATES = TRUE;
SLEEP = 60;
WNE_TRAP_NUM = $60;
UNIMPL_TRAP_NUM = $9F;
SUSPEND_RESUME_BIT = $0001;
ACTIVATING = 1;
RESUMING = 1;
TEXT_FONT_SIZE = 12;
DRAG_THRESHOLD = 30;
MIN_WINDOW_HEIGHT = 50;
MIN_WINDOW_WIDTH = 50;
SCROLL_BAR_PIXELS = 15;
ROWHEIGHT = 15;
LEFTMARGIN = 10;
STARTROW = 0;
HORIZONTAL_OFFSET = 0;
var
gPictWindow, gEventWindow: WindowPtr;
gTheEvent: EventRecord;
gSizeRect: Rect;
gDone, gWNEimplemented: BOOLEAN;
gCurRow, gMaxRow: INTEGER;
{>>}
procedure CenterPict (thePicture: PicHandle; var myRect: Rect);
var
windRect, pictureRect: Rect;
begin
windRect := myRect;
pictureRect := thePicture^^.picFrame;
myRect.top := (windRect.bottom - windRect.top - (pictureRect.bottom - pictureRect.top)) div 2 + windRect.top;
myRect.bottom := myRect.top + (pictureRect.bottom - pictureRect.top);
myRect.left := (windRect.right - windRect.left - (pictureRect.right - pictureRect.left)) div 2 + windRect.left;
myRect.right := myRect.left + (pictureRect.right - pictureRect.left);
end;
{>>}
procedure DrawMyPicture (drawingWindow: WindowPtr);
var
drawingClipRect, myRect: Rect;
oldPort: GrafPtr;
tempRgn: RgnHandle;
thePicture: PicHandle;
begin
GetPort(oldPort);
SetPort(drawingWindow);
tempRgn := NewRgn;
GetClip(tempRgn);
EraseRect(drawingWindow^.portRect);
DrawGrowicon(drawingWindow);
drawingClipRect := drawingWindow^.portRect;
drawingClipRect.right := drawingClipRect.right - SCROLL_BAR_PIXELS;
drawingClipRect.bottom := drawingClipRect.bottom - SCROLL_BAR_PIXELS;
myRect := drawingWindow^.portRect;
thePicture := GetPicture(BASE_RES_ID);
CenterPict(thePicture, myRect);
ClipRect(drawingClipRect);
DrawPicture(thePicture, myRect);
SetClip(tempRgn);
DisposeRgn(tempRgn);
SetPort(oldPort);
end;
{>>}
procedure HandleMouseDown;
var
whichWindow: WindowPtr;
thePart: INTEGER;
windSize: LONGINT;
oldPort: GrafPtr;
begin
thePart := FindWindow(gTheEvent.where, whichWindow);
case thePart of
inSysWindow:
SystemClick(gTheEvent, whichWindow);
inDrag:
DragWindow(whichWindow, gTheEvent.where, screenBits.bounds);
inContent:
if whichWindow <> FrontWindow then
SelectWindow(whichWindow);
inGrow:
begin
windSize := GrowWindow(whichWindow, gTheEvent.where, gSizeRect);
if (windSize <> 0) then
begin
GetPort(oldPort);
SetPort(whichWindow);
EraseRect(whichWindow^.portRect);
SizeWindow(whichWindow, LoWord(windSize), HiWord(windSize), NORMAL_UPDATES);
InvalRect(whichWindow^.portRect);
SetPort(oldPort);
end;
end;
inGoAway:
gDone := TRUE;
inZoomIn, inZoomOut:
if TrackBox(whichWindow, gTheEvent.where, thePart) then
begin
GetPort(oldPort);
SetPort(whichWindow);
EraseRect(whichWindow^.portRect);
ZoomWindow(whichWindow, thePart, LEAVE_WHERE_IT_IS);
InvalRect(whichWindow^.portRect);
SetPort(oldPort);
end;
end;
end;
{>>}
procedure ScrollWindow;
var
tempRgn: RgnHandle;
begin
tempRgn := NewRgn;
ScrollRect(gEventWindow^.portRect, HORIZONTAL_OFFSET, -ROWHEIGHT, tempRgn);
DisposeRgn(tempRgn);
end;
{>>}
procedure DrawEventString (s: Str255);
begin
if (gCurRow > gMaxRow) then
ScrollWindow
else
gCurRow := gCurRow + ROWHEIGHT;
MoveTo(LEFTMARGIN, gCurRow);
DrawString(s);
end;
{>>}
procedure HandleEvent;
var
gotOne: BOOLEAN;
begin
if gWNEimplemented then
gotOne := WaitNextEvent(everyEvent, gTheEvent, SLEEP, nil)
else
begin
SystemTask;
gotOne := GetNextEvent(everyEvent, gTheEvent);
end;
if gotOne then
case gTheEvent.what of
nullEvent:
begin
end;
mouseDown:
begin
DrawEventString('mouseDown');
HandleMouseDown;
end;
mouseUp:
DrawEventString('mouseUp');
keyDown:
DrawEventString('keyDown');
keyUp:
DrawEventString('keyUp');
autoKey:
DrawEventString('autoKey');
updateEvt:
if (WindowPtr(gTheEvent.message) = gPictWindow) then
begin
DrawEventString('updateEvt: gPictWindow');
BeginUpdate(WindowPtr(gTheEvent.message));
DrawMyPicture(WindowPtr(gTheEvent.message));
EndUpdate(WindowPtr(gTheEvent.message));
end
else
begin
DrawEventString('updateEvt:gEventWindow ');
BeginUpdate(WindowPtr(gTheEvent.message));
EndUpdate(WindowPtr(gTheEvent.message));
end;
diskEvt:
DrawEventString('diskEvt');
activateEvt:
if (WindowPtr(gTheEvent.message) = gPictWindow) then
begin
DrawGrowicon(WindowPtr(gTheEvent.message));
if (BitAnd(gTheEvent.modifiers, activeFlag) = ACTIVATING) then
DrawEventString('activateEvt: activating gPictWindow')
else
DrawEventString('activateEvt: deactivating gPictWindow');
end
else
begin
if (BitAnd(gTheEvent.modifiers, activeFlag) = ACTIVATING) then
DrawEventString('activateEvt: activating gEventWindow')
else
DrawEventString('activateEvt: deactivating gEventWindow');
end;
networkEvt:
DrawEventString('networkEvt');
driverEvt:
DrawEventString('driverEvt');
app1Evt:
DrawEventString('app1Evt');
app2Evt:
DrawEventString('app2Evt');
app3Evt:
DrawEventString('app3Evt');
app4Evt:
if (BitAnd(gTheEvent.message, SUSPEND_RESUME_BIT) = RESUMING) then
DrawEventString('Resume event')
else
DrawEventString('Suspend event');
end;
end;
{>>}
procedure MainLoop;
begin
gDone := FALSE;
gWNEimplemented := (NGetTrapAddress(WNE_TRAP_NUM, ToolTrap) <> NGetTrapAddress(UNIMPL_TRAP_NUM, ToolTrap));
while gDone = FALSE do
HandleEvent;
end;
{>>}
procedure SetUpSizeRect;
begin
gSizeRect.top := MIN_WINDOW_HEIGHT;
gSizeRect.left := MIN_WINDOW_WIDTH;
gSizeRect.bottom := 32767;
gSizeRect.right := 32767;
end;
{>>}
procedure SetupEventWindow;
var
eventRect: Rect;
fontNum: INTEGER;
begin
eventRect := gEventWindow^.portRect;
gMaxRow := eventRect.bottom - eventRect.top - ROWHEIGHT;
gCurRow := STARTROW;
SetPort(gEventWindow);
GetFNum('monaco', fontNum);
TextFont(fontNum);
TextSize(TEXT_FONT_SIZE);
end;
{>>}
procedure Windowinit;
begin
gPictWindow := GetNewWindow(BASE_RES_ID, nil, WindowPtr(-1));
gEventWindow := GetNewWindow(BASE_RES_ID + 1, nil, WindowPtr(-1));
SetupEventWindow;
ShowWindow(gEventWindow);
ShowWindow(gPictWindow);
end;
begin
Windowinit;
SetUpSizeRect;
Mainloop;
end.
{ note: This projects needs 2 WIND resources with id 400 and 401, and a PICT resource with id 400 }

203
projects/SimpleMenu/SimpleMenu.pas Normal file
View File

@ -0,0 +1,203 @@
program SimpleMenu;
const
BASE_RES_ID = 400;
INCLUDE_SECONDS = TRUE;
SLEEP = 60;
WNE_TRAP_NUM = $60;
UNIMPL_TRAP_NUM = $9F;
QUIT_ITEM = 1;
ABOUT_ITEM = 1;
APPLE_MENU_ID = BASE_RES_ID;
FILE_MENU_ID = BASE_RES_ID + 1;
EDIT_MENU_ID = BASE_RES_ID + 2;
OPTIONS_MENU_ID = BASE_RES_ID + 3;
ABOUT_ALERT = 400;
var
gClockWindow: WindowPtr;
gDone, gWNEimplemented: BOOLEAN;
gCurrentTime, gOldTime: LONGINT;
gTheEvent: EventRecord;
{>>}
procedure HandleAppleChoice (theItem: INTEGER);
var
accName: Str255;
accNumber, itemNumber, dummy: INTEGER;
appleMenu: MenuHandle;
begin
case theItem of
ABOUT_ITEM:
dummy := NoteAlert(ABOUT_ALERT, nil);
otherwise
begin
appleMenu := GetMHandle(APPLE_MENU_ID);
GetItem(appleMenu, theItem, accName);
accNumber := OpenDeskAcc(accName);
end;
end;
end;
{>>}
procedure HandleFileChoice (theItem: INTEGER);
begin
case theItem of
QUIT_ITEM:
gDone := TRUE;
end;
end;
{>>}
procedure HandleOptionsChoice (theItem: INTEGER);
var
fontNumber: INTEGER;
fontName: Str255;
fontMenu: MenuHandle;
begin
Writeln(theItem);
end;
{>>}
procedure HandleMenuChoice (menuChoice: LONGINT);
var
theMenu, theItem: INTEGER;
begin
if menuChoice <> 0 then
begin
theMenu := HiWord(menuChoice);
theItem := LoWord(menuChoice);
case theMenu of
APPLE_MENU_ID:
HandleAppleChoice(theItem);
FILE_MENU_ID:
HandleFileChoice(theItem);
OPTIONS_MENU_ID:
HandleOptionsChoice(theItem);
end;
HiliteMenu(0);
end;
end;
{>>}
procedure HandleMouseDown;
var
whichWindow: WindowPtr;
thePart: INTEGER;
menuChoice, windSize: LONGINT;
begin
thePart := FindWindow(gTheEvent.where, whichWindow);
case thePart of
inMenuBar:
begin
menuChoice := MenuSelect(gTheEvent.where);
HandleMenuChoice(menuChoice);
end;
inSysWindow:
SystemClick(gTheEvent, whichWindow);
inDrag:
DragWindow(whichWindow, gTheEvent.where, screenBits.bounds);
inGoAway:
gDone := TRUE;
end;
end;
{>>}
procedure DrawClock (theWindow: WindowPtr);
var
myTimeString: Str255;
begin
IUTimeString(gCurrentTime, INCLUDE_SECONDS, myTimeString);
EraseRect(theWindow^.portRect);
MoveTo(12, 25);
DrawString(myTimeString);
gOldTime := gCurrentTime;
end;
{>>}
procedure HandleNull;
begin
GetDateTime(gCurrentTime);
if gCurrentTime <> gOldTime then
DrawClock(gClockWindow);
end;
{>>}
procedure HandleEvent;
var
theChar: CHAR;
dummy: BOOLEAN;
begin
if gWNEimplemented then
dummy := WaitNextEvent(everyEvent, gTheEvent, SLEEP, nil)
else
begin
SystemTask;
dummy := GetNextEvent(everyEvent, gTheEvent);
end;
case gTheEvent.what of
nullEvent:
HandleNull;
mouseDown:
HandleMouseDown;
keyDown, autoKey:
begin
theChar := CHR(BitAnd(gTheEvent.message, charCodeMask));
if (BitAnd(gTheEvent.modifiers, cmdKey) <> 0) then
HandleMenuChoice(MenuKey(theChar));
end;
updateEvt:
begin
BeginUpdate(WindowPtr(gTheEvent.message));
EndUpdate(WindowPtr(gTheEvent.message));
end;
end;
end;
{>>}
procedure MainLoop;
begin
gDone := FALSE;
gWNEimplemented := (NGetTrapAddress(WNE_TRAP_NUM, ToolTrap) <> NGetTrapAddress(UNIMPL_TRAP_NUM, ToolTrap));
while (gDone = FALSE) do
HandleEvent;
end;
{>>}
procedure MenuBarInit;
var
myMenuBar: Handle;
aMenu: MenuHandle;
begin
myMenuBar := GetNewMBar(BASE_RES_ID);
SetMenuBar(myMenuBar);
DisposHandle(myMenuBar);
aMenu := GetMHandle(APPLE_MENU_ID);
AddResMenu(aMenu, 'DRVR');
DrawMenuBar;
end;
{>>}
procedure Windowinit;
begin
gClockWindow := GetNewWindow(BASE_RES_ID, nil, WindowPtr(-1));
SetPort(gClockWindow);
ShowWindow(gClockWindow);
TextSize(24);
end;
begin
Windowinit;
MenuBarInit;
DrawClock(gClockWindow);
MainLoop;
end.
{ Resources needed: }
{ 1x WIND #400 }
{ 1x MBAR #400 4 options}
{ 1x MENU #400 -> Apple#400[about] File#401[quit] Edit#402[undo, cut, copy, paste, clear] Options#403[option1, option2] }
{ 1x ALRT #400 }
{ 1x DITL #400 }

287
projects/Timer/Timer.pas Normal file
View File

@ -0,0 +1,287 @@
program Timer;
const
BASE_RES_ID = 400;
PLAIN = [];
PLAIN_ITEM = 1;
BOLD_ITEM = 2;
ITALIC_ITEM = 3;
UNDERLINE_ITEM = 4;
OUTLINE_ITEM = 5;
SHADOW_ITEM = 6;
INCLUDE_SECONDS = TRUE;
ADD_CHECK_MARK = TRUE;
REMOVE_CHECK_MARK = FALSE;
DRAG_THRESHOLD = 30;
SLEEP = 60;
WNE_TRAP_NUM = $60;
UNIMPL_TRAP_NUM = $9F;
QUIT_ITEM = 1;
ABOUT_ITEM = 1;
NOT_A_NORMAL_MENU = -1;
APPLE_MENU_ID = BASE_RES_ID;
FILE_MENU_ID = BASE_RES_ID + 1;
FONT_MENU_ID = 100;
STYLE_MENU_ID = 101;
CLOCK_LEFT = 12;
CLOCK_TOP = 25;
CLOCK_SIZE = 24;
ABOUT_ALERT = 400;
var
gClockWindow: WindowPtr;
gDone, gWNEimplemented: BOOLEAN;
gCurrentTime, gOldTime: LONGINT;
gTheEvent: EventRecord;
gLastFont: INTEGER;
gCurrentStyle: Style;
{>>}
procedure CheckStyles;
var
styleMenu: MenuHandle;
begin
styleMenu := GetMHandle(STYLE_MENU_ID);
Checkitem(styleMenu, PLAIN_ITEM, (gCurrentStyle = PLAIN));
Checkitem(styleMenu, BOLD_ITEM, (bold in gCurrentStyle));
Checkitem(styleMenu, ITALIC_ITEM, (italic in gCurrentStyle));
Checkitem(styleMenu, UNDERLINE_ITEM, (underline in gCurrentStyle));
Checkitem(styleMenu, OUTLINE_ITEM, (outline in gCurrentStyle));
Checkitem(styleMenu, SHADOW_ITEM, (shadow in gCurrentStyle));
end;
{>>}
procedure HandleStyleChoice (theitem: INTEGER);
begin
case theitem of
PLAIN_ITEM:
gCurrentStyle := PLAIN;
BOLD_ITEM:
if bold in gCurrentStyle then
gCurrentStyle := gCurrentStyle - [bold]
else
gCurrentStyle := gCurrentStyle + [bold];
ITALIC_ITEM:
if italic in gCurrentStyle then
gCurrentStyle := gCurrentStyle - [italic]
else
gCurrentStyle := gCurrentStyle + [italic];
UNDERLINE_ITEM:
if underline in gCurrentStyle then
gCurrentStyle := gCurrentStyle - [underline]
else
gCurrentStyle := gCurrentStyle + [underline];
OUTLINE_ITEM:
if outline in gCurrentStyle then
gCurrentStyle := gCurrentStyle - [outline]
else
gCurrentStyle := gCurrentStyle + [outline];
SHADOW_ITEM:
if shadow in gCurrentStyle then
gCurrentStyle := gCurrentStyle - [shadow]
else
gCurrentStyle := gCurrentStyle + [shadow];
end;
CheckStyles;
TextFace(gCurrentStyle);
end;
{>>}
procedure HandleFontChoice (theItem: INTEGER);
var
fontNumber: INTEGER;
fontName: Str255;
fontMenu: MenuHandle;
begin
fontMenu := GetMHandle(FONT_MENU_ID);
CheckItem(fontMenu, glastFont, REMOVE_CHECK_MARK);
CheckItem(fontMenu, theItem, ADD_CHECK_MARK);
gLastFont := theItem;
GetItem(fontMenu, theItem, fontName);
GetFNum(fontName, fontNumber);
TextFont(fontNumber);
end;
{>>}
procedure HandleFileChoice (theItem: INTEGER);
begin
case theItem of
QUIT_ITEM:
gDone := TRUE;
end;
end;
{>>}
procedure HandleAppleChoice (theItem: INTEGER);
var
accName: Str255;
accNumber, itemNumber, dummy: INTEGER;
appleMenu: MenuHandle;
begin
case theItem of
ABOUT_ITEM:
dummy := NoteAlert(ABOUT_ALERT, nil);
otherwise
begin
appleMenu := GetMHandle(APPLE_MENU_ID);
GetItem(appleMenu, theItem, accName);
accNumber := OpenDeskAcc(accName);
end;
end;
end;
{>>}
procedure HandleMenuChoice (menuChoice: LONGINT);
var
theMenu, theitem: INTEGER;
begin
if menuChoice <> 0 then
begin
theMenu := HiWord(menuChoice);
theitem := LoWord(menuChoice);
case theMenu of
APPLE_MENU_ID:
HandleAppleChoice(theItem);
FILE_MENU_ID:
HandleFileChoice(theItem);
FONT_MENU_ID:
HandleFontChoice(theItem);
STYLE_MENU_ID:
HandleStyleChoice(theItem);
end;
HiliteMenu(0);
end;
end;
{>>}
procedure HandleMouseDown;
var
whichWindow: WindowPtr;
thePart: INTEGER;
menuChoice, windSize: LONGINT;
begin
thePart := FindWindow(gTheEvent.where, whichWindow);
case thePart of
inMenuBar:
begin
menuChoice := MenuSelect(gTheEvent.where);
HandleMenuChoice(menuChoice);
end;
inSysWindow:
SystemClick(gTheEvent, whichWindow);
inDrag:
DragWindow(whichWindow, gTheEvent.where, screenBits.bounds);
inGoAway:
gDone := TRUE;
end;
end;
{>>}
procedure DrawClock (theWindow: WindowPtr);
var
myTimeString: Str255;
begin
IUTimeString(gCurrentTime, INCLUDE_SECONDS, myTimeString);
EraseRect(theWindow^.portRect);
MoveTo(CLOCK_LEFT, CLOCK_TOP);
DrawString(myTimeString);
gOldTime := gCurrentTime;
end;
{>>}
procedure HandleNull;
begin
GetDateTime(gCurrentTime);
if gCurrentTime <> gOldTime then
DrawClock(gClockWindow);
end;
{>>}
procedure HandleEvent;
var
theChar: CHAR;
dummy: BOOLEAN;
begin
if gWNEimplemented then
dummy := WaitNextEvent(everyEvent, gTheEvent, SLEEP, nil)
else
begin
SystemTask;
dummy := GetNextEvent(everyEvent, gTheEvent);
end;
case gTheEvent.what of
nullEvent:
HandleNull;
mouseDown:
HandleMouseDown;
keyDown, autoKey:
begin
theChar := CHR(BitAnd(gTheEvent.message, charCodeMask));
if (BitAnd(gTheEvent.modifiers, cmdKey) <> 0) then
HandleMenuChoice(MenuKey(theChar));
end;
updateEvt:
begin
BeginUpdate(WindowPtr(gTheEvent.message));
EndUpdate(WindowPtr(gTheEvent.message));
end;
end;
end;
{>>}
procedure MainLoop;
begin
gDone := FALSE;
gWNEimplemented := (NGetTrapAddress(WNE_TRAP_NUM, ToolTrap) <> NGetTrapAddress(UNIMPL_TRAP_NUM, ToolTrap));
while (gDone = FALSE) do
HandleEvent;
end;
{>>}
procedure MenuBarInit;
var
myMenuBar: Handle;
aMenu: MenuHandle;
begin
myMenuBar := GetNewMBar(BASE_RES_ID);
SetMenuBar(myMenuBar);
DisposHandle(myMenuBar);
aMenu := GetMHandle(APPLE_MENU_ID);
AddResMenu(aMenu, 'DRVR');
aMenu := GetMenu(FONT_MENU_ID);
InsertMenu(aMenu, NOT_A_NORMAL_MENU);
AddResMenu(aMenu, 'FONT');
aMenu := GetMenu(STYLE_MENU_ID);
InsertMenu(aMenu, NOT_A_NORMAL_MENU);
Checkitem(aMenu, PLAIN_ITEM, TRUE);
DrawMenuBar;
gLastFont := 1;
gCurrentStyle := PLAIN;
HandleFontChoice(gLastFont);
end;
{>>}
procedure Windowinit;
begin
gClockWindow := GetNewWindow(BASE_RES_ID, nil, WindowPtr(-1));
SetPort(gClockWindow);
ShowWindow(gClockWindow);
TextSize(CLOCK_SIZE);
end;
begin
Windowinit;
MenuBarInit;
DrawClock(gClockWindow);
MainLoop;
end.

78
projects/mpw.pict.p Normal file
View File

@ -0,0 +1,78 @@
program readPICT;
{the following variable must be at the top level}
VAR
globalRef : INTEGER; {refNum of the file to read from}
{the following procedure must be at the top level}
PROCEDURE GetPICTData(dataPtr: Ptr; byteCount: INTEGER);
{replacement for the QuickDraw bottleneck routine}
VAR
err : OSErr;
longCount : LONGINT;
BEGIN
longCount := byteCount;
err := FSRead(globalRef,longCount,dataPtr);
{can't check for an error because we don't know how to handle it}
END;
CONST
abortPICT = 128; {error code if DrawPicture aborted}
PROCEDURE GetDrawPICTFile; {read in a PICT FILE selected by the user}
VAR
wher : Point; {where to display dialog}
reply : SFReply; {reply record}
myFileTypes : SFTypeList; {more Standard FILE goodies}
numFileTypes: INTEGER;
savedProcs : QDProcsPtr;
myProcs : QDProcs; {use CQDProcs for a color window}
myPicture : PicHandle; {we need a picture handle for DrawPicture}
longCount : LONGINT;
myEOF : LONGINT;
myFilePos : LONGINT;
BEGIN
wher.h := 20;
wher.v := 20;
numFileTypes := 1; {display PICT files}
myFileTypes[0] := 'PICT';
SFGetFile(wher,'',NIL,numFileTypes,myFileTypes,NIL,reply);
IF reply.good THEN BEGIN
SetStdProcs(myProcs); {use SetStdCProcs for a CGrafPort}
myProcs.getPicProc := @GetPICTData;
savedProcs := thePort^.grafProcs; {set the grafProcs to ours}
thePort^.grafProcs := @myProcs;
myPicture := PicHandle(NewHandle(SizeOf(myPicture)));
Signal(FSOpen(reply.fname,reply.vRefNum,globalRef));
Signal(GetEOF(globalRef,myEOF)); {get EOF for later check}
Signal(SetFPos(globalRef,fsFromStart,512)); {skip header}
{read in the (obsolete) size word and the picFrame}
longCount := SizeOf(myPicture);
Signal(FSRead(globalRef,longCount,Ptr(myPicture^)));
DrawPicture(myPicture,myPicture^^.picFrame); {draw the picture}
Signal(GetFPos(globalRef,filePos)); {get position for check}
Signal(FSClose(globalRef));
DisposHandle(Handle(myPicture));
thePort^.grafProcs := savedProcs; {restore the procs}
{Check for errors. If there wasn't enough room,}
{DrawPicture will abort; the FILE position mark}
{won't be at the end of the FILE.}
IF filePos <> myEOF THEN Signal(abortPICT);
END; {IF reply.good}
END; {GetDrawPICTFile}