|
Главная | Правила | Регистрация | Дневники | Справка | Пользователи | Календарь | Поиск | Сообщения за день | Все разделы прочитаны |
|
Опции темы | Опции просмотра |
17.06.2010, 18:23 | #1 (permalink) | |
Member
Регистрация: 29.09.2009
Сообщений: 32
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 10
|
Паскаль. Расстановка 8-ми ферзей на шахматной доске.
Задача звучит так: Цитата:
Мне надо как-то переделать какую-то из двух имеющихся вариантов задач с ферзями под мое условие. У меня имеется два варианта задач с этими ферзями. 1) Она выдает кол-во расстановок и какие-то непонятные числа, судя по всему расстановки, но они в непонятном варианте каком-то: Код:
program Queens; uses crt; const N=8; type Index=1..N; Rasstanovka=array [Index] of 0..N; var X:Rasstanovka; Count:word; function P(var X:Rasstanovka;k,y:Index):boolean; var i:Index; begin i:=1; while (i<k)and(y<>X[i])and(abs(k-i)<>abs(y-X[i])) do inc(i); P:=i=k end; procedure Backtracking(k:Index); var i,y:Index; begin for y:=1 to N do if P(X,k,y) then begin X[k]:=y; if k=N then begin for i:=1 to N do write(X[i]);writeln;inc(Count) end; Backtracking(k+1) end end; begin clrscr; Count:=0; writeln('Rasstanovki ',N,' queens:'); Backtracking(1); writeln('Vsego ',Count,' rasstanovok') end. 2) Этот вариант выдает положение 8-ми ферзей в нормальном положении и даже "рисует" их расположение. Но проблема одна, выдает только один вариант расстановки: Код:
Program QUEENS; Uses CRT; Const N = 8; M = 8; Type Queen = record X,Y : Integer; End; Var A : Array[1..N, 1..N] Of Integer; K : Array[1..M] Of Queen; I,J,Q,X,Y : Integer; Procedure ClearQueen; Var I : Integer; Begin For I := 1 To M Do Begin K[I].X := 0; K[I].Y := 0; End; End; Procedure ShowQueen; Var I : Integer; Begin For I := 1 To M Do WriteLn('Q',I, ' [', K[I].X, ',', K[I].Y, ']'); End; Procedure SetQueen; Begin For I := 1 To M Do If (K[I].X <> 0) And (K[I].Y <> 0) Then A[K[I].X, K[I].Y] := I; End; Procedure ClearArray; Var I,J : Integer; Begin For I := 1 To N Do For J := 1 To N Do A[I, J] := 0; End; Procedure ShowArray; Var I,J : Integer; Begin For I := 1 To N Do Begin For J := 1 To N Do Write(A[I, J]:3); WriteLn; End; End; Procedure SetArray(X,Y : Integer); Var I,J : Integer; Begin For I := 1 To N Do Inc(A[I,Y]); For I := 1 To N Do Inc(A[X,I]); For I := -N To N Do If (X+I>=1) And (X+I<=N) And (Y+I>=1) And (Y+I<=N) Then Inc(A[X+I,Y+I]); For I := -N To N Do If (X+I>=1) And (X+I<=N) And (Y-I>=1) And (Y-I<=N) Then Inc(A[X+I,Y-I]); End; Function CountArray:Integer; Var I,J,S : Integer; Begin S := 0; For I := 1 To N Do For J := 1 To N Do If A[I, J] = 0 Then Inc(S); CountArray := S; End; Begin ClrScr; ClearArray; ClearQueen; Q := 1; I := 1; While (Q <= M) do begin X := Trunc((I-1)/N)+1; Y := I-N*(X-1); If A[X,Y] = 0 then Begin SetArray(X,Y); K[Q].X := X; K[Q].Y := Y; Inc(Q); end else Inc(I); If I > N*N then Begin Dec(Q); I := 1+((K[Q].X - 1) * N + K[Q].Y); K[Q].X := 0; K[Q].Y := 0; ClearArray; For J := 1 To Q-1 Do SetArray(K[J].X,K[J].Y); end; end; ClrScr; ShowQueen; ClearArray; SetQueen; ShowArray; readkey; end. |
|
17.06.2010, 18:23 | |
Helpmaster
Member
Регистрация: 08.03.2016
Сообщений: 0
|
Скорее всего в похожих обсуждениях вы найдете множество полезных советов Турбо Паскаль или Фри Паскаль. Задание по теме Типизированный файл Паскаль Паскаль |
Ads | |
Member
Регистрация: 31.10.2006
Сообщений: 40200
Записей в дневнике: 0
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Репутация: 55070
|
Опции темы | |
Опции просмотра | |
|
|