Запись оставлена OCTAGRAM 12.02.2017 в 06:42
Показать изменения, внесённые Matenlimb, EllPabe, EllPabe, KelFuPs и lookDef | запустить | загрузка… | развернуть | скачать | новая запись

{
Разградыватель японских кроссводров (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.

Отправка исправлений и поправок. (cоздать новую запись)
После отправки поправок вы сможете посмотреть различия между старой и новой записью.

Использовать подсветку синтаксиса
В текущей реализации JS-DOS Read/ReadLn работают только при подключенном модуле Crt! Для подсветки отдельных строк используйте для них префикс @@

{
Разградыватель японских кроссводров (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.

Ваше имя
Введите текст с изображения
картинка

Как долго ваша запись должна быть доступна?
1 день 1 месяц Всегда

Запомнить мои настройки

pastebin - collaborative debugging

Меню навигации

Избранные записи

Форум

Чат

Последние записи

Создатели

Запись оставлена OCTAGRAM 12.02.2017 в 06:42
Показать изменения, внесённые Matenlimb, EllPabe, EllPabe, KelFuPs и lookDef | запустить | загрузка… | развернуть | скачать | новая запись

pastebin - collaborative debugging

Меню навигации

Избранные записи

Форум

Чат

Последние записи

Создатели

Запись оставлена OCTAGRAM 12.02.2017 в 06:42Показать изменения, внесённые Matenlimb, EllPabe, EllPabe, KelFuPs и lookDef | запустить | загрузка… | развернуть | скачать | новая запись

Запись оставлена OCTAGRAM 12.02.2017 в 06:42
Показать изменения, внесённые Matenlimb, EllPabe, EllPabe, KelFuPs и lookDef | запустить | загрузка… | развернуть | скачать | новая запись