old/PAS/Japan/JAPCROSS.BAK

uses Graph;
const
 MAX_SIZE = 100;
 MAX_LEN  = 20;
 bx = 30;
 by = 30;

type
 tLine = array [1..MAX_SIZE] of shortint;
 pLine = ^tLine;
 tLines = array [1..MAX_SIZE] of pLine;
 pLines = ^TLines;
 tData = array [1..MAX_LEN] of byte;
 pData = ^tData;
 tAll  = array [1..MAX_SIZE] of pData;
 pAll  = ^tAll;

var
 Lines  : pLines;
 Cols   : pLines;
 DataX  : pAll;
 DataY  : pAll;

 changed: boolean;
 inp    : text;
 nIn,nOut:string;
 SizeX,SizeY,sDx,sDy : word;

Function KeyPressed:boolean;assembler;
asm
  mov ah, 1
  int 16h
  mov al, 0
  jz @@2
  mov al, 1
@@2:
end;

procedure InitBoardAndData;
var i : word;
begin
  GetMem(Lines,sizeof(pLine)*SizeY);
  GetMem(Cols,sizeof(pLine)*SizeX);
  for i := 1 to SizeY do
   begin
    GetMem(Lines^[i],SizeX);
    FillChar(Lines^[i]^,SizeX,0);
   end;
  for i := 1 to SizeX do
   begin
    GetMem(Cols^[i],SizeY);
    FillChar(Cols^[i]^,SizeY,0);
   end;
  GetMem(DataX,sizeof(pData)*SizeX);
  GetMem(DataY,sizeof(pData)*SizeY);
  for i := 1 to SizeX do
   begin
    GetMem(DataX^[i],sDx+1);
    FillChar(DataX^[i]^,sDx+1,0);
   end;
  for i := 1 to SizeY do
   begin
    GetMem(DataY^[i],sDy+1);
    FillChar(DataY^[i]^,sDy+1,0);
   end;
end;{InitBoardAndData}
{-------------------------------}
Procedure ReleaseAlldata;
var i : word;
begin
  for i := 1 to SizeY do FreeMem(Lines^[i],SizeY);
  for i := 1 to SizeX do FreeMem(Cols^[i],SizeX);
  FreeMem(Lines,sizeof(pLine)*SizeY);
  FreeMem(Cols,sizeof(pLine)*SizeX);
  for i := 1 to SizeX do FreeMem(DataX^[i],sDx+1);
  for i := 1 to SizeY do FreeMem(DataY^[i],sDy+1);
  FreeMem(DataX,sizeof(pData)*SizeX);
  FreeMem(DataY,sizeof(pData)*SizeY);
end;{ReleaseAlldata}
{-------------------------------}
Procedure ReadAllData;
var i,j,err:word;
    st,s2 : string;
begin
 i:=0;
{
  for i:=1 to SizeX do
   for J := 1 to sDx do Read(inp,dataX^[i]^[j]);
  for i:=1 to SizeY do
   for J := 1 to sDy do Read(inp,dataY^[i]^[j]);}
  repeat
    ReadLn(inp,st);
    if st = '' then continue;
    inc(i);j:=1;
    if Pos(' ',st) = 0 then Val(st,DataX^[i]^[1],err)
    else
    begin
     repeat
       s2:=Copy(st,1,Pos(' ',st)-1);
       Val(s2,DataX^[i]^[j],err);
       Delete(st,1,Pos(' ',st));
       inc(j);
     until pos(' ',st) = 0;
     Val(st,DataX^[i]^[j],err);
    end;
  until eof(inp) or (i=SizeX);
  i:=0;
  repeat
    ReadLn(inp,st);
    if st = '' then continue;
    inc(i);j:=1;
    if Pos(' ',st) = 0 then Val(st,DataY^[i]^[1],err)
    else
    begin
     repeat
       s2:=Copy(st,1,Pos(' ',st)-1);
       Val(s2,DataY^[i]^[j],err);
       Delete(st,1,Pos(' ',st));
       inc(j);
     until pos(' ',st) = 0;
     Val(st,DataY^[i]^[j],err);
    end;
  until eof(inp) or (i=SizeY);
