{

Разградыватель японских кроссводров (c) OCTAGRAM, 2004.

В Интернете встречается под именем файла MGET.PAS

Поскольку Turbo Pascal Онлайн позволяет передать в виртуальную

машину только один файл, и программу, и условие нужно объединить

в один файл.

Формат: количество строк, строки, количество столбцов, столбцы.

Каждая строка и столбец - это последовательности символов,

кодирующих объекты на поле. 1..9 - соответственно 1..9,

a..z - 10..35, дальше русские буквы, дальше см. функцию ToNum.

START

25

23

2222

1222

61

1222

2222

43

8

2112

c

22122

12221

g

211112

122211

g

111111

222212

g

111111

4223

c

2111

213

6

17

7

414

21112

112b

226224

1141112

14a1

84225

8121111

14a2

314225

2261111

222b

1121112

22414

227

3

}

{$R-,Q-}

Program MoneyGetter;

Uses CRT;

Const UnKnown = '?'; Plus = '█'; Minus = ' '; Error = '!';

      UseGrid = False;

Type ListType = String[79] {^TListType};

     TListType = Record Count : Byte; Next : ListType End;

     Str79 = String[79];

Function ToNum(Symb : Char) : Byte; Forward;

Function Obsh(Str1, Str2 : Str79) : Str79;

Var a : Byte;

  TempRes : Str79;

Begin

TempRes := '';

For a := 1 To Length(Str1) Do

If Str1[a] <> Str2[a] Then TempRes := TempRes + UnKnown

Else TempRes := TempRes + Str2[a];

Obsh := TempRes

End;

Function CanRazmest(Str : Str79; Place, Len : Byte) : Boolean;

Var a : Byte;

Begin

CanRazmest := True;

If Place > 1 Then If Str[Place - 1] = Plus Then CanRazmest := False;

If Place + Len - 1 < Length(Str) Then If Str[Place + Len] = Plus Then CanRazmest := False;

For a := Place To Place + Len - 1 Do

If Str[a] = Minus Then CanRazmest := False

End;

Function AddLine(Str : Str79; Place, Len : Byte) : Str79;

Var a : Byte;

Begin

If Place > 1 Then Str[Place - 1] := Minus;

If Place + Len - 1 < Length(Str) Then Str[Place + Len] := Minus;

For a := Place To Place + Len - 1 Do

Str[a] := Plus;

AddLine := Str

End;

Function MinLen(Uslov : ListType) : Byte; {For first objects}

Var Tmp : Byte;

Begin

Tmp := 255;

While Uslov <> '' Do

Begin

Tmp := Tmp + ToNum(Uslov[1]) + 1;

Uslov := Copy(Uslov, 2, Length(Uslov) - 1)

End;

MinLen := Tmp

End;

Function ToNum(Symb : Char) : Byte;

Begin

Case Symb Of

'0' .. '9' : ToNum := Byte(Symb) - Byte('0');

'a' .. 'z' : ToNum := Byte(Symb) - Byte('a') + 10;

'A' .. 'Z' : ToNum := Byte(Symb) - Byte('A') + 10;

'А' .. 'Я' : ToNum := Byte(Symb) - Byte('А') + 36;

'а' .. 'п' : ToNum := Byte(Symb) - Byte('а') + 36;

'р' .. 'я' : ToNum := Byte(Symb) - Byte('р') + 52;

'!' : ToNum := 68;

'@' : ToNum := 69;

'#' : ToNum := 70;

'$' : ToNum := 71;

'%' : ToNum := 72;

'^' : ToNum := 73;

'&' : ToNum := 74;

'*' : ToNum := 75

End

End;

Function FillMinus(Str : Str79; Start, Finish : Byte) : Str79;

Var a : Byte;

Begin

For a := Start To Finish Do

Str[a] := Minus;

FillMinus := Str

End;

Function FillPlus(Str : Str79; Start, Finish : Byte) : Str79;

Var a : Byte;

Begin

For a := Start To Finish Do

Str[a] := Plus;

FillPlus := Str

End;

Function AllUnKnown(Str : Str79; Start, Finish : Byte) : Boolean;

Var a : Byte;

Begin

AllUnKnown := True;

For a := Start To Finish Do

If Str[a] <> UnKnown Then AllUnKnown := False

End;

Function PolElem(Uslov : Str79; Elem : Byte) : Byte;

Var a, Tmp : Byte;

Begin

Tmp := 1;

For a := 1 To Elem - 1 Do

Inc(Tmp, ToNum(Uslov[a]) + 1);

PolElem := Tmp

End;

