Category : Pascal Source Code
Archive   : FILLEDIT.ZIP
Filename : FILLEDIT.PAS

Program fill_Pattern_Editor;
{Created on March 27, 1988 By Darren D. Humphrey Version 1.40

revision history

v 1.00 March 27, 1988 First Kludged version
v 1.10 June 22, 1988 Added primitve windows
v 1.20 June 23, 1988 Added CGA title page
v 1.30 July 26, 1988 Used more elegant screen routines from GBI toolbox.
Cleaned up a LOT of crap.
v 1.40 Aug. 2, 1988 Cleaned up bit-wise crap. Smaller code. Comparable
execution speed.

You may freely copy this source code provided that you adhere to the
following terms:

1. All credits to the author to the author remain unaltered and intact
2. The code is distributed in unmodified form.
3. All of the files are distributed in one archive.

By reading this code, or using this program, you agree to adhere to these terms

}
{$i-,r-,s-,v-,b-}

uses crt,
graph,
filltype, {some fillpatterns created with this program, and
a procedure called setfill which allows you to
use them easily. Source code is N/A}
drivers, {links in CGA driver}
gwindow, {Some shareware routines available from this author
(Windowing in graphics mode)}
gwrites; {Some shareware routines available from this author
(Writes to graphics screen with TABS for columns, etc)}
const
st=':fillpatterntype = (';
filename='newpatrn.dat';

var
cr:pointer; {cursor pointer}
pattern:fillpatterntype; {current fill pattern being edited}
result, {General error result variable}
gd,gm, {graphics mode and graphics driver}
nx,ny:integer; {current cursor position}

{...Procedures, Et al...}

procedure save(s1:string);
var
fil:text;
begin
assign(fil,filename);
reset(fil);
if ioresult=0 then
begin
append(fil);
writeln(fil,s1);
close(fil);
end {of if}
else
begin
rewrite(fil);
writeln(fil,'Const');
writeln(fil,s1);
close(fil);
end; {of else}
end; {of save}

function makecode(pattern:fillpatterntype; var s:string):string;
var
s2:string; {generates source code}
loop:byte;
begin
s:=copy(s,1,12);
insert(' ',s,1);
s:=s+st;
for loop:=1 to 8 do
begin
str(pattern[loop],s2);
s:=s+s2;
if loop<8 then s:=s+',';
end;
s:=s+');';
makecode:=s;
end; {of makecode}

function bitOn(bitno,num:byte):boolean;
begin
biton:=(num shr bitno) and 1=1;
end;

procedure complement(var pattern:fillpatterntype);
var {Inverses fill pattern}
loop:byte;
begin
for loop:=1 to 8 do
pattern[loop]:= pattern[loop] xor 255;
end; {Of complement}

procedure initcursor(var cursor:pointer);
var
size:integer;
begin
initgraph(gd,gm,'');
setcolor(2);
line(5,0,5,10); line(0,5,10,5);
size:=imagesize(0,0,10,10);
getmem(cursor,size);
getimage(0,0,10,10,cursor^);
end; {of initcursor}


procedure helpbox;
var
temps:string;
begin
leftmargin:=3; currentY:=0;
bar3d(40,120,280,190,0,topon);
setviewport(42,122,278,188,clipoff);
gwriteln('ave uit ew');
gwriteln('lear pattern');
gwriteln('everse pattern');
gwriteln(' toggle bit');
gwriteln(' move cursor');
setviewport(0,0,GetMaxX,GetMaxY,clipoff);
end;

procedure rc(x,y:integer);
begin
if biton(x,pattern[y]) then
setfillstyle(1,2)
else setfillstyle(0,2);
bar(((x+1)*12),(y*12),10+((x+1)*12),10+(y*12));
end;{Of rc}

procedure sc(var nx,ny:integer);
begin
if nx>7 then nx:=7;
if nx<0 then nx:=0;
if ny>8 then ny:=8;
if ny<1 then ny:=1;
putImage((nx+1)*12,ny*12,cr^,1);
end;{Of sc}

procedure setup(var pattern:fillpatterntype);
var x,y:integer;
begin
setfillstyle(0,1);
bar3d(10,10,108,108,0,topon);
setfillpattern(pattern,1);
bar3d(124,24,251,101,0,topon);
for x:=0 to 7 do
for y:=1 to 8 do
rc(x,y);
sc(nx,ny);