end;{ReadAllData}
{-----------------------------------------------}
Procedure SavePicture;
var
 i,j:word;
 Pict : text;
 l1,l2:string;
begin
 Assign(pict,nOut);
 Rewrite(pict);
 l1:='   ';
 l2:='   ';
 if sizex>9 then
  begin
   for j:=1 to 9 do l1:=l1+' ';
   for i:=1 to (sizeX div 10)-1 do for j:=1 to 10 do l1:=l1+chr($30+i);
   for j:=0 to (sizex mod 10) do l1:=l1+chr($30+(sizeX) div 10);
   for j:=1 to 9 do l2:=l2+chr($30+j);
   for i:=1 to (sizeX div 10)-1 do for j:=0 to 9 do l2:=l2+chr($30+j);
   for j:=0 to (sizex mod 10) do l2:=l2+chr($30+j);
  end
 else
   for j:=1 to SizeX do l2:=l2+chr($30+j);
{ WriteLn(Pict,'            111111111122222222223333333333444444444455555555556666666666777777');
  WriteLn(Pict,'   123456789012345678901234567890123456789012345678901234567890123456789012345');}
 WriteLn(Pict,l1);WriteLn(Pict,l2);
 for i := 1 to sizey do
  begin
    if i > 9 then Write(Pict,i,' ')
             else Write(Pict,' ',i,' ');
    for j:= 1 to sizex do
     case Lines^[i]^[j] of
      1 : write(pict,'þ');
      -1: write(pict,'ú');
      0 : write(pict,' ');
     end;
    Writeln(pict);
  end;
 Close(pict);
end;{SavePicture}
{-----------------------------------------------}
Procedure DrawPicture;
var
 i,j:word;
 l:string;
 k:real;
 grDriver: Integer;
 grMode: Integer;
 ErrCode: Integer;
begin
 grDriver := Detect;
 InitGraph(grDriver, grMode,' ');
 ErrCode := GraphResult;
 if ErrCode <> grOk then
  begin
   WriteLN('No graph :)');
   Exit;
  end;
 if SizeX>SizeY then
  k:=600/SizeX else k:=440/SizeY;
 SetColor(Yellow);
 Rectangle(bx,by,bx+round(SizeX*k),by+round(SizeY*k));
 SetTextStyle(DefaultFont, VertDir, 1);
 SetTextJustify(CENTERTEXT,bottomtext);
 for i := 1 to SizeX do
  begin
    Str(i,l);
    OutTextXY(round(bx+(i-0.5)*k),by-2,l);
    Line(round(bx+i*k),by,round(bx+i*k),by+round(SizeY*k));
  end;
 SetTextStyle(DefaultFont, HorizDir, 1);
 SetTextJustify(RightText,Centertext);
 for i := 1 to SizeY do
  begin
    Str(i,l);
    OutTextXY(bx-2,by+round((i-0.5)*k),l);
    Line(bx,by+round(i*k),round(bx+SizeX*k),by+round(i*k));
  end;
 SetFillStyle(SolidFill,LightRed);
 SetColor(Lightred);
 for i := 1 to sizey do
    for j := 1 to sizex do
     case Lines^[i]^[j] of
      1 : Bar(bx+round((j-1)*k)+1,by+round((i-1)*k)+1,bx+round(k*j)-1,by+round(k*i)-1);
{      1 : FillEllipse(bx+round((j-0.5)*k),by+round((i-0.5)*k),round(k/2),round(k/2));}
      -1: FillEllipse(bx+round((j-0.5)*k),by+round((i-0.5)*k),round(k/10),round(k/10));
     end;