Function NoPlus(Str : Str79; Start, Finish : Byte) : Boolean;

Var a : Byte;

Begin

NoPlus := True;

For a := Start To Finish Do

If Str[a] = Plus Then NoPlus := False

End;

Function Utochn(Str : Str79; Uslov : ListType;

StartPlace, FinishPlace : Byte) : Str79; Forward;

Procedure ShowVert(Str : Str79; Col : Byte); Forward;

Function Utochn2(Str : Str79; Uslov : ListType; StartPlace, FinishPlace : Byte) : Str79;

Var Prom, NewRes : Str79;

    a : Byte;

    NoError : Boolean;

Label Ext;

Begin

Prom := Str;

NoError := False;

If Uslov = '' Then

Begin

If NoPlus(Str, StartPlace, FinishPlace) Then

Utochn2 := FillMinus(Str, StartPlace, FinishPlace)

Else Utochn2 := Error;

GoTo Ext End;

If StartPlace > FinishPlace - MinLen(UsLov) + 1 Then Begin Utochn2 := Error; GoTo Ext End;

If AllUnKnown(Str, StartPlace, FinishPlace) Then

Begin

For a := 1 To Length(Uslov) Do

Prom := FillPlus(Prom, PolElem(Uslov, a) + FinishPlace - MinLen(Uslov),

                 PolElem(Uslov, a + 1) + StartPlace - 3);

If MinLen(Uslov) = FinishPlace - StartPlace + 1 Then

For a := 2 To Length(Uslov) Do

Prom[PolElem(Uslov, a) - 2 + StartPlace] := Minus;

Utochn2 := Prom;

NoError := True

End

Else

For a := FinishPlace - ToNum(Uslov[Length(Uslov)]) + 1

DownTo StartPlace + MinLen(Uslov) - ToNum(Uslov[Length(Uslov)]) Do

If CanRazmest(Str, a, ToNum(Uslov[Length(Uslov)])) Then

If NoPlus(Str, a + ToNum(Uslov[Length(Uslov)]), FinishPlace) Then

Begin

NewRes := AddLine(Str, a, ToNum(Uslov[Length(Uslov)]));

NewRes := FillMinus(NewRes, a + ToNum(Uslov[Length(Uslov)]), FinishPlace);

NewRes := Utochn(NewRes, Copy(Uslov, 1, Length(Uslov) - 1),

                 StartPlace, a - 2);

If NewRes <> Error Then

Begin

ShowVert(NewRes, 79);

If NoError Then

Begin

Prom := Obsh(Prom, NewRes);

If Prom = Str Then

Begin

Utochn2 := Prom;

GoTo Ext

End

End

Else Prom := NewRes;

NoError := True

End

End;

If NoError Then Utochn2 := Prom

Else Utochn2 := Error;

Ext :

End;

Function Utochn(Str : Str79; Uslov : ListType; StartPlace, FinishPlace : Byte) : Str79;

Var Prom, NewRes : Str79;

    a : Byte;

    NoError : Boolean;

Label Ext;

Begin

Prom := Str;

NoError := False;

If Uslov = '' Then

Begin

If NoPlus(Str, StartPlace, FinishPlace) Then

Utochn := FillMinus(Str, StartPlace, FinishPlace)

Else Utochn := Error;

GoTo Ext End;

If StartPlace > FinishPlace - MinLen(UsLov) + 1 Then Begin Utochn := Error; GoTo Ext End;

If AllUnKnown(Str, StartPlace, FinishPlace) Then

Begin

For a := 1 To Length(Uslov) Do

Prom := FillPlus(Prom, PolElem(Uslov, a) + FinishPlace - MinLen(Uslov),

                 PolElem(Uslov, a + 1) + StartPlace - 3);

If MinLen(Uslov) = FinishPlace - StartPlace + 1 Then

For a := 2 To Length(Uslov) Do

Prom[PolElem(Uslov, a) - 2 + StartPlace] := Minus;

Utochn := Prom;

NoError := True

End

Else

For a := StartPlace To FinishPlace - MinLen(Uslov) + 1 Do

If CanRazmest(Str, a, ToNum(Uslov[1])) Then

If NoPlus(Str, StartPlace, a - 1) Then

Begin

NewRes := AddLine(Str, a, ToNum(Uslov[1]));

NewRes := FillMinus(NewRes, StartPlace, a - 1);

NewRes := Utochn2(NewRes, Copy(Uslov, 2, Length(Uslov) - 1),

                 a + ToNum(Uslov[1]) + 1, FinishPlace);

If NewRes <> Error Then

Begin

ShowVert(NewRes, 79);

If NoError Then