end; {of setup}

procedure setbit(x,y:integer; var pattern:fillpatterntype);
begin
rc(nx,ny);
pattern[y]:=pattern[y] xor (1 shl x);
setfillpattern(pattern,2);
bar (125,25,250,100);
rc(nx,ny);
end;{Of setbit}

procedure edit(var pattern:fillpatterntype);
var
c:char;
done:boolean;
s1:string;
count:byte;
begin
done:=false;
repeat
case ord(readkey) of
0:case ord(readkey) of
71:begin rc(nx,ny); dec(nx); dec(ny); sc(nx,ny); end; {Home}
72:begin rc(nx,ny); dec(ny); sc(nx,ny); end; {Up Arrow}
73:begin rc(nx,ny); inc(nx); dec(ny); sc(nx,ny); end; {Page Up}
75:begin rc(nx,ny); dec(nx); sc(nx,ny); end; {Left Arrow}
77:begin rc(nx,ny); inc(nx); sc(nx,ny); end; {Right Arrow}
79:begin rc(nx,ny); dec(nx); inc(ny); sc(nx,ny); end; {End}
80:begin rc(nx,ny); inc(ny); sc(nx,ny); end; {Down Arrow}
81:begin rc(nx,ny); inc(nx); inc(ny); sc(nx,ny); end; {Page Down}
end;
55:begin rc(nx,ny); dec(nx); dec(ny); sc(nx,ny); end; {Home}
56:begin rc(nx,ny); dec(ny); sc(nx,ny); end; {Up Arrow}
57:begin rc(nx,ny); inc(nx); dec(ny); sc(nx,ny); end; {Page Up}
52:begin rc(nx,ny); dec(nx); sc(nx,ny); end; {Left Arrow}
54:begin rc(nx,ny); inc(nx); sc(nx,ny); end; {Right Arrow}
49:begin rc(nx,ny); dec(nx); inc(ny); sc(nx,ny); end; {End}
50:begin rc(nx,ny); inc(ny); sc(nx,ny); end; {Down Arrow}
51:begin rc(nx,ny); inc(nx); inc(ny); sc(nx,ny); end; {Page Down}
13:begin setbit(nx,ny,pattern); sc(nx,ny); end;
67,99:begin
for count:=1 to 8 do
pattern[count]:=0;
setup(pattern);
end;
83,115:begin
setwindowparams(10,170,310,190,1,0,1,true,w);
opengwindow(w);
currentY:=4;
gwriteln('Name this pattern: ');
Greadln(w,s1);
s1:=makecode(pattern,s1);
save(s1);
closegwindow(w);
end;
82,114:begin complement(pattern); setup(pattern); end;
81,113:done:=true;
end; {Of Case}
until done;
end; {of Edit}

procedure Title_page;
var
s:string;
i,x,y:integer;
begin
i:=1;
initgraph(gd,gm,'');
if graphresult<>grOk then halt(7);
for y:=1 to 9 do
for x:=1 to 12 do
begin
setcolor(2);
circle(25*x,20*y,10);
if odd(i) then setfill(i,2)
else if (i mod 3 =0) then setfill(i,3)
else setfill(i,1);
floodfill(25*x,20*y,2);
inc(i);
end;
delay(2000);
leftmargin:=0; currenty:=4; linespacing:=2;
SetTextJustify(CenterText,TopText);
setwindowparams(42,100,280,180,0,0,1,clipon,w);
opengwindow(w);
setcolor(1);
gwritelnABS(118,'FillEdit Version 1.40');
gwritelnABS(118,'Copyright (C) 1988');
gwritelnABS(118,'by');

setcolor(3);
gwritelnABS(118,'Darren Humphrey');
setcolor(2);
gwritelnABS(118,'Please press ');
SetTextJustify(LeftText,TopText);
WaitForCR(true);
closegwindow(w);
helpbox;
end;

{...Main...}
begin
result:=0;
result:=RegisterBGIdriver(@CGADriverProc);
if result<>0 then halt(8);
Gd:=cga; gm:=cgac1;
nx:=1; ny:=1;
initcursor(cr);
for result:=1 to 8 do
pattern[result]:=0;
Title_Page;
setup(pattern);
edit(pattern);
closegraph;
textmode(co80);
end.