Program listing
program Mathemorchids;
uses
graph, crt, dos;
const
dir = '\data\'; { *** Change *** }
maxcolor = 14;
colors : array[1..maxcolor] of shortint = (lightblue, magenta, blue,
yellow, green, lightgreen, red, lightmagenta, lightcyan, cyan,
lightmagenta, white, darkgray, lightgray);
colname : array[0..15] of string =
('black','blue','green','cyan','red','magenta','brown','lightgray',
'darkgray','lightblue','lightgreen','lightcyan','lightred',
'lightmagenta','yellow','white');
maxarray = 10;
maxrad = 2 * 3.141592;
var
xw, yw, xmax, ymax, xmid, ymid, rnum, xradius, yradius : word;
jump, jmin, jmax, jinc, xmult, ymult, xminrad, yminrad,
index, maxindex, loop : shortint;
color : array[1..maxarray] of shortint;
finished, disk, openf, openf1, redo, saving, written : boolean;
rad, radinc : real;
id, numstr : string;
f, f1 : text;
procedure GoGraph;
var
graphdriver, graphmode : integer;
begin
graphdriver := detect;
initgraph (graphdriver, graphmode, '');
xmax := getmaxx;
ymax := getmaxy;
xmid := xmax div 2;
ymid := ymax div 2;
end; { GoGraph }
procedure DrawLine (x1,y1,x2,y2 : integer; puttest : shortint);
var
xdiff, ydiff : integer;
x, y, xinc, yinc : real;
put : shortint;
function Reached : boolean;
var
xreached, yreached : boolean;
begin
if xinc > 0 then
begin
xreached := trunc(x) >= x2;
end else
begin
xreached := trunc(x) <= x2
end;
if yinc > 0 then
begin
yreached := trunc(y) >= y2;
end else
begin
yreached := trunc(y) <= y2;
end;
Reached := xreached and yreached;
end; { Reached }
begin
xdiff := x1 - x2;
ydiff := y1 - y2;
if abs(xdiff) > abs(ydiff) then
begin
yinc := -ydiff / abs(xdiff);
if xdiff < 0 then xinc := +1 else xinc := -1;
end else
begin
xinc := -xdiff / abs(ydiff);
if ydiff < 0 then yinc := +1 else yinc := -1;
end;
x := x1 * 1.0; y := y1 * 1.0;
put := 0;
index := 1;
repeat
inc (put);
if put = puttest then
begin
putpixel (trunc(x),trunc(y),color[index]);
inc (index);
if index > maxindex then index := 1;
put := 0;
end;
if trunc(x) <> x2 then x := x + xinc;
if trunc(y) <> y2 then y := y + yinc;
until reached or keypressed;
end; { DrawLine }
procedure Circle;
const
radius = 150;
begin
rad := 0;
radinc := 0.005;
outtextxy (10,10,id);
if disk then
begin
str (rnum, numstr);
numstr := 'From disk ' + numstr;
end else numstr := 'NO DISK';
outtextxy (10,30,numstr);
repeat
xw := xmid + trunc (sin (rad) * radius + sin (rad * xmult) * xminrad);
yw := ymid + trunc (cos (rad) * radius + cos (rad * ymult) * yminrad);
jump := jump + jinc;
if (jump = jmin) or (jump >= jmax) then jinc := -jinc;
DrawLine (xw,yw,xmid,ymid,jump);
rad := rad + radinc;
until (rad > maxrad);
redo := false;
end; { Circle }
procedure GetColors;
function Different : boolean;
var
temp : boolean;
begin
temp := false;
for index := 1 to maxindex-1 do if color[index] <> color[index+1] then
begin
temp := true;
index := maxindex-1;
end;
Different := temp;
end; { Different }
begin
if not written then
begin
maxindex := random (maxarray-1) + 2;
repeat
for index := 1 to maxindex do color[index] := colors[random(maxcolor)+1];
until Different;
end;
jinc := +1;
jump := jmin;
end; { GetColors }
procedure SetUpData;
procedure GetID;
begin
str (trunc (random * 1000), id);
for loop := 1 to 3 do
begin
id := chr (random (26) + ord('a')) + id;
end;
end; { GetID }
procedure FromDisk;
var
code : integer;
begin
if eof (f) then
begin
reset (f);
rnum := 0;
end;
readln (f, numstr);
val (numstr, jmin, code);
readln (f, numstr);
val (numstr, jmax, code);
readln (f, numstr);
val (numstr, xmult, code);
readln (f, numstr);
val (numstr, ymult, code);
readln (f, numstr);
val (numstr, xminrad, code);
readln (f, numstr);
val (numstr, yminrad, code);
GetColors;
inc (rnum);
end; { FromDisk }
procedure Create;
begin
jmin := random (5) + 3;
jmax := random (80) + jmin + 2;
xmult := random (25);
xminrad := random (40) + 5;
yminrad := random (40) + 5;
if random > 0.5 then ymult := random (25) else
ymult := xmult;
end; { Create }
begin
if not disk then Create else FromDisk;
jinc := +1;
jump := jmin;
GetID;
end; { SetUpData }
procedure SaveData;
function FileExists : boolean;
begin
FileExists := true;
{$i-}
reset (f);
{$i+}
if IoResult <> 0 then
begin
FileExists := false;
end else close (f);
end; { FileExists }
begin
if openf then
begin
while not saving and not eof (f) do readln (f, numstr);
saving := true;
disk := false;
end else
begin
assign (f, dir + 'orchid.dat');
if FileExists then append (f) else rewrite (f);
saving := true;
openf := true;
end;
str (jmin, numstr);
writeln (f, numstr);
str (jmax, numstr);
writeln (f, numstr);
str (xmult, numstr);
writeln (f, numstr);
str (ymult, numstr);
writeln (f, numstr);
str (xminrad, numstr);
writeln (f, numstr);
str (yminrad, numstr);
writeln (f, numstr);
outtextxy (10,50,'SAVED');
end; { SaveData }
procedure ReadFromDisk;
begin
if not disk then
begin
disk := true;
saving := false;
rnum := 0;
if not openf then
begin
assign (f, dir + 'orchid.dat');
reset (f);
openf := true;
end else reset (f);
end else
begin
disk := false;
close (f);
openf := false;
end;
end; { ReadFromDisk }
procedure Help;
begin
closegraph;
clrscr;
writeln;
writeln (' MATHEMORCHIDS');
writeln;
writeln (' H/h : This help screen');
writeln (' R/r : Re-color the shape without modifying it');
writeln (' S/s : Save the shape to disk');
writeln (' F/f : Read / stop reading previously saved shapes from disk');
writeln (' Q/q : Quit the program');
writeln;
writeln (' Press any key to proceed');
repeat until readkey <> '‘';
GoGraph;
redo := true;
end; { Help }
procedure GetKey;
var
pressed : char;
begin
written := false;
repeat
pressed := upcase (readkey);
case pressed of
'H' : Help;
'R' : redo := true;
'S' : SaveData;
'F' : ReadFromDisk;
'Q' : finished := true;
end;
until pressed <> 'S';
end; { GetKey }
procedure SetUp;
begin
finished := false;
openf := false;
openf1 := false;
written := false;
disk := false;
saving := false;
redo := false;
Randomize;
end; { SetUp }
begin
Help;
SetUp;
repeat
if not written then
begin
cleardevice;
if not redo then SetUpData;
GetColors;
Circle;
end;
GetKey;
until finished;
if openf then close (f);
if openf1 then close (f1);
end. { Mathemorchids }
Program by Simon Whitechapel of http://www.freespeech.org/amygdala
Free for personal and educational use at user's own risk
Listing of variables used for creating mathemorchids available here.