uses crt;
var
x,y,z:array[1..64]of integer;
xi,yi,i,j,stepMix:integer;
begin
{вводим координаты точки с контролем}
repeat
write('Enter x:');
readln(xi);
until (xi>0)and(xi<9);
{вводим координаты точки с контролем}
repeat
write('Enter y:');
readln(yi);
until (yi>0)and(yi<9);
{начальные значения первой точки}
i:=1;
x[i]:=1;{по горизонтали}
y[i]:=1;{по вертикали}
z[i]:=8;{возможное число ходов}
stepMix:=65;{максимальное возможное количество ходов}
repeat
case z[i]of
{ все возможные варианты ходов}
8:begin x[i+1]:=x[i]+1; y[i+1]:=y[i]+2;end;
7:begin x[i+1]:=x[i]+2; y[i+1]:=y[i]+1;end;
6:begin x[i+1]:=x[i]+2; y[i+1]:=y[i]-1;end;
5:begin x[i+1]:=x[i]+1; y[i+1]:=y[i]-2;end;
4:begin x[i+1]:=x[i]-1; y[i+1]:=y[i]-2;end;
3:begin x[i+1]:=x[i]-2; y[i+1]:=y[i]-1;end;
2:begin x[i+1]:=x[i]-2; y[i+1]:=y[i]+1;end;
1:begin x[i+1]:=x[i]-1; y[i+1]:=y[i]+2;end;
{эти строчки можно исключить, но безних я не пробывал}
-3,
-2,
-1,
0:begin dec(i);end;
end;
{проверяем совпадение с нужной точкой }
if(x[i+1]=xi)and(y[i+1]=yi)then
begin
if stepMix>=i then
begin
{контрольный вывод всех ходов}
stepMix:=i;
for j:=1 to i+1 do write(x[j]:3);writeln('=':3,i:5);
for j:=1 to i+1 do write(y[j]:3);writeln('=':3,i:5,z[i]:5);
ReadKey;
end;
z[i]:=0;
end;
{провеяем попадание в доску 8х8}
if(x[i+1]>0)and(x[i+1]<9)and(y[i+1]>0)and(y[i+1]<9)and(z[i]>0)then
begin
{проверяем повторную точку}
j:=1;
while(x[j]<>x[i+1])and(y[j]<>y[i+1])do
inc(j);
{уменьшаем количестово ходов для текущей точки}
dec(z[i]);
if z[i]<0 then z[i]:=0;
{если равно, то нет совпадающих координат теперь новая текущая точка}
if j=(i+1) then
begin
inc(i);
z[i]:=8;
end;
end
else
begin
{точка вышла за пределы доски}
dec(z[i]);
if z[i]<0 then z[i]:=0;
end;
{контрольный вывод
writeln(i:5,z[i]:5,stepMix:5);
{цикл коррективки возможных ходов}
while (z[i]<=0)and(i>0) do dec(i);
until i=0;
end.
program treugolnik;
var n,i,j:integer;
begin
write('n=');readln(n);
for i:=1 to n do
begin
for j:=1 to 2*n-1 do
begin
if (j=n-i+1)or(j=n+i-1) then
begin
write('*')
end
else if (i=n)and(j mod 2=1) then
begin
write('*');
end
else write(' ')
end;
writeln;
end;
readln;
end.
Case (зарезервированное слово)
Оператор Case состоит из выражения (селектора) и списка операторов, каждый из которых выполнится в определенном случае.
Синтаксис:
Case выражение Of
вариант : оператор;
...
вариант : оператор;
End
или
Case выражение Of
вариант : оператор;
...
вариант : оператор;
Else оператор
End
Замечания:
"вариант" состоит из одной или большего количества констант или диапазонов, разделенных запятыми.
Часть "Else" является необязательной.
if <вариант>
then <оператор>
else if <вариант>
then <оператор>
else if <вариант>
then <оператор>
else <оператор>;
uses crt;
const s:array[1..12] of byte=(3,4,7,3,2,8,9,3,5,1,5,0);
var i,k,j:integer;
a:array[1..20]of integer;
begin
clrscr;
for i:=1 to 12 do
write(s[i],' ');
writeln;
i:=1;k:=0;
while s[i]<>0 do
begin
k:=k+1;
for j:=i+1 to i+s[i] do
a[k]:=a[k]*10+s[j];
i:=i+s[i]+1;
end;
writeln;
writeln('k=',k);
for i:=1 to k do
write(a[i],' ');
readln
end.
const s:array[1..12] of byte=(3,4,7,3,2,8,9,3,5,1,5,0);
проверяем совпадение с нужной точкой }
if(x[i+1]=xi)and(y[i+1]=yi)then
begin
if stepMix>=i then
begin
{контрольный вывод всех ходов}
stepMix:=i;
for j:=1 to i+1 do write(x[j]:3);writeln('=':3,i:5);
for j:=1 to i+1 do write(y[j]:3);writeln('=':3,i:5,z[i]:5);
ReadKey;
end;
z[i]:=0;
end;
Var
i, j, s, n: Integer;
t, x: Array[1..100] Of Integer;
Procedure ReadData;
Begin
ReadLn(n);
End;
Procedure OverWrite;
Begin
For j := 1 To s Do
Begin
t[j] := x[j];
End;
End;
Procedure WriteData;
Begin
For j := 1 To s Do
Begin
Write(x[j], ' ');
End;
End;
Begin
ReadData;
s := 1;
For i := 1 To n Do
Begin
OverWrite;
WriteData;
For j := 1 To s-1 Do
Begin
If (j <> 1) Then
Begin
x[j] := t[j-1] + t[j];
End;
End;
x[s] := 1;
WriteLn;
End;
ReadLn;
End.
var n,i,j:integer;
{рекурсивная функция}
function F(x,y:integer):integer;
begin
{условие выхода из рекурсии}
if (x=1)or(y=1)then F:=1
{получаем следующий элемент}
else F:=F(x-1,y)+F(x,y-1);
end;
begin
{вводим число}
repeat
write('Enter N:');
readln(n);
until n>0;
{цикл по строкам}
for i:=1 to n do
begin
{цикл в строке}
for j:=1 to i do write(F(j,i-j+1):3);
writeln;
end;
end.
Var
i, j, s, n: Integer;
t, x: Array[1..100] Of Integer;
Procedure ReadData;
Begin
ReadLn(n);
End;
Procedure OverWrite;
Begin
For j := 1 To s Do
Begin
t[j] := x[j];
End;
End;
Procedure WriteData;
Begin
For j := 1 To s Do
Begin
Write(x[j], ' ');
End;
End;
Begin
ReadData;
s := 1;
For i := 1 To n+1 Do
Begin
OverWrite;
WriteData;
For j := 1 To s Do
Begin
If (j <> 1) Then
Begin
x[j] := t[j-1] + t[j];
End;
End;
x[s] := 1;
WriteLn;
Inc(s);
End;
ReadLn;
End.
Var
a, b, i, k1, k2, ans: Integer;
Procedure ReadData;
Begin
ReadLn(a, b);
End;
Procedure WriteData;
Begin
WriteLn(ans);
ReadLn;
End;
Function Check(i: Integer): Boolean;
Var
j, k, t: Integer;
res: Boolean;
x: Array[1..5] Of Integer;
Begin
j := 1;
While (i <> 0) Do
Begin
x[j] := i Mod 10;
Inc(j);
i := i Div 10;
End;
For j := 1 To 4 Do
Begin
For k := 1 To 4 Do
Begin
If (x[j] > x[j+1]) Then
Begin
t := x[k];
x[k] := x[k+1];
x[k+1] := t;
End;
End;
End;
For j := 1 To 4 Do
Begin
If (x[j] = x[j+1]) Then
Begin
res := TRUE;
End;
End;
Check := res;
End;
Begin
ReadData;
For i := a To b Do
Begin
Inc(k1);
If (Check(i)) Then
Begin
Inc(k2);
End;
End;
ans := k1-k2;
WriteData;
End.
uses crt;
Var i, j, s, n: Integer;
t, x: Array[1..100] Of Integer;
Procedure ReadData;
Begin
write('Vvedite razmer treugolnika n=');
ReadLn(n);
End;
Procedure OverWrite;
Begin
For j := 1 To s Do
t[j] := x[j];
End;
Procedure WriteData;
Begin
For j := 1 To s-1 Do
Write(x[j], ' ');
end;
Begin
clrscr;
ReadData;
s := 1;
For i := 0 To n+1 Do
Begin
OverWrite;
WriteData;
For j := 1 To s Do
x[j] := t[j-1] + t[j];
x[1]:=1;
x[s]:=1;
WriteLn;
Inc(s);
End;
ReadLn;
End.
Var
i, j, s, n: Integer;
t, x: Array[1..100] Of Integer;
Procedure ReadData;
Begin
ReadLn(n);
End;
Procedure OverWrite;
Begin
For j := 1 To s Do
Begin
t[j] := x[j];
End;
End;
Procedure WriteData;
Begin
For j := 1 To s-1 Do
Begin
Write(x[j], ' ');
End;
End;
Begin
ReadData;
s := 1;
x[1] := 1;
For i := 1 To n+1 Do
Begin
OverWrite;
WriteData;
For j := 1 To s Do
Begin
If (j <> 1) Then
Begin
x[j] := t[j-1] + t[j];
End;
End;
x[s] := 1;
If (i <> 1) Then
Begin
WriteLn;
End;
Inc(s);
End;
ReadLn;
End.
Если Вы уже зарегистрированы на Портале - войдите в систему, если Вы еще не регистрировались - пройдите простую процедуру регистрации.