end;{DrawPicture}
{-----------------------------------------------}
Procedure Work(Main:pLine;Other:pLines;data:pData;MainS,pos:word);
var
  M       : array [1..MAX_SIZE] of longint;
  poss    : array [1..MAX_LEN]  of byte;
  counter : longint;
  tmp     : shortint;
  working : tLine;
  i,j     : word;
{-----------------------------}
 Function Test:boolean;
 var i:word;
 begin
   Test:=true;
   for i := 1 to MainS do if Main^[i]*working[i] < 0 then Test:=false;
 end;
{-----------------------------}
 Procedure Setwork;
 var
  i,j:word;
 begin
  fillchar(working,MAX_SIZE,255);i:=1;
  while Data^[i]<>0 do
   begin for j := poss[i] to poss[i]+Data^[i]-1 do working[j]:=1;inc(i);end;
 end;
{-----------------------------}
 Function Shift:boolean;
 var last:word;
 begin
  shift:=false;Last:=1;
  while poss[Last+1]<>0 do inc(Last);
  if data^[Last]+poss[Last]>MainS then
   begin
    dec(last);
    while (Last>0) and (poss[Last]+Data^[Last]+1 >= poss[Last+1]) do dec(last);
   end;
  if Last=0 then exit;
  inc(poss[Last]);
{ if Poss[Last+1] <> 0 then Poss[Last+1] := poss[last]+Data^[Last]+1;}
  while Poss[Last+1] <> 0 do begin Poss[Last+1] := poss[last]+Data^[Last]+1; inc(last);end;
  shift:=true;
  setwork;
 end;
{-----------------------------}
begin
  FillChar(M,MAX_SIZE*4,0);FillChar(poss,MAX_LEN,0);counter:=0;i:=1;j:=1;
  while Data^[i]<>0 do begin poss[i]:=j;inc(j,data^[i]+1);inc(i);end;SetWork;
  repeat
   if test then
    begin
     inc(counter);
     for i := 1 to MainS do inc(M[i],working[i]);
    end;
  until not shift;
  if counter = 0 then begin WriteLN('Error in Data!');Halt(200);end;
  for i := 1 to MainS do if abs(m[i])=counter then
   begin
     tmp := M[i] div abs(m[i]);
     if main^[i] <> tmp then
      begin
       changed := true;
       main^[i]:= tmp;
      end;
     Other^[i]^[pos] := tmp;
   end;
end;
{-------------------------------}
Procedure Reverse(Data:pAll;Size:word);
var
 i,j,last,rb:word;
begin
  for i:=1 to Size do
   begin
    last:=1;while data^[i]^[Last+1]<>0 do inc(Last);
    for j := 1 to last div 2 do
     begin
       rb:=data^[i]^[Last-j+1];
       data^[i]^[Last-j+1] := data^[i]^[j];
       data^[i]^[j]:=rb;
     end;
   end;
end;
{----------------------}
var
 i : word;
 total : longint;
 revx,revy : word;
begin
  if ParamCount < 1 then
   begin
     WriteLn('Usage: japcross.exe <input.txt> [out.asc]');
     Halt(255);
   end;
  nIn := ParamStr(1);
  if ParamStr(2) <> '' then nOut := ParamStr(2)
  else nOut := Copy(nIn,1,Length(nIn)-3)+'asc';

  Assign(inp,nIn);
  {$I-}
    Reset(inp);
    if IOResult <> 0 then
    begin
     writeLn('Error opening ',nIn);
     Halt(244);
    end;
  {$I+}

  Read(inp,SizeX,SizeY,sDx,sDy,revx,revy);
  InitBoardAndData;
  ReadAlldata;
  if RevX = 1 then Reverse(DataX,SizeX);
  if RevY = 1 then Reverse(DataY,SizeY);
  total := 0;
  repeat
    changed := false;
    for i:=1 to sizeX do Work(Cols^[i],Lines,DataX^[i],SizeY,i);
    for i:=1 to sizeY do Work(Lines^[i],Cols,DataY^[i],SizeX,i);
    inc(total);
     Write(#13'Times: ',total,'     ');
    if KeyPressed then
     begin
       SavePicture;
       Close(inp);
       ReleaseAllData;
       Halt(255);
     end;
  until not changed;
  SavePicture;
  Close(inp);
{  DrawPicture;}
  ReadLn;
  ReleaseAllData;
{  CloseGraph;}
end.