Begin

Prom := Obsh(Prom, NewRes);

If (StartPlace = 1) And (FinishPlace = Length(Str)) Then ShowVert(Prom, 80);

If Prom = Str Then

Begin

Utochn := Prom;

GoTo Ext

End

End

Else Prom := NewRes;

NoError := True

End

End;

If NoError Then Utochn := Prom

Else Utochn := Error;

Ext :

End;

Type HeapTp = Array[1 .. 80, 1 .. 80] Of Char;

Var StrNow : Str79;

    HeapSt : HeapTp;

    HeapOldSt : HeapTp;

    SizeX, SizeY : Byte;

    HorizUsl, VertUsl : Array[1 .. 80] Of Str79;

    FileName : Str79; TheFile : Text;

Procedure MakeHeap(DimX, DimY : Byte);

Var a, b : Byte;

Begin

SizeX := DimX;

SizeY := DimY;

For a := 1 To DimY Do

For b := 1 To DimX Do

HeapSt[a, b] := UnKnown

End;

Function HeapEqu : Boolean;

Var a : Word;

Begin

HeapEqu := True;

For a := 1 To 1600 Do

If HeapSt[1, a] <> HeapOldSt[1, a]

Then HeapEqu := False;

HeapOldSt := HeapSt

End;

{Function NoError : Boolean;

Var a : Byte;

Begin

NoError := True;

For a := 1 To SizeY Do

If HeapSt[a, 1] = Error Then NoError := False;

For a := 1 To SizeX Do

If HeapSt[1, a] = Error Then NoError := False

End;}

Const NoError : Boolean = True;

Procedure IzvlHoriz(Row : Byte);

Var a : Byte;

Begin

StrNow := '';

For a := 1 To SizeX Do

StrNow := StrNow + HeapSt[Row, a]

End;

Procedure IzvlVert(Col : Byte);

Var a : Byte;

Begin

StrNow := '';

For a := 1 To SizeY Do

StrNow := StrNow + HeapSt[a, Col]

End;

Procedure SaveHoriz(Row : Byte);

Var a : Byte;

Begin

For a := 1 To SizeX Do

HeapSt[Row, a] := StrNow[a]

End;

Procedure SaveVert(Col : Byte);

Var a : Byte;

Begin

For a := 1 To SizeY Do

HeapSt[a, Col] := StrNow[a]

End;

Procedure UtochnHoriz(Row : Byte);

Begin

IzvlHoriz(Row);

StrNow := Utochn(StrNow, HorizUsl[Row], 1, Length(StrNow));

If StrNow <> Error Then SaveHoriz(Row) Else NoError := False

End;

Procedure UtochnVert(Col : Byte);

Begin

IzvlVert(Col);

StrNow := Utochn(StrNow, VertUsl[Col], 1, Length(StrNow));

If StrNow <> Error Then SaveVert(Col) Else NoError := False;

End;

Var TextScreen : Array[1 .. 50, 1 .. 80] Of

Record Symb : Char; Attr : Byte End Absolute $B800 : 0000;

Procedure MakeGrid;

Var a, b : Byte;

Begin

If not UseGrid then Exit;

For a := 1 To SizeY Do

For b := 1 To SizeX Do

TextScreen[a, b].Attr := $07 + ((a + b) Mod 2) * $88

End;

Procedure ShowVert(Str : Str79; Col : Byte);

Var a : Byte;

Begin

For a := 1 To Length(Str) Do

TextScreen[a, Col].Symb := Str[a]

End;

Procedure HLC(Col : Byte);

Var a : Byte;

Begin

For a := 1 To SizeY Do

TextScreen[a, Col].Attr := $8F

End;

Procedure HLR(Row : Byte);

Var a : Byte;

Begin

For a := 1 To SizeX Do

TextScreen[Row, a].Attr := $8F

End;

Procedure UpdateScreen;

Var a, b : Byte;

Begin

Asm

mov ax, 0720h  {Clear Screen}

push 0B800h

pop es

mov di,0

cld

mov cx,4000

rep stosw

End;

For a := 1 To SizeY Do For b := 1 To SizeX Do

TextScreen[a, b].Symb := HeapSt[a, b]

End;

Function Done : Boolean;

Var a, b : Byte;

Begin

Done := True;

For a := 1 To SizeY Do For b := 1 To SizeX Do

If HeapSt[a, b] = UnKnown Then Done := False

End;

Procedure FFQC(CT : Char); {Find First Question & Change to ... ( Change To ) }

Var a, b : Byte;

Label Ext;

Begin

For a := 1 To SizeY Do

For b := 1 To SizeX Do

