#99 Article 182 Posted at 1992/02/18 22:58:48 by 相友優 (MAP268) [PAINT]
Subject: Re:*8 領域ペイント /176 .... /167 /164
そんじゃ、昔仕事用に空で書いた奴（タイルに対応してる奴）を忘れないように(笑)
あげときます。
以下( Turbo pascal 5.0 以上で 98互換機ね )
まず単色塗り
program paint;
type istr=string[80];
function value(i:istr):longint;
var n:longint; n1:word;
begin
while (copy(i,1,1)=' ') or (copy(i,1,1)='+') do delete(i,1,1);
val(i,n,n1);
if n1<>0 then begin
i:=copy(i,1,n1-1);
val(i,n,n1)
end;
value:=n;
if i='' then value:=0;
end;
function cstr(i:longint):istr;
var c : istr;
function cv(n:longint):istr;
var d:longint; m:word;
begin
d:=n div 10; m:=n mod 10;
if d<>0 then cv:=cv(d)+chr(m+48)
else
cv:=chr(m+48);
end;
begin
c:='';
if i<0 then c:='-';
cstr:=c+cv(abs(i));
end;
const bp:array[0..7] of byte=(128,64,32,16,8,4,2,1);
maxfifo=4096;
type
v80=array [0..79] of byte;
vra=array [0..399] of v80;
poi=record
x,y:word;
dir:boolean;
end;
var
vram0:vra absolute $a800:0;
vram1:vra absolute $b000:0;
vram2:vra absolute $b800:0;
ox,oy:word;
stack:array [0..maxfifo] of poi;
fi,fo:word;
procedure pushpo(x,y:word);
begin
inc(fi);
fi:=fi mod maxfifo;
stack[fi].x:=x;
stack[fi].y:=y;
end;
procedure pulpo(var x,y:word);
begin
if fi<>fo then begin
inc(fo);
fo:=fo mod maxfifo;
x:=stack[fo].x;
y:=stack[fo].y;
end else begin x:=ox; y:=oy; end;
end;
function point(x,y:word):boolean;
var p:word;
begin
p:=x and 7;
x:=x shr 3;
point:=((vram0[y][x] and bp[p])<>0) or
((vram1[y][x] and bp[p])<>0);
end;
procedure pset(x,y:word);
var p:word;
begin
p:=x and 7;
x:=x shr 3;
vram0[y][x]:=vram0[y][x] or bp[p];
vram1[y][x]:=vram1[y][x] or bp[p];
end;
procedure line(x1,x2,y:word);
var i:word;
begin
for i:=x1 to x2 do pset(i,y);
end;
function seekp(x,y:word; dir:boolean):boolean;
var sp:boolean;
begin
sp:=false;
if dir then begin {↓方向}
if y<399 then sp:=not point(x,y+1);
end else if y>0 then sp:=not point(x,y-1);
seekp:=sp;
end;
procedure paintf(x,y:word);
var dir:boolean; dirf,dirb:array [boolean] of boolean; px,x1,x2:word;
const dirc:array[boolean] of integer=(-1,1);
begin
pushpo(x,y);
while (fi<>fo) do begin
pulpo(x,y);
if not point(x,y) then begin
x1:=x; x2:=x;
while (not point(x1,y)) and (x1>1) do dec(x1);
inc(x1);
while (not point(x2,y)) and (x2<639) do inc(x2);
dec(x2);
line(x1,x2,y);
dirf[false]:=seekp(x1,y,false); dirf[true]:=seekp(x1,y,true);
dirb[false]:=false; dirb[true]:=false;
px:=x1;
while px<=x2 do begin
for dir:=false to true do begin
if (not dirb[dir]) and dirf[dir] then pushpo(px,y+dirc[dir]);
dirb[dir]:=dirf[dir]; dirf[dir]:=seekp(px,y,dir);
end;
inc(px);
end;
end;
end;
end;
begin
fi:=0; fo:=0;
if ParamCount>1 then begin
ox:=value(ParamStr(1));
oy:=value(ParamStr(2));
paintf(ox,oy);
end;
end.
あ、もしかして塗るところはアルゴリズムのチェック用だったから手を抜いてるかも
しれない… ま～い～や。 読めばわかるでせう。
次、たいる。
program paint2;
type istr=string[80];
function value(i:istr):longint;
var n:longint; n1:word;
begin
while (copy(i,1,1)=' ') or (copy(i,1,1)='+') do delete(i,1,1);
val(i,n,n1);
if n1<>0 then begin
i:=copy(i,1,n1-1);
val(i,n,n1)
end;
value:=n;
if i='' then value:=0;
end;
function cstr(i:longint):istr;
var c : istr;
function cv(n:longint):istr;
var d:longint; m:word;
begin
d:=n div 10; m:=n mod 10;
if d<>0 then cv:=cv(d)+chr(m+48)
else
cv:=chr(m+48);
end;
begin
c:='';
if i<0 then c:='-';
cstr:=c+cv(abs(i));
end;
const
bp:array[0..7] of byte=(128,64,32,16,8,4,2,1);
lc:array[0..7] of byte=($ff,$7f,$3f,$1f,$f,$7,$3,$1);
rc:array[0..7] of byte=($80,$c0,$e0,$f0,$f8,$fc,$fe,$ff);
maxfifo=8192;
type
v80=array [0..79] of byte;
vra=array [0..399] of v80;
poi=record
x,y:word;
dir:boolean;
end;
var
vram0:vra absolute $a800:0;
vram1:vra absolute $b000:0;
vram2:vra absolute $b800:0;
ox,oy,bc:word;
stack:array [0..maxfifo] of poi;
fi,fo:word;
pti:istr;
procedure paintf(x,y,bc:word; tile:istr);
type
tiles=array[0..2] of byte;
tilep=array[0..25] of tiles;
var dir:boolean; dirf,dirb:array [boolean] of boolean; px,x1,x2:integer;
tl:word; ti:tiles; tt:tilep; yy:word; ym:integer;
const dirc:array[boolean] of integer=(-1,1);
procedure pushpo(x,y:word);
begin
inc(fi);
fi:=fi mod maxfifo;
stack[fi].x:=x;
stack[fi].y:=y;
end;
procedure pulpo(var x,y:word);
begin
if fi<>fo then begin
inc(fo);
fo:=fo mod maxfifo;
x:=stack[fo].x;
y:=stack[fo].y;
end else begin x:=ox; y:=oy; end;
end;
function point(x,y:word):boolean;
var p:word; cl,b,r,g:byte; q:boolean;
begin
p:=x and 7;
x:=x shr 3;
cl:=bp[p];
b:=vram0[y][x];
r:=vram1[y][x];
g:=vram2[y][x];
case bc of
0:q:=(not (b or r or g) and cl)<>0;
1:q:=(b and not (r or g) and cl)<>0;
2:q:=(r and not (b or g) and cl)<>0;
3:q:=(b and r and (not g) and cl)<>0;
4:q:=(g and not (b or r) and cl)<>0;
5:q:=(b and g and (not r) and cl)<>0;
6:q:=(r and g and (not b) and cl)<>0;
7:q:=(b and r and g and cl)<>0;
end;
if not q then begin
ym:=(y-yy) mod tl;
q:=(((b and cl)=((tt[ym][0]) and cl)) and
((r and cl)=((tt[ym][1]) and cl)) and
((g and cl)=((tt[ym][2]) and cl)));
end;
point:=q;
end;
procedure pset(x,y:word);
var p:word;
begin
p:=x and 7;
x:=x shr 3;
vram0[y][x]:=vram0[y][x] or bp[p];
end;
procedure tline(x1,x2,y:word; ti:tiles);
var j,i,xx1,xx2,p1,p2:word; cp:byte;
procedure setpt;
begin
vram0[y][xx1]:=(vram0[y][xx1] and not cp) or (ti[0] and cp);
vram1[y][xx1]:=(vram1[y][xx1] and not cp) or (ti[1] and cp);
vram2[y][xx1]:=(vram2[y][xx1] and not cp) or (ti[2] and cp);
dec(i);
inc(xx1);
end;
begin
p1:=x1 and 7;
p2:=x2 and 7;
xx1:=x1 shr 3;
xx2:=x2 shr ;
i:=xx2-xx1+1;
if xx2=xx1 then begin cp:=lc[p1] and rc[p2]; setpt; end else
begin
cp:=lc[p1];
setpt;
cp:=$ff;
if i>2 then for j:=1 to i-1 do setpt;
cp:=rc[p2];
setpt;
end;
end;
function seekp(x,y:word; dir:boolean):boolean;
var sp:boolean;
begin
sp:=false;
if dir then begin {↓方向}
if y<399 then sp:=not point(x,y+1);
end else if y>0 then sp:=not point(x,y-1);
seekp:=sp;
end;
begin
tl:=ord(tile[0]) div 3;
for yy:=0 to tl-1 do begin
tt[yy][0]:=byte(tile[yy*3+1]);
tt[yy][1]:=byte(tile[yy*3+2]);
tt[yy][2]:=byte(tile[yy*3+3]);
end;
yy:=y;
pushpo(x,y);
while (fi<>fo) do begin
pulpo(x,y);
if not point(x,y) then begin
x1:=x; x2:=x;
while (not point(x1,y)) and (x1>0) do dec(x1);
inc(x1);
while (not point(x2,y)) and (x2<640) do inc(x2);
dec(x2);
ym:=(y-yy) mod tl;
tline(x1,x2,y,tt[ym]);
dirf[false]:=false; dirf[true]:=false;
px:=x1;
while px<=x2 do begin
for dir:=false to true do begin
dirb[dir]:=dirf[dir]; dirf[dir]:=seekp(px,y,dir);
if (not dirb[dir]) and dirf[dir] then pushpo(px,y+dirc[dir]);
end;
inc(px);
end;
end;
end;
end;
{
00000000
00110110
01111111
01111111
00111110
00011100
00001000
00000000
00000000
}
begin
fi:=0; fo:=0; pti:=#$0#$FF#$AA#0#$FF#$55;
{ fi:=0; fo:=0; pti:=#$55#$ff#$55#$aa#$ff#$aa;}
fi:=0; fo:=0; pti:=#$ff#$ff#$ff#$c9#$ff#$c9#$80#$ff#$80#$80#$ff#$80#$c1#$ff#$c1#$f7#$ff#$f7#$ff#$ff#$ff#$ff#$ff#$ff;
if ParamCount>2 then begin
ox:=value(ParamStr(1));
oy:=value(ParamStr(2));
bc:=value(ParamStr(3));
paintf(ox,oy,bc,pti);
end;
end.
そ～いうわけで、何かに使えるとは思うけど（そこそこ高速だけど）あんまり奇麗な
Pascalじゃないなぁ(笑) 結局これは全部アセンブラ化してＪ３１に某社のグラフィックライブラリに乗ってたりする。ううむ。
そ～とも