Skip to content

Instantly share code, notes, and snippets.

@i-rinat

i-rinat/jpn.pas Secret

Created July 3, 2017 15:59
Show Gist options
  • Save i-rinat/45f41d44d1cd4839a07b53017234b8e6 to your computer and use it in GitHub Desktop.
Save i-rinat/45f41d44d1cd4839a07b53017234b8e6 to your computer and use it in GitHub Desktop.
Nonograms in Turbo Pascal
{ japan crosswords }
{.$DEFINE DumpEveryTime}
{$Define CheckInfinityLoop}
{$Define Skipping}
{$Define SkippingNotChanged}
{$Define Progress_bar}
{$Define FastClean1}
{/$L+,D+,Q+,R+,S+}
uses dos,crt;
const Diver : double = 2.0;
const EMPTY = 0;
UNKNOWN = -1;
FULL = 1;
DONTCHANGE = -2;
WORKING = 128;
STD_DRAW = 64;
SIZE_MAX = 100;
NUM_COUNT= 20;
var a :array[0..SIZE_MAX-1,0..SIZE_MAX-1]of shortint;
h_line,v_line :array[0..SIZE_MAX-1]of boolean;
h_size,v_size :integer;
i,j :integer;
task_h,task_v :array[0..SIZE_MAX-1,0..NUM_COUNT] of byte;
task_h_size,
task_v_size :array[0..SIZE_MAX-1]of double;
v_changed,h_changed :array[0..SIZE_MAX-1]of boolean;
work1,work2,work3 :array[0..SIZE_MAX-1]of shortint;
{ work1 - à ¡®ç¨© ¬ áᨢ, work2- ®¡à §¥æ, work3 - á㬬 â®à }
cellsize :integer;
x_ofs,y_ofs :integer;
cont_calc :boolean;
filename :string;
_time :longint;
oldExitProc :pointer;
{$IFDEF SkippingNotChanged}
size_change :integer;
{$ENDIF}
{$IFDEF Skipping}
var
skip:boolean;
KbdIntVec : Procedure;
{$F+}
procedure Keyclick; interrupt;
begin
if Port[$60] = $01 then {esc}
begin
skip:=true;
end;
inline ($9C); { PUSHF -- Push flags }
{ Call old ISR using saved vector }
KbdIntVec;
end;
{$F-}
{$ENDIF}
procedure SetRgb(c,r,g,b:byte);
begin
port[$3c8]:=c; port[$3c9]:=r;
port[$3c9]:=g; port[$3c9]:=b;
end;
function getdostimer:longint;
var hour,minute,sec,sec100:word;
temp:longint;
begin
gettime(hour,minute,sec,sec100);
temp:=hour; temp:=temp*60+minute; temp:=temp*60+sec;
getdostimer:=temp;
end;
procedure myExitProc; far;
begin
_time:=getdostimer-_time;
if _time<0 then inc(_time,86400);
writeln(_time,' sec');
{$IFDEF Skipping}
SetIntVec($9,@KbdIntVec);
{$ENDIF}
ExitProc:=OldExitProc;
end;
procedure process_command_string;
procedure Usage;
begin
writeln('usage jpn_cwrd.exe [/n] <taskfile>');
halt(0);
end;
begin
cont_calc:=true;
if paramcount<1 then Usage;
if (paramStr(1)='/n')or(paramStr(1)='/N') then begin
cont_calc:=false;
if paramcount<2 then Usage;
filename:=paramStr(2);
end else filename:=paramStr(1);
delete(filename,pos('.',filename),length(filename)-pos('.',filename)+1);
end;
procedure dump_state;
var df:file;
i,j:integer;
begin
assign(df,FILENAME+'.sol');
filemode:=2;
rewrite(df,1);
blockwrite(df,h_size,2);
blockwrite(df,v_size,2);
for j:=0 to v_size-1 do
for i:=0 to h_size-1 do
blockwrite(df,a[i,j],1);
close(df);
end;
function FileExist(FileName: String): Boolean;
var F: file;
begin
{$I-}
Assign(F, FileName);
FileMode := 0;
Reset(F);
Close(F);
{$I+}
FileExist := (IOResult = 0) and (FileName <> '');
end; { FileExists }
procedure read_state;
var df:file;
i,j:integer;
s:shortint;
begin
h_size:=0; v_size:=0;
{$I-}
assign(df,FILENAME+'.sol');
filemode:=2;
reset(df,1);
if IOResult<>0 then begin cont_calc:=false; exit end;
{$I+}
blockread(df,h_size,2);
blockread(df,v_size,2);
for j:=0 to v_size-1 do
for i:=0 to h_size-1 do
blockread(df,a[i,j],1);
close(df);
end;
procedure SetMode(mode:byte);
var reg:registers;
begin
reg.ah:=0;
reg.al:=mode;
intr($10,reg);
end;
procedure PutCell(x,y,w:integer);
var i,j,nx,ny:integer;
c:byte;
ofs:word;
begin
nx:=x_ofs+x*cellsize;
ny:=y_ofs+y*cellsize;
ofs:=word(ny)*320+nx;
case w of
UNKNOWN, FULL, EMPTY : c:=STD_DRAW+w;
WORKING+UNKNOWN,
WORKING+FULL,
WORKING+EMPTY : c:=w;
else c:=1;
end;
for j:=0 to cellsize-1 do
begin
for i:=0 to cellsize-1 do mem[segA000:ofs+i]:=c;
inc(ofs,320);
end;
end;
function check(first,last:integer):boolean;
var i:integer;
f:boolean;
begin
f:=true; i:=first;
while (i<=last) do begin
if (work2[i]=FULL) and (work1[i]=EMPTY) then begin i:=last+1;f:=false; end else
if (work2[i]=EMPTY) and (work1[i]=FULL) then begin i:=last+1;f:=false; end;
inc(i);
end;
check:=f;
end;
procedure process_h(linenum:integer);
var k:integer;
old:boolean;
procedure walk_h(num,firstavail:integer);
var i,minpos,maxpos,lastpos:integer;
begin
{$IFDEF Skipping}
if skip then exit;
{$ENDIF}
{$IFDEF SkippingNotChanged}
if size_change=0 then exit;
{$ENDIF}
if num>task_h[linenum,0] then
begin
for i:=firstavail to h_size-1 do work1[i]:=EMPTY;
if check(firstavail,h_size-1) then
for i:=0 to h_size-1 do begin
if work3[i]=UNKNOWN then work3[i]:=work1[i]
else if (work3[i]=FULL) and (work1[i]=EMPTY) then begin
work3[i]:=DONTCHANGE; {$IFDEF SkippingNotChanged}dec(size_change);{$ENDIF}end
else if (work3[i]=EMPTY) and (work1[i]=FULL) then begin
work3[i]:=DONTCHANGE; {$IFDEF SkippingNotChanged}dec(size_change);{$ENDIF}end;
end;
exit;
end;
minpos:=firstavail;
maxpos:=h_size-1;
for i:=num+1 to task_h[linenum,0] do maxpos:=maxpos-task_h[linenum,i]-1;
maxpos:=maxpos-task_h[linenum,num]+1;
for i:=minpos to maxpos do begin
{$IFDEF Skipping}
if skip then exit;
{$ENDIF}
{$IFDEF SkippingNotChanged}
if size_change=0 then exit;
{$ENDIF}
for j:=0 to task_h[linenum,num]-1 do work1[j+i]:=FULL;
lastpos:=i+task_h[linenum,num];
if lastpos<h_size then work1[lastpos]:=EMPTY else lastpos:=h_size-1;
if check(firstavail,lastpos) then
walk_h(num+1,lastpos+1);
{$IFDEF FastClean1}
work1[i]:=EMPTY;
{$ELSE}
for j:=i to h_size-1 do work1[j]:=EMPTY;
{$ENDIF FastClean1}
end;
end;
{$IFDEF Progress_bar}
procedure walk_h1(num,firstavail:integer);
var i,minpos,maxpos,lastpos:integer;
next_pos,pos,k:integer;
incer,real_pos:double;
begin
{$IFDEF Skipping}
if skip then exit;
{$ENDIF}
{$IFDEF SkippingNotChanged}
if size_change=0 then exit;
{$ENDIF}
if num>task_h[linenum,0] then
begin
for i:=firstavail to h_size-1 do work1[i]:=EMPTY;
if check(firstavail,h_size-1) then
for i:=0 to h_size-1 do begin
if work3[i]=UNKNOWN then work3[i]:=work1[i]
else if (work3[i]=FULL) and (work1[i]=EMPTY) then begin
work3[i]:=DONTCHANGE; {$IFDEF SkippingNotChanged}dec(size_change);{$ENDIF}end
else if (work3[i]=EMPTY) and (work1[i]=FULL) then begin
work3[i]:=DONTCHANGE; {$IFDEF SkippingNotChanged}dec(size_change);{$ENDIF}end;
end;
exit;
end;
minpos:=firstavail;
maxpos:=h_size-1;
for i:=num+1 to task_h[linenum,0] do maxpos:=maxpos-task_h[linenum,i]-1;
maxpos:=maxpos-task_h[linenum,num]+1;
if maxpos=minpos then incer:=1 else incer:=maxpos-minpos;
incer:=320.0/incer;
pos:=0; next_pos:=0; real_pos:=0.0;
for i:=minpos to maxpos do begin
{$IFDEF Skipping}
if skip then exit;
{$ENDIF}
{$IFDEF SkippingNotChanged}
if size_change=0 then exit;
{$ENDIF}
for j:=0 to task_h[linenum,num]-1 do work1[j+i]:=FULL;
lastpos:=i+task_h[linenum,num];
if lastpos<h_size then work1[lastpos]:=EMPTY else lastpos:=h_size-1;
if check(firstavail,lastpos) then
walk_h(num+1,lastpos+1);
{$IFDEF FastClean1}
work1[i]:=EMPTY;
{$ELSE}
for j:=i to h_size-1 do work1[j]:=EMPTY;
{$ENDIF FastClean1}
real_pos:=real_pos+incer;
next_pos:=trunc(real_pos);
while (pos<next_pos)and(pos<320)do begin mem[segA000:pos]:=4;inc(pos);end;
end;
for i:=0 to 319 do mem[SegA000:i]:=0;
end;
{$ENDIF}
begin
{$IFDEF Skipping}
old:=h_changed[linenum];
{$ENDIF}
{$IFDEF SkippingNotChanged}
size_change:=0;
{$ENDIF}
h_changed[linenum]:=false;
for k:=0 to h_size-1 do begin
work3[k]:=UNKNOWN;
work2[k]:=a[k,linenum];
work1[k]:=UNKNOWN;
{$IFDEF SkippingNotChanged}
if work2[k]=UNKNOWN then inc(size_change);
{$ENDIF}
end;
{$IFDEF Progress_Bar}
walk_h1(1,0);
{$ELSE}
walk_h(1,0);
{$ENDIF}
{$IFDEF Progress_bar}
{$IFDEF Skipping}
if skip then for k:=0 to 319 do mem[SegA000:k]:=0;
{$ENDIF}
{$IFDEF SkippingNotChanged}
if size_change=0 then for k:=0 to 319 do mem[SegA000:k]:=0;
{$ENDIF}
{$ENDIF} {progress_bar}
{$IFDEF Skipping}
if skip then h_changed[linenum]:=old;
if not skip then
{$ENDIF}
for i:=0 to h_size-1 do begin
if ((work3[i]=FULL)or(work3[i]=EMPTY))and(work3[i]<>a[i,linenum]) then
begin
v_changed[i]:=true;
a[i,linenum]:=work3[i];
end;
end;
{$IFDEF Skipping}
skip:=false;
{$ENDIF}
end;
procedure process_v(colnum:integer);
var k:integer;
old:boolean;
procedure walk_v(num,firstavail:integer);
var i,minpos,maxpos,lastpos:integer;
begin
{$IFDEF Skipping}
if skip then exit;
{$ENDIF}
{$IFDEF SkippingNotChanged}
if size_change=0 then exit;
{$ENDIF}
if num>task_v[colnum,0] then
begin
for i:=firstavail to v_size-1 do work1[i]:=EMPTY;
if check(firstavail,v_size-1) then
for i:=0 to v_size-1 do begin
if work3[i]=UNKNOWN then work3[i]:=work1[i]
else if (work3[i]=FULL) and (work1[i]=EMPTY) then begin
work3[i]:=DONTCHANGE; {$IFDEF SkippingNotChanged}dec(size_change);{$ENDIF}end
else if (work3[i]=EMPTY) and (work1[i]=FULL) then begin
work3[i]:=DONTCHANGE; {$IFDEF SkippingNotChanged}dec(size_change);{$ENDIF}end;
end;
exit;
end;
minpos:=firstavail;
maxpos:=v_size-1;
for i:=num+1 to task_v[colnum,0] do maxpos:=maxpos-task_v[colnum,i]-1;
maxpos:=maxpos-task_v[colnum,num]+1;
for i:=minpos to maxpos do begin
{$IFDEF Skipping}
if skip then exit;
{$ENDIF}
{$IFDEF SkippingNotChanged}
if size_change=0 then exit;
{$ENDIF}
for j:=0 to task_v[colnum,num]-1 do work1[j+i]:=FULL;
lastpos:=i+task_v[colnum,num];
if lastpos<v_size then work1[lastpos]:=EMPTY else lastpos:=v_size-1;
if check(firstavail,lastpos) then walk_v(num+1,lastpos+1);
{$IFDEF FastClean1}
work1[i]:=EMPTY;
{$ELSE}
for j:=i to v_size-1 do work1[j]:=EMPTY;
{$ENDIF FastClean1}
end;
end;
{$IFDEF Progress_Bar}
procedure walk_v1(num,firstavail:integer);
var i,minpos,maxpos,lastpos:integer;
next_pos,pos,k:integer;
incer,real_pos:double;
begin
{$IFDEF Skipping}
if skip then exit;
{$ENDIF}
{$IFDEF SkippingNotChanged}
if size_change=0 then exit;
{$ENDIF}
if num>task_v[colnum,0] then
begin
for i:=firstavail to v_size-1 do work1[i]:=EMPTY;
if check(firstavail,v_size-1) then
for i:=0 to v_size-1 do begin
if work3[i]=UNKNOWN then work3[i]:=work1[i]
else if (work3[i]=FULL) and (work1[i]=EMPTY) then begin
work3[i]:=DONTCHANGE; {$IFDEF SkippingNotChanged}dec(size_change);{$ENDIF}end
else if (work3[i]=EMPTY) and (work1[i]=FULL) then begin
work3[i]:=DONTCHANGE; {$IFDEF SkippingNotChanged}dec(size_change);{$ENDIF}end;
end;
exit;
end;
minpos:=firstavail;
maxpos:=v_size-1;
if maxpos=minpos then incer:=1 else incer:=maxpos-minpos;
incer:=320.0/incer;
pos:=0; next_pos:=0; real_pos:=0.0;
for i:=num+1 to task_v[colnum,0] do maxpos:=maxpos-task_v[colnum,i]-1;
maxpos:=maxpos-task_v[colnum,num]+1;
for i:=minpos to maxpos do begin
{$IFDEF Skipping}
if skip then exit;
{$ENDIF}
{$IFDEF SkippingNotChanged}
if size_change=0 then exit;
{$ENDIF}
for j:=0 to task_v[colnum,num]-1 do work1[j+i]:=FULL;
lastpos:=i+task_v[colnum,num];
if lastpos<v_size then work1[lastpos]:=EMPTY else lastpos:=v_size-1;
if check(firstavail,lastpos) then walk_v(num+1,lastpos+1);
{$IFDEF FastClean1}
work1[i]:=EMPTY;
{$ELSE}
for j:=i to v_size-1 do work1[j]:=EMPTY;
{$ENDIF FastClean1}
real_pos:=real_pos+incer;
next_pos:=trunc(real_pos);
while (pos<next_pos)and(pos<320)do begin mem[segA000:pos]:=4;inc(pos);end;
end;
for i:=0 to 319 do mem[SegA000:i]:=0;
end;
{$ENDIF}
begin
{$IFDEF Skipping}
old:=v_changed[colnum];
{$ENDIF}
{$IFDEF SkippingNotChanged}
size_change:=0;
{$ENDIF}
v_changed[colnum]:=false;
for k:=0 to v_size-1 do begin
work3[k]:=UNKNOWN;
work2[k]:=a[colnum,k];
work1[k]:=UNKNOWN;
{$IFDEF SkippingNotChanged}
if work2[k]=UNKNOWN then inc(size_change);
{$ENDIF}
end;
{$IFDEF Progress_bar}
walk_v1(1,0);
{$ELSE}
walk_v(1,0);
{$ENDIF}
{$IFDEF Progress_bar}
{$IFDEF Skipping}
if skip then for k:=0 to 319 do mem[SegA000:k]:=0;
{$ENDIF}
{$IFDEF SkippingNotChanged}
if size_change=0 then for k:=0 to 319 do mem[SegA000:k]:=0;
{$ENDIF}
{$ENDIF} {progress_bar}
{$IFDEF Skipping}
if skip then v_changed[colnum]:=old;
if not skip then
{$ENDIF}
for i:=0 to v_size-1 do begin
if ((work3[i]=FULL)or(work3[i]=EMPTY))and(work3[i]<>a[colnum,i]) then
begin
h_changed[i]:=true;
a[colnum,i]:=work3[i];
end;
end;
{$IFDEF Skipping}
skip:=false;
{$ENDIF}
end;
procedure read_task;
var f:text;
i,j,nx,ny:integer;
procedure size_fail_proc;
begin
SetMode($3);
close(f);
writeln('size too big');
halt(1);
end;
begin
assign(f,FILENAME+'.jcs');
reset(f);
read(f,h_size,v_size);
if (h_size>SIZE_MAX)or(v_size>SIZE_MAX) then size_fail_proc;
readln(f);
for i:=0 to v_size-1 do h_changed[i]:=true;
for i:=0 to h_size-1 do v_changed[i]:=true;
for i:=0 to h_size-1 do
for j:=0 to v_size-1 do a[i,j]:=UNKNOWN;
for i:=0 to h_size-1 do
begin
task_v[i,0]:=0;
while not eoln(f) do
begin inc(task_v[i,0]); if task_v[i,0]>NUM_COUNT then size_fail_proc;
read(f,task_v[i,task_v[i,0]]); end;
readln(f);
end;
readln(f);
for i:=0 to v_size-1 do
begin
task_h[i,0]:=0;
while not eoln(f) do
begin inc(task_h[i,0]); if task_h[i,0]>NUM_COUNT then size_fail_proc;
read(f,task_h[i,task_h[i,0]]); end;
readln(f);
end;
close(f);
nx:=0; ny:=0; cellsize:=0;
while (nx<=300) and (ny<=180) and (cellsize<10) do begin
inc(nx,h_size);
inc(ny,v_size);
inc(cellsize);
end;
dec(nx,h_size);
dec(ny,v_size);
dec(cellsize);
x_ofs:=(320-nx)div 2;
y_ofs:=(200-ny)div 2;
for i:=0 to h_size-1 do v_line[i]:=true;
for i:=0 to v_size-1 do h_line[i]:=true;
for i:=0 to h_size-1 do begin
task_v_size[i]:=0;
for j:=1 to task_v[i,0] do task_v_size[i]:=task_v_size[i]+task_v[i,j];
task_v_size[i]:=exp(task_v[i,0]*ln(v_size-task_v_size[i]-task_v[i,0]+2));
end;
for i:=0 to v_size-1 do begin
task_h_size[i]:=0;
for j:=1 to task_h[i,0] do task_h_size[i]:=task_h_size[i]+task_h[i,j];
task_h_size[i]:=exp(task_h[i,0]*ln(h_size-task_h_size[i]-task_h[i,0]+2));
end;
end;
procedure solve;
var i,j:integer;
l_now,l_last:longint;
s:integer;
f:boolean;
procedure stop_and_dump;
begin
case readkey of
'q','Q': begin
dump_state;
SetMode($3);
halt;
end;
's','S': begin
dump_state;
end;
end;
end;
begin
l_now:=longint(h_size)*longint(v_size);
if (cont_calc) and fileExist(FILENAME+'.sol') then begin
read_state;
end;
for i:=0 to h_size-1 do
for j:=0 to v_size-1 do PutCell(i,j,a[i,j]);
repeat
l_last:=l_now;
{ hor : x line}
for j:=0 to v_size-1 do if (task_h_size[j]<Diver) then if h_line[j] then begin
for i:=0 to h_size-1 do PutCell(i,j,WORKING+a[i,j]);
if keypressed then stop_and_dump;
if h_changed[j] then process_h(j);
s:=h_size;
for i:=0 to h_size-1 do begin
PutCell(i,j,a[i,j]);if a[i,j]<>UNKNOWN then dec(s);end;
if s=0 then h_line[j]:=false;
end;
{ vert : y line }
for i:=0 to h_size-1 do if (task_v_size[i]<Diver) then if (v_line[i]) then begin
for j:=0 to v_size-1 do PutCell(i,j,WORKING+a[i,j]);
if keypressed then stop_and_dump;
if v_changed[i] then process_v(i);
s:=v_size;
for j:=0 to v_size-1 do begin
PutCell(i,j,a[i,j]);if a[i,j]<>UNKNOWN then dec(s);end;
if s=0 then v_line[i]:=false;
end;
{$IFDEF DumpEveryTime}
dump_state;
{$ENDIF}
for i:=0 to v_size-1 do task_h_size[i]:=task_h_size[i]/Diver;
for i:=0 to h_size-1 do task_v_size[i]:=task_v_size[i]/Diver;
l_now:=0;
for i:=0 to h_size-1 do
for j:=0 to v_size-1 do if a[i,j]=UNKNOWN then inc(l_now);
{$IFDEF CheckInfinityLoop}
f:=false;
for i:=0 to h_size-1 do f:=f or v_changed[i] or (task_v_size[i]>Diver);
for i:=0 to v_size-1 do f:=f or h_changed[i] or (task_h_size[i]>Diver);
if (not f)and(l_now>0) then begin
SetMode($3);
writeln(filename,' : error (infinity loop)');
dump_state;
halt(1);
end;
{$EndIf}
until (l_now=0);
end;
procedure initVideo;
const deep:double=0.3;
begin
SetMode($13);
SetRgb(STD_DRAW+UNKNOWN,42,42,42);
SetRgb(STD_DRAW+EMPTY ,21,21,21);
SetRgb(STD_DRAW+FULL ,63,63,63);
SetRgb(WORKING+EMPTY,trunc(0*deep+(1-deep)*21),trunc(42*deep+(1-deep)*21),trunc(0*deep+(1-deep)*21));
SetRgb(WORKING+FULL,trunc(0*deep+(1-deep)*63),trunc(42*deep+(1-deep)*63),trunc(0*deep+(1-deep)*63));
SetRgb(WORKING+UNKNOWN,trunc(0*deep+(1-deep)*42),trunc(42*deep+(1-deep)*42),trunc(0*deep+(1-deep)*42));
end;
begin
{$IFDEF Skipping}
GetIntVec($9,@KbdIntVec);
SetIntVec($9,Addr(Keyclick));
skip:=false;
{$ENDIF}
oldExitProc:=ExitProc;
ExitProc:=@myExitProc;
_time:=getdostimer;
process_command_string;
initVideo;
read_task;
solve;
dump_state;
SetMode($3);
writeln(filename,' : no errors');
end.
uses crt,dos;
const EMPTY = 0;
UNKNOWN = -1;
FULL = 1;
DONTCHANGE = -2;
WORKING = 3;
SIZE_MAX = 100;
NUM_COUNT= 20;
var a :array[0..SIZE_MAX-1,0..SIZE_MAX-1]of shortint;
h_size,v_size :integer;
i,j :integer;
cellsize :integer;
x_ofs,y_ofs :integer;
filename :string;
nx,ny :integer;
done :boolean;
x,y,xold,yold:integer;
var mouse_x,mouse_y:integer;
pressed_l,pressed_r:boolean;
mouse_present:boolean; { …᫨ ¬ëèì ¯à¨áãâáâ¢ã¥â, íâ  ¯¥à¥¬¥­­ ï ¨¬¥¥â §­ ç¥­¨¥ true }
number_of_mouse_buttons:word; { Š®«¨ç¥á⢮ ª­®¯®ª ¬ëè¨ }
function init_mouse:boolean;
var temp:word;
begin
asm
mov ax,0
int 33h
mov temp,ax
mov number_of_mouse_buttons,bx
end;
init_mouse:=(temp=$FFFF);
end;
procedure hide_mouse;assembler;
asm
mov ax,2
int 33h
end;
procedure show_mouse;assembler;
asm
mov ax,1
int 33h
end;
procedure get_mouse;
var temp:word;
begin
asm
mov ax,3
int 33h
mov mouse_x,cx
mov mouse_y,dx
mov temp,bx
end;
pressed_l:=(temp and 1 = 1);
pressed_r:=(temp and 2 = 2);
end;
procedure read_state;
var df:file;
i,j:integer;
s:shortint;
begin
h_size:=0; v_size:=0;
{$I-}
assign(df,FILENAME);
filemode:=2;
reset(df,1);
if IOResult<>0 then exit;
{$I+}
blockread(df,h_size,2);
blockread(df,v_size,2);
for j:=0 to v_size-1 do
for i:=0 to h_size-1 do
blockread(df,a[i,j],1);
close(df);
end;
procedure SetMode(mode:byte);
var reg:registers;
begin
reg.ah:=0;
reg.al:=mode;
intr($10,reg);
end;
procedure PutCell(x,y,w:integer);
var i,j,nx,ny:integer;
c:byte;
ofs:word;
begin
nx:=x_ofs+x*cellsize;
ny:=y_ofs+y*cellsize;
ofs:=word(ny)*320+nx;
case w of
UNKNOWN : c:=7;
FULL : c:=15;
EMPTY : c:=8;
WORKING : c:=2;
else c:=1;
end;
for j:=0 to cellsize-1 do
begin
for i:=0 to cellsize-1 do mem[$a000:ofs+i]:=c;
inc(ofs,320);
end;
end;
function lz(x:integer):string;
var tmp,tmp2:string[2];
begin
str((x mod 100)div 10,tmp);
str(x mod 10,tmp2);
lz:=tmp+tmp2;
end;
begin
if paramCount<1 then begin
Writeln('Usage: sol_view <solfile.sol>');
halt(1);
end;
filename:=paramstr(1);
read_state;
nx:=0; ny:=0; cellsize:=0;
while (nx<=300) and (ny<=180) and (cellsize<10) do begin
inc(nx,h_size);
inc(ny,v_size);
inc(cellsize);
end;
dec(nx,h_size);
dec(ny,v_size);
dec(cellsize);
x_ofs:=(320-nx)div 2;
y_ofs:=(200-ny)div 2;
SetMode($13);
for i:=0 to h_size-1 do
for j:=0 to v_size-1 do Putcell(i,j,a[i,j]);
init_mouse;
Show_Mouse;
done:=false;
directVideo:=false;
xold:=-1; yold:=-1;
repeat
get_mouse;
mouse_x:=mouse_x div 2;
x:=mouse_x-x_ofs;
y:=mouse_y-y_ofs;
x:=x div cellsize;
y:=y div cellsize;
if (x>=0)and(y>=0)and(x<h_size)and(y<v_size)and((x<>xold)or(y<>yold)) then begin
xold:=x; yold:=y;
gotoxy(1,1);
write(lz(x),':',lz(y),' -> ',a[x,y],' ');
end;
if keypressed then
case readkey of
#27:done:=true;
end;
until done;
SetMode($3);
end.
50 35
14 1
1 3 1 3 1
2 12 2 1
2 2 2 1
2 2 1 13 1
1 2 1 1 1 1 1 1
2 2 1 1 1 1 1 1
1 2 1 13 1
2 2 1 1 1 1 1 1
1 1 2 1 1 1 1 1 1
1 2 2 1 13 1
2 1 2 2 1
2 2 2 8 1 4 1
1 1 2 1 1 1 1 2 2
2 2 2 1 1 1 1 1 1
1 1 2 1 1 1 1 1 2 1
2 2 2 8 1 1 1
2 1 2 1 1 1 1 2 2
1 1 2 1 1 1 1 4 1
2 2 2 1 1 1 1 2 1
2 1 2 8 1 2 1
1 1 2 1 1 1 1 2 1
2 2 2 1 1 1 1 2 1
1 1 2 8 1 2 1
2 2 2 1 1 1 1 2 1
2 4 1 1 1 1 2 1
1 4 8 1 2 1
6 2 1
5 1 13 1
4 1 1 1 1 1 1
3 1 1 1 1 1 1
3 1 13 1
2 1 1 1 1 1 1
2 1 1 1 1 1 1
2 1 13 1
2 2 1
2 8 1 4 1
2 1 1 1 1 2 2
2 1 1 1 1 1 1
2 1 1 1 1 1 2 1
2 1 1 1 1 1 1
2 8 1 2 2
2 4 1
2 7 2 1
2 2 2 2 1
2 1 1 3 1
2 1 2 2 1 1
2 12 1 1
5 4 1
3 1
2 3
2 2
2 3
3 3
3 2
3 3
3 2
3 3
3 3
4 2
4 3
3 2
6
7
48
49
3 2
3 7 15 7 6 5
1 1 1 1 1 1 1 1 1 2 2
1 1 7 15 7 6 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 15 1 1 1 6 2 1
3 7 7 4
1 1 1 1 15 1 1 1 6 2
1 1 1 1 1 1 1 1
1 1 1 1 5 1 1 1 5 3
2 7 2 2 7 2 2 2 1
4 1 3 1 11 1 3 1 4 1
12 1 19 1 7
2 2 2 2
5 5
13 19 8
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment