pastebin - collaborative debugging

pastebin is a collaborative debugging tool allowing you to share and modify code snippets while chatting on IRC, IM or a message board.

This site is developed to XHTML and CSS2 W3C standards. If you see this paragraph, your browser does not support those standards and you need to upgrade. Visit WaSP for a variety of options.

 >  > Запись оставлена OCTAGRAM 12.02.2017 в 06:42 Получить справку

Запись оставлена OCTAGRAM 12.02.2017 в 06:42
запустить | скачать | новая запись

  1. {
  2. Разградыватель японских кроссводров (c) OCTAGRAM, 2004.
  3.  
  4. В Интернете встречается под именем файла MGET.PAS
  5.  
  6. Поскольку Turbo Pascal Онлайн позволяет передать в виртуальную
  7. машину только один файл, и программу, и условие нужно объединить
  8. в один файл.
  9. Формат: количество строк, строки, количество столбцов, столбцы.
  10. Каждая строка и столбец - это последовательности символов,
  11. кодирующих объекты на поле. 1..9 - соответственно 1..9,
  12. a..z - 10..35, дальше русские буквы, дальше см. функцию ToNum.
  13.  
  14. START
  15. 25
  16. 23
  17. 2222
  18. 1222
  19. 61
  20. 1222
  21. 2222
  22. 43
  23. 8
  24. 2112
  25. c
  26. 22122
  27. 12221
  28. g
  29. 211112
  30. 122211
  31. g
  32. 111111
  33. 222212
  34. g
  35. 111111
  36. 4223
  37. c
  38. 2111
  39. 213
  40. 6
  41. 17
  42. 7
  43. 414
  44. 21112
  45. 112b
  46. 226224
  47. 1141112
  48. 14a1
  49. 84225
  50. 8121111
  51. 14a2
  52. 314225
  53. 2261111
  54. 222b
  55. 1121112
  56. 22414
  57. 227
  58. 3
  59.  
  60.  
  61. }
  62. {$R-,Q-}
  63. Program MoneyGetter;
  64. Uses CRT;
  65. Const UnKnown = '?'; Plus = '█'; Minus = ' '; Error = '!';
  66.       UseGrid = False;
  67. Type ListType = String[79] {^TListType};
  68.      TListType = Record Count : Byte; Next : ListType End;
  69.      Str79 = String[79];
  70. Function ToNum(Symb : Char) : Byte; Forward;
  71.  
  72.  
  73. Function Obsh(Str1, Str2 : Str79) : Str79;
  74. Var a : Byte;
  75.   TempRes : Str79;
  76. Begin
  77. TempRes := '';
  78. For a := 1 To Length(Str1) Do
  79. If Str1[a] <> Str2[a] Then TempRes := TempRes + UnKnown
  80. Else TempRes := TempRes + Str2[a];
  81. Obsh := TempRes
  82. End;
  83.  
  84.  
  85. Function CanRazmest(Str : Str79; Place, Len : Byte) : Boolean;
  86. Var a : Byte;
  87. Begin
  88. CanRazmest := True;
  89. If Place > 1 Then If Str[Place - 1] = Plus Then CanRazmest := False;
  90. If Place + Len - 1 < Length(Str) Then If Str[Place + Len] = Plus Then CanRazmest := False;
  91. For a := Place To Place + Len - 1 Do
  92. If Str[a] = Minus Then CanRazmest := False
  93. End;
  94. Function AddLine(Str : Str79; Place, Len : Byte) : Str79;
  95. Var a : Byte;
  96. Begin
  97. If Place > 1 Then Str[Place - 1] := Minus;
  98. If Place + Len - 1 < Length(Str) Then Str[Place + Len] := Minus;
  99. For a := Place To Place + Len - 1 Do
  100. Str[a] := Plus;
  101. AddLine := Str
  102. End;
  103. Function MinLen(Uslov : ListType) : Byte; {For first objects}
  104. Var Tmp : Byte;
  105. Begin
  106. Tmp := 255;
  107. While Uslov <> '' Do
  108. Begin
  109. Tmp := Tmp + ToNum(Uslov[1]) + 1;
  110. Uslov := Copy(Uslov, 2, Length(Uslov) - 1)
  111. End;
  112. MinLen := Tmp
  113. End;
  114.  
  115. Function ToNum(Symb : Char) : Byte;
  116. Begin
  117. Case Symb Of
  118. '0' .. '9' : ToNum := Byte(Symb) - Byte('0');
  119. 'a' .. 'z' : ToNum := Byte(Symb) - Byte('a') + 10;
  120. 'A' .. 'Z' : ToNum := Byte(Symb) - Byte('A') + 10;
  121. 'А' .. 'Я' : ToNum := Byte(Symb) - Byte('А') + 36;
  122. 'а' .. 'п' : ToNum := Byte(Symb) - Byte('а') + 36;
  123. 'р' .. 'я' : ToNum := Byte(Symb) - Byte('р') + 52;
  124. '!' : ToNum := 68;
  125. '@' : ToNum := 69;
  126. '#' : ToNum := 70;
  127. '$' : ToNum := 71;
  128. '%' : ToNum := 72;
  129. '^' : ToNum := 73;
  130. '&' : ToNum := 74;
  131. '*' : ToNum := 75
  132. End
  133. End;
  134.  
  135. Function FillMinus(Str : Str79; Start, Finish : Byte) : Str79;
  136. Var a : Byte;
  137. Begin
  138. For a := Start To Finish Do
  139. Str[a] := Minus;
  140. FillMinus := Str
  141. End;
  142.  
  143. Function FillPlus(Str : Str79; Start, Finish : Byte) : Str79;
  144. Var a : Byte;
  145. Begin
  146. For a := Start To Finish Do
  147. Str[a] := Plus;
  148. FillPlus := Str
  149. End;
  150.  
  151. Function AllUnKnown(Str : Str79; Start, Finish : Byte) : Boolean;
  152. Var a : Byte;
  153. Begin
  154. AllUnKnown := True;
  155. For a := Start To Finish Do
  156. If Str[a] <> UnKnown Then AllUnKnown := False
  157. End;
  158.  
  159. Function PolElem(Uslov : Str79; Elem : Byte) : Byte;
  160. Var a, Tmp : Byte;
  161. Begin
  162. Tmp := 1;
  163. For a := 1 To Elem - 1 Do
  164. Inc(Tmp, ToNum(Uslov[a]) + 1);
  165. PolElem := Tmp
  166. End;
  167.  
  168. Function NoPlus(Str : Str79; Start, Finish : Byte) : Boolean;
  169. Var a : Byte;
  170. Begin
  171. NoPlus := True;
  172. For a := Start To Finish Do
  173. If Str[a] = Plus Then NoPlus := False
  174. End;
  175.  
  176. Function Utochn(Str : Str79; Uslov : ListType;
  177. StartPlace, FinishPlace : Byte) : Str79; Forward;
  178. Procedure ShowVert(Str : Str79; Col : Byte); Forward;
  179.  
  180. Function Utochn2(Str : Str79; Uslov : ListType; StartPlace, FinishPlace : Byte) : Str79;
  181. Var Prom, NewRes : Str79;
  182.     a : Byte;
  183.     NoError : Boolean;
  184. Label Ext;
  185. Begin
  186. Prom := Str;
  187. NoError := False;
  188. If Uslov = '' Then
  189. Begin
  190. If NoPlus(Str, StartPlace, FinishPlace) Then
  191. Utochn2 := FillMinus(Str, StartPlace, FinishPlace)
  192. Else Utochn2 := Error;
  193. GoTo Ext End;
  194. If StartPlace > FinishPlace - MinLen(UsLov) + 1 Then Begin Utochn2 := Error; GoTo Ext End;
  195.  
  196. If AllUnKnown(Str, StartPlace, FinishPlace) Then
  197. Begin
  198. For a := 1 To Length(Uslov) Do
  199. Prom := FillPlus(Prom, PolElem(Uslov, a) + FinishPlace - MinLen(Uslov),
  200.                  PolElem(Uslov, a + 1) + StartPlace - 3);
  201. If MinLen(Uslov) = FinishPlace - StartPlace + 1 Then
  202. For a := 2 To Length(Uslov) Do
  203. Prom[PolElem(Uslov, a) - 2 + StartPlace] := Minus;
  204. Utochn2 := Prom;
  205. NoError := True
  206. End
  207. Else
  208. For a := FinishPlace - ToNum(Uslov[Length(Uslov)]) + 1
  209. DownTo StartPlace + MinLen(Uslov) - ToNum(Uslov[Length(Uslov)]) Do
  210.  
  211. If CanRazmest(Str, a, ToNum(Uslov[Length(Uslov)])) Then
  212. If NoPlus(Str, a + ToNum(Uslov[Length(Uslov)]), FinishPlace) Then
  213. Begin
  214. NewRes := AddLine(Str, a, ToNum(Uslov[Length(Uslov)]));
  215. NewRes := FillMinus(NewRes, a + ToNum(Uslov[Length(Uslov)]), FinishPlace);
  216. NewRes := Utochn(NewRes, Copy(Uslov, 1, Length(Uslov) - 1),
  217.                  StartPlace, a - 2);
  218. If NewRes <> Error Then
  219. Begin
  220. ShowVert(NewRes, 79);
  221. If NoError Then
  222. Begin
  223. Prom := Obsh(Prom, NewRes);
  224. If Prom = Str Then
  225. Begin
  226. Utochn2 := Prom;
  227. GoTo Ext
  228. End
  229. End
  230. Else Prom := NewRes;
  231. NoError := True
  232. End
  233. End;
  234. If NoError Then Utochn2 := Prom
  235. Else Utochn2 := Error;
  236.  
  237. Ext :
  238. End;
  239.  
  240.  
  241. Function Utochn(Str : Str79; Uslov : ListType; StartPlace, FinishPlace : Byte) : Str79;
  242. Var Prom, NewRes : Str79;
  243.     a : Byte;
  244.     NoError : Boolean;
  245. Label Ext;
  246. Begin
  247. Prom := Str;
  248. NoError := False;
  249. If Uslov = '' Then
  250. Begin
  251. If NoPlus(Str, StartPlace, FinishPlace) Then
  252. Utochn := FillMinus(Str, StartPlace, FinishPlace)
  253. Else Utochn := Error;
  254. GoTo Ext End;
  255. If StartPlace > FinishPlace - MinLen(UsLov) + 1 Then Begin Utochn := Error; GoTo Ext End;
  256.  
  257. If AllUnKnown(Str, StartPlace, FinishPlace) Then
  258. Begin
  259. For a := 1 To Length(Uslov) Do
  260. Prom := FillPlus(Prom, PolElem(Uslov, a) + FinishPlace - MinLen(Uslov),
  261.                  PolElem(Uslov, a + 1) + StartPlace - 3);
  262. If MinLen(Uslov) = FinishPlace - StartPlace + 1 Then
  263. For a := 2 To Length(Uslov) Do
  264. Prom[PolElem(Uslov, a) - 2 + StartPlace] := Minus;
  265. Utochn := Prom;
  266. NoError := True
  267. End
  268. Else
  269. For a := StartPlace To FinishPlace - MinLen(Uslov) + 1 Do
  270. If CanRazmest(Str, a, ToNum(Uslov[1])) Then
  271. If NoPlus(Str, StartPlace, a - 1) Then
  272. Begin
  273. NewRes := AddLine(Str, a, ToNum(Uslov[1]));
  274. NewRes := FillMinus(NewRes, StartPlace, a - 1);
  275. NewRes := Utochn2(NewRes, Copy(Uslov, 2, Length(Uslov) - 1),
  276.                  a + ToNum(Uslov[1]) + 1, FinishPlace);
  277. If NewRes <> Error Then
  278. Begin
  279. ShowVert(NewRes, 79);
  280. If NoError Then
  281. Begin
  282. Prom := Obsh(Prom, NewRes);
  283. If (StartPlace = 1) And (FinishPlace = Length(Str)) Then ShowVert(Prom, 80);
  284. If Prom = Str Then
  285. Begin
  286. Utochn := Prom;
  287. GoTo Ext
  288. End
  289. End
  290. Else Prom := NewRes;
  291. NoError := True
  292. End
  293. End;
  294. If NoError Then Utochn := Prom
  295. Else Utochn := Error;
  296.  
  297. Ext :
  298. End;
  299.  
  300. Type HeapTp = Array[1 .. 80, 1 .. 80] Of Char;
  301. Var StrNow : Str79;
  302.     HeapSt : HeapTp;
  303.     HeapOldSt : HeapTp;
  304.     SizeX, SizeY : Byte;
  305.     HorizUsl, VertUsl : Array[1 .. 80] Of Str79;
  306.     FileName : Str79; TheFile : Text;
  307.  
  308. Procedure MakeHeap(DimX, DimY : Byte);
  309. Var a, b : Byte;
  310. Begin
  311. SizeX := DimX;
  312. SizeY := DimY;
  313. For a := 1 To DimY Do
  314. For b := 1 To DimX Do
  315. HeapSt[a, b] := UnKnown
  316. End;
  317.  
  318. Function HeapEqu : Boolean;
  319. Var a : Word;
  320. Begin
  321. HeapEqu := True;
  322. For a := 1 To 1600 Do
  323. If HeapSt[1, a] <> HeapOldSt[1, a]
  324. Then HeapEqu := False;
  325. HeapOldSt := HeapSt
  326. End;
  327.  
  328. {Function NoError : Boolean;
  329. Var a : Byte;
  330. Begin
  331. NoError := True;
  332. For a := 1 To SizeY Do
  333. If HeapSt[a, 1] = Error Then NoError := False;
  334. For a := 1 To SizeX Do
  335. If HeapSt[1, a] = Error Then NoError := False
  336. End;}
  337.  
  338. Const NoError : Boolean = True;
  339.  
  340. Procedure IzvlHoriz(Row : Byte);
  341. Var a : Byte;
  342. Begin
  343. StrNow := '';
  344. For a := 1 To SizeX Do
  345. StrNow := StrNow + HeapSt[Row, a]
  346. End;
  347.  
  348. Procedure IzvlVert(Col : Byte);
  349. Var a : Byte;
  350. Begin
  351. StrNow := '';
  352. For a := 1 To SizeY Do
  353. StrNow := StrNow + HeapSt[a, Col]
  354. End;
  355.  
  356. Procedure SaveHoriz(Row : Byte);
  357. Var a : Byte;
  358. Begin
  359. For a := 1 To SizeX Do
  360. HeapSt[Row, a] := StrNow[a]
  361. End;
  362.  
  363. Procedure SaveVert(Col : Byte);
  364. Var a : Byte;
  365. Begin
  366. For a := 1 To SizeY Do
  367. HeapSt[a, Col] := StrNow[a]
  368. End;
  369.  
  370. Procedure UtochnHoriz(Row : Byte);
  371. Begin
  372. IzvlHoriz(Row);
  373. StrNow := Utochn(StrNow, HorizUsl[Row], 1, Length(StrNow));
  374. If StrNow <> Error Then SaveHoriz(Row) Else NoError := False
  375. End;
  376.  
  377. Procedure UtochnVert(Col : Byte);
  378. Begin
  379. IzvlVert(Col);
  380. StrNow := Utochn(StrNow, VertUsl[Col], 1, Length(StrNow));
  381. If StrNow <> Error Then SaveVert(Col) Else NoError := False;
  382. End;
  383.  
  384. Var TextScreen : Array[1 .. 50, 1 .. 80] Of
  385. Record Symb : Char; Attr : Byte End Absolute $B800 : 0000;
  386.  
  387. Procedure MakeGrid;
  388. Var a, b : Byte;
  389. Begin
  390. If not UseGrid then Exit;
  391. For a := 1 To SizeY Do
  392. For b := 1 To SizeX Do
  393. TextScreen[a, b].Attr := $07 + ((a + b) Mod 2) * $88
  394. End;
  395.  
  396. Procedure ShowVert(Str : Str79; Col : Byte);
  397. Var a : Byte;
  398. Begin
  399. For a := 1 To Length(Str) Do
  400. TextScreen[a, Col].Symb := Str[a]
  401. End;
  402.  
  403. Procedure HLC(Col : Byte);
  404. Var a : Byte;
  405. Begin
  406. For a := 1 To SizeY Do
  407. TextScreen[a, Col].Attr := $8F
  408. End;
  409.  
  410. Procedure HLR(Row : Byte);
  411. Var a : Byte;
  412. Begin
  413. For a := 1 To SizeX Do
  414. TextScreen[Row, a].Attr := $8F
  415. End;
  416.  
  417. Procedure UpdateScreen;
  418. Var a, b : Byte;
  419. Begin
  420. Asm
  421. mov ax, 0720h  {Clear Screen}
  422. push 0B800h
  423. pop es
  424. mov di,0
  425. cld
  426. mov cx,4000
  427. rep stosw
  428. End;
  429. For a := 1 To SizeY Do For b := 1 To SizeX Do
  430. TextScreen[a, b].Symb := HeapSt[a, b]
  431. End;
  432.  
  433. Function Done : Boolean;
  434. Var a, b : Byte;
  435. Begin
  436. Done := True;
  437. For a := 1 To SizeY Do For b := 1 To SizeX Do
  438. If HeapSt[a, b] = UnKnown Then Done := False
  439. End;
  440.  
  441. Procedure FFQC(CT : Char); {Find First Question & Change to ... ( Change To ) }
  442. Var a, b : Byte;
  443. Label Ext;
  444. Begin
  445. For a := 1 To SizeY Do
  446. For b := 1 To SizeX Do
  447. If HeapSt[a, b] = UnKnown Then
  448. Begin
  449. HeapSt[a, b] := CT;
  450. GoTo Ext
  451. End;
  452. Ext :
  453. End;
  454.  
  455. Type STp = Record Q : Array[1 .. 2500] Of Record X, Y : Byte End; Count : Word End;
  456. Var StackQ : Array[1 .. 40] Of ^STp;
  457. Const SP : Byte = 1;
  458.  
  459. Procedure Push;
  460. Var a, b : Byte;
  461. Begin
  462. New(StackQ[SP]);
  463. StackQ[SP]^.Count := 0;
  464. For a := 1 To SizeY Do
  465. For b := 1 To SizeX Do
  466. If HeapSt[a, b] = UnKnown Then
  467. Begin
  468. Inc(StackQ[SP]^.Count);
  469. StackQ[SP]^.Q[StackQ[SP]^.Count].X := b;
  470. StackQ[SP]^.Q[StackQ[SP]^.Count].Y := a
  471. End;
  472. Inc(SP)
  473. End;
  474. Procedure Pop;
  475. Var a : Byte;
  476. Begin
  477. Dec(SP);
  478. For a := StackQ[SP]^.Count DownTo 1 Do
  479. HeapSt[StackQ[SP]^.Q[a].Y, StackQ[SP]^.Q[a].X] := UnKnown;
  480. Dispose(StackQ[SP]);
  481. End;
  482.  
  483. Function ColEqu(Col : Byte) : Boolean;
  484. Var a : Byte;
  485. Begin
  486. ColEqu := True;
  487. For a := 1 To SizeY Do
  488. If HeapSt[a, Col] <> HeapOldSt[a, Col] Then
  489. ColEqu := False
  490. End;
  491.  
  492. Var RowEqu : Array[1 .. 80] Of Boolean;
  493.  
  494. Procedure RowEq;
  495. Var Row, Col : Byte;
  496. Begin
  497. For Row := 1 To SizeY Do
  498. Begin
  499. RowEqu[Row] := True;
  500. For Col := 1 To SizeX Do
  501. If HeapSt[Row, Col] <> HeapOldSt[Row, Col] Then
  502. RowEqu[Row] := False
  503. End
  504. End;
  505.  
  506. Procedure Test;
  507. Var Sum1, Sum2 : Word;
  508.     a : Byte;
  509. Begin
  510. Sum1 := 0;
  511. Sum2 := 0;
  512. For a := 1 To SizeX Do
  513. Inc(Sum1, MinLen(VertUsl[a]) + 1 - Length(VertUsl[a]));
  514. For a := 1 To SizeY Do
  515. Inc(Sum2, MinLen(HorizUsl[a]) + 1 - Length(HorizUsl[a]));
  516. If Sum1 <> Sum2 Then
  517. Begin
  518. WriteLn('Checksum error!');
  519. Repeat Until KeyPressed;
  520. Halt(1)
  521. End
  522. End;
  523.  
  524. {$DEFINE ErStop}
  525.  
  526. Procedure Think;
  527. Label Ret, Ext, Ext2;
  528. Var a : Byte;
  529. Begin
  530. Ret : UpdateScreen;
  531. NoError := True;
  532. For a := 1 To SizeY Do
  533. If Not RowEqu[a] Then
  534. Begin
  535. HLR(a);
  536. UtochnHoriz(a);
  537. UpdateScreen
  538. End;
  539. {$IFDEF ErStop}
  540. If Not NoError Then GoTo Ext;
  541. {$ENDIF}
  542.  
  543. UpdateScreen;
  544. NoError := True;
  545. For a := 1 To SizeX Do
  546. If Not ColEqu(a) Then
  547. Begin
  548. HLC(a);
  549. UtochnVert(a);
  550. UpdateScreen
  551. End;
  552. RowEq;
  553. If (Not Done) And (Not HeapEqu) {$IFDEF ErStop} And NoError {$ENDIF} Then GoTo Ret;
  554. Ext :
  555. UpdateScreen;
  556. If Done Then GoTo Ext2;
  557. If Not NoError Then
  558. If SP > 1 Then
  559. Begin
  560. Pop;
  561. FFQC(Minus);
  562. GoTo Ret
  563. End
  564. Else
  565. Begin
  566. {TextMode(CO80);}
  567. WriteLn('Error!');
  568. GoTo Ext2
  569. End
  570. Else
  571. If HeapEqu Then
  572. Begin
  573. Push;
  574. FFQC(Plus);
  575. GoTo Ret
  576. End;
  577. Ext2 :
  578. End;
  579.  
  580. Var a : Byte;
  581.   S: String;
  582. Begin
  583. { Write('Введите имя файла условия : '); }
  584. { ReadLn(FileName); }
  585. Assign(TheFile, 'PROGRAM.PAS');
  586. ReSet(TheFile);
  587. repeat
  588.   ReadLn(TheFile, S);
  589. until S = 'START';
  590. ReadLn(TheFile, SizeY);
  591. For a := 1 To SizeY Do
  592. ReadLn(TheFile, HorizUsl[a]);
  593. ReadLn(TheFile, SizeX);
  594. For a := 1 To SizeX Do
  595. ReadLn(TheFile, VertUsl[a]);
  596. Close(TheFile);
  597. Test;
  598. MakeHeap(SizeX, SizeY);
  599. TextMode(265);
  600. Asm
  601.    mov dx,3DAh
  602.    in al,dx
  603.    mov dx,3C0h
  604.    mov al,10h
  605.    out dx,al
  606.    mov al,04h
  607.    out dx,al
  608.    mov dx,3DAh
  609.    in al,dx
  610.    mov dx,3C0h
  611.    mov al,20h
  612.    out dx,al
  613. End;          { No Blink }
  614.  
  615.  
  616. Think;
  617.  
  618. MakeGrid;
  619. Repeat Until KeyPressed;
  620.  
  621. TextMode(CO80)
  622. End.

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

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


картинка


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