If HeapSt[a, b] = UnKnown Then

Begin

HeapSt[a, b] := CT;

GoTo Ext

End;

Ext :

End;

Type STp = Record Q : Array[1 .. 2500] Of Record X, Y : Byte End; Count : Word End;

Var StackQ : Array[1 .. 40] Of ^STp;

Const SP : Byte = 1;

Procedure Push;

Var a, b : Byte;

Begin

New(StackQ[SP]);

StackQ[SP]^.Count := 0;

For a := 1 To SizeY Do

For b := 1 To SizeX Do

If HeapSt[a, b] = UnKnown Then

Begin

Inc(StackQ[SP]^.Count);

StackQ[SP]^.Q[StackQ[SP]^.Count].X := b;

StackQ[SP]^.Q[StackQ[SP]^.Count].Y := a

End;

Inc(SP)

End;

Procedure Pop;

Var a : Byte;

Begin

Dec(SP);

For a := StackQ[SP]^.Count DownTo 1 Do

HeapSt[StackQ[SP]^.Q[a].Y, StackQ[SP]^.Q[a].X] := UnKnown;

Dispose(StackQ[SP]);

End;

Function ColEqu(Col : Byte) : Boolean;

Var a : Byte;

Begin

ColEqu := True;

For a := 1 To SizeY Do

If HeapSt[a, Col] <> HeapOldSt[a, Col] Then

ColEqu := False

End;

Var RowEqu : Array[1 .. 80] Of Boolean;

Procedure RowEq;

Var Row, Col : Byte;

Begin

For Row := 1 To SizeY Do

Begin

RowEqu[Row] := True;

For Col := 1 To SizeX Do

If HeapSt[Row, Col] <> HeapOldSt[Row, Col] Then

RowEqu[Row] := False

End

End;

Procedure Test;

Var Sum1, Sum2 : Word;

    a : Byte;

Begin

Sum1 := 0;

Sum2 := 0;

For a := 1 To SizeX Do

Inc(Sum1, MinLen(VertUsl[a]) + 1 - Length(VertUsl[a]));

For a := 1 To SizeY Do

Inc(Sum2, MinLen(HorizUsl[a]) + 1 - Length(HorizUsl[a]));

If Sum1 <> Sum2 Then

Begin

WriteLn('Checksum error!');

Repeat Until KeyPressed;

Halt(1)

End

End;

{$DEFINE ErStop}

Procedure Think;

Label Ret, Ext, Ext2;

Var a : Byte;

Begin

Ret : UpdateScreen;

NoError := True;

For a := 1 To SizeY Do

If Not RowEqu[a] Then

Begin

HLR(a);

UtochnHoriz(a);

UpdateScreen

End;

{$IFDEF ErStop}

If Not NoError Then GoTo Ext;

{$ENDIF}

UpdateScreen;

NoError := True;

For a := 1 To SizeX Do

If Not ColEqu(a) Then

Begin

HLC(a);

UtochnVert(a);

UpdateScreen

End;

RowEq;

If (Not Done) And (Not HeapEqu) {$IFDEF ErStop} And NoError {$ENDIF} Then GoTo Ret;

Ext :

UpdateScreen;

If Done Then GoTo Ext2;

If Not NoError Then

If SP > 1 Then

Begin

Pop;

FFQC(Minus);

GoTo Ret

End

Else

Begin

{TextMode(CO80);}

WriteLn('Error!');

GoTo Ext2

End

Else

If HeapEqu Then

Begin

Push;

FFQC(Plus);

GoTo Ret

End;

Ext2 :

End;

Var a : Byte;

  S: String;

Begin

{ Write('Введите имя файла условия : '); }

{ ReadLn(FileName); }

Assign(TheFile, 'PROGRAM.PAS');

ReSet(TheFile);

repeat

  ReadLn(TheFile, S);

until S = 'START';

ReadLn(TheFile, SizeY);

For a := 1 To SizeY Do

ReadLn(TheFile, HorizUsl[a]);

ReadLn(TheFile, SizeX);

For a := 1 To SizeX Do

ReadLn(TheFile, VertUsl[a]);

Close(TheFile);

Test;

MakeHeap(SizeX, SizeY);

TextMode(265);

Asm

   mov dx,3DAh

   in al,dx

   mov dx,3C0h

   mov al,10h

   out dx,al

   mov al,04h

   out dx,al

   mov dx,3DAh

   in al,dx

   mov dx,3C0h

   mov al,20h

   out dx,al

End;          { No Blink }

Think;

MakeGrid;

Repeat Until KeyPressed;

TextMode(CO80)

End.