Форум программистов

Информация о пользователе

Привет, Гость! Войдите или зарегистрируйтесь.


Вы здесь » Форум программистов » Форум программистов » Программы


Программы

Сообщений 1 страница 13 из 13

1

Проблемы

Программа поздравления с Новым Годом. Языков программирования - Паскаль.

uses graphabc;
var x,y,i,j,n,dn,r:Integer;
co:color;
begin
r:=10;
x:=r;
y:=r;
n:=5;

dn:=192;
for j:=1 to 12 do begin
for i:=1 to 3072 do begin
setpencolor(clWhite);
setbrushcolor(clgreen);
if (i=1038+n) or (i=1039+n) or (i=1040+n) or (i=1041+n) or (i=1042+n) or (i=1043+n) or (i=1046+n) or (i=1047+n) or (i=1048+n) or (i=1049+n) or (i=1050+n) or (i=1051+n) or (i=1054+n) or (i=1055+n) or (i=1058+n) or (i=1059+n) or (i=1060+n) or (i=1061+n) or (i=1062+n) or (i=1063+n) or (i=1102+n) or (i=1103+n) or (i=1104+n) or (i=1105+n) or (i=1106+n) or (i=1107+n) or (i=1110+n) or (i=1111+n) or (i=1112+n) or (i=1113+n) or (i=1114+n) or (i=1115+n) or (i=1118+n) or (i=1119+n) or (i=1122+n) or (i=1123+n) or (i=1124+n) or (i=1125+n) or (i=1126+n) or (i=1127+n) or (i=1170+n) or (i=1171+n) or (i=1174+n) or (i=1175+n) or (i=1178+n) or (i=1179+n) or (i=1182+n) or (i=1183+n) or (i=1186+n) or (i=1187+n) or (i=1234+n) or (i=1235+n) or (i=1238+n) or (i=1239+n) or (i=1242+n) or (i=1243+n) or (i=1246+n) or (i=1247+n) or (i=1250+n) or (i=1251+n) or (i=1294+n) or (i=1295+n) or (i=1296+n) or (i=1297+n) or (i=1298+n) or (i=1299+n)  or (i=1302+n) or (i=1303+n) or (i=1306+n) or (i=1307+n) or (i=1310+n) or (i=1311+n) or (i=1314+n) or (i=1315+n) or (i=1316+n) or (i=1317+n) or (i=1318+n) or (i=1319+n) or (i=1358+n)  or (i=1359+n)  or (i=1360+n)  or (i=1361+n)  or (i=1362+n)  or (i=1363+n) or (i=1366+n) or (i=1367+n)  or (i=1374+n) or (i=1375+n)  or (i=1378+n)  or (i=1379+n)  or (i=1380+n)  or (i=1381+n)  or (i=1382+n)  or (i=1383+n)  or (i=1422+n)  or (i=1423+n) or (i=1430+n) or (i=1431+n) or (i=1434+n) or (i=1435+n) or (i=1438+n) or (i=1439+n)  or (i=1446+n) or (i=1447+n) or (i=1486+n) or (i=1487+n) or (i=1494+n) or (i=1495+n) or (i=1498+n) or (i=1499+n) or (i=1502+n) or (i=1503+n) or  (i=1510+n) or (i=1511+n) or (i=1550+n) or (i=1551+n) or (i=1552+n) or (i=1553+n) or (i=1554+n) or (i=1555+n) or (i=1558+n) or (i=1559+n) or (i=1560+n) or (i=1561+n) or (i=1562+n) or (i=1563+n) or (i=1566+n) or (i=1567+n) or (i=1570+n) or (i=1571+n) or (i=1572+n) or (i=1573+n) or (i=1574+n) or (i=1575+n) or (i=1614+n)or (i=1615+n) or (i=1616+n) or (i=1617+n) or (i=1618+n) or (i=1619+n) or (i=1622+n) or (i=1623+n) or (i=1624+n) or (i=1625+n) or (i=1626+n) or (i=1627+n) or (i=1627+n) or (i=1630+n) or (i=1631+n) or (i=1634+n) or (i=1635+n) or (i=1636+n) or (i=1637+n) or (i=1638+n) or (i=1639+n)or (i=1370+n) or (i=1371+n) then setbrushcolor(clblack);
if x=660-r then begin x:=r; y:=y+r; end;
if (y=500-r)then begin y:=r; x:=r;  end;
Circle(x,y,r);
x:=x+r;
end;
n:=n+192;
end;

n:=-955;
dn:=192;
for j:=1 to 1000 do begin
co:=clrandom;
for i:=1 to 3072 do begin
setpencolor(clWhite);
if i mod 5 = 0 then setbrushcolor(clred);
if i mod 5 = 1 then setbrushcolor(clgreen);
if i mod 5 = 2 then setbrushcolor(clblue);
if i mod 5 = 3 then setbrushcolor(clyellow);
if i mod 5 = 4 then setbrushcolor(clorange);
if (i=1038+n) or (i=1039+n) or (i=1040+n) or (i=1041+n) or (i=1042+n) or (i=1043+n) or (i=1046+n) or (i=1047+n) or (i=1048+n) or (i=1049+n) or (i=1050+n) or (i=1051+n) or (i=1054+n) or (i=1055+n) or (i=1058+n) or (i=1059+n) or (i=1060+n) or (i=1061+n) or (i=1062+n) or (i=1063+n) or (i=1102+n) or (i=1103+n) or (i=1104+n) or (i=1105+n) or (i=1106+n) or (i=1107+n) or (i=1110+n) or (i=1111+n) or (i=1112+n) or (i=1113+n) or (i=1114+n) or (i=1115+n) or (i=1118+n) or (i=1119+n) or (i=1122+n) or (i=1123+n) or (i=1124+n) or (i=1125+n) or (i=1126+n) or (i=1127+n) or (i=1170+n) or (i=1171+n) or (i=1174+n) or (i=1175+n) or (i=1178+n) or (i=1179+n) or (i=1182+n) or (i=1183+n) or (i=1186+n) or (i=1187+n) or (i=1234+n) or (i=1235+n) or (i=1238+n) or (i=1239+n) or (i=1242+n) or (i=1243+n) or (i=1246+n) or (i=1247+n) or (i=1250+n) or (i=1251+n) or (i=1294+n) or (i=1295+n) or (i=1296+n) or (i=1297+n) or (i=1298+n) or (i=1299+n)
or (i=1302+n) or (i=1303+n) or (i=1306+n) or (i=1307+n) or (i=1310+n) or (i=1311+n) or (i=1314+n) or (i=1315+n) or (i=1316+n) or (i=1317+n) or (i=1318+n) or (i=1319+n) or (i=1358+n)  or (i=1359+n)  or (i=1360+n)  or (i=1361+n)  or (i=1362+n)  or (i=1363+n) or (i=1366+n) or (i=1367+n)  or (i=1374+n) or (i=1375+n)  or (i=1378+n)  or (i=1379+n)  or (i=1380+n)  or (i=1381+n)  or (i=1382+n)  or (i=1383+n)  or (i=1422+n)  or (i=1423+n) or (i=1430+n) or (i=1431+n) or (i=1434+n) or (i=1435+n) or (i=1438+n) or (i=1439+n) or (i=1442+n) or (i=1443+n) or (i=1446+n) or (i=1447+n) or (i=1486+n) or (i=1487+n) or (i=1494+n) or (i=1495+n) or (i=1498+n) or (i=1499+n) or (i=1502+n) or (i=1503+n) or (i=1506+n) or (i=1507+n) or (i=1510+n) or (i=1511+n) or (i=1550+n) or (i=1551+n) or (i=1552+n) or (i=1553+n) or (i=1554+n) or (i=1555+n) or (i=1558+n) or (i=1559+n) or (i=1560+n) or (i=1561+n) or (i=1562+n) or (i=1563+n) or (i=1566+n)
or (i=1567+n) or (i=1570+n) or (i=1571+n) or (i=1572+n) or (i=1573+n) or (i=1574+n) or (i=1575+n) or (i=1614+n)or (i=1615+n) or (i=1616+n) or (i=1617+n) or (i=1618+n) or (i=1619+n) or (i=1622+n) or (i=1623+n) or (i=1624+n) or (i=1625+n) or (i=1626+n) or (i=1627+n) or (i=1627+n) or (i=1630+n) or (i=1631+n) or (i=1634+n) or (i=1635+n) or (i=1636+n) or (i=1637+n) or (i=1638+n) or (i=1639+n)or (i=1370+n) or (i=1371+n) then setbrushcolor(co);
if x=660-r then begin x:=r; y:=y+r; end;
if (y=500-r)then begin y:=r; x:=r;  end;
Circle(x,y,r);
x:=x+r;
end;
if n=1349 then dn:=-192;
if n=-955 then dn:=192;
n:=n+dn;
end;
end.

+2

2

Программа решения квадратного уравнения. Программа  проверяет правильность исходных данных и в случае, когда коэффициент при второй степени неизвестного равен нулю, выводить соответствующее сообщение.
uses  crt;

var
  a, b, c, d, x1, x2: real;

begin
  textbackground(9);
  clrscr;
  write('Введите коэффициент A '); readln(a);
  write('Введите коэффициент B '); readln(b);
  write('Введите коэффициент C '); readln(c);
  write('Уравнение:', a, 'x2+', b); writeln('x+', c, '=0');
  D := (b * b) - (4 * a * c);
  if (a = b) and (b = c) and (c = 0)
    then
    writeln('Корней бесчисленное множество')
  else
  if (a = b) and (b = 0) and (c <> 0)
    then
    writeln('Уравнение корней не имеет')
  else
  if d = 0
  then
  begin
    writeln('Уравнение имеет два одинаковых корня');
    writeln('x1=x2=', -b / (2 * a):0:2);
  end
  else
  if a = 0
  then begin
    writeln('Линейное уравнение, имеет один корень');
    writeln('x=', (-c / b));
  end
  else
  if d < 0
    then
    writeln('Нет решений, т.к. D<0')
  else
  begin
    x1 := (-b + sqrt(d)) / (2 * a);
    x2 := (-b - sqrt(d)) / (2 * a);
    writeln('Первый корень, x1=', x1);
    writeln('Второй корень, x2=', x2);
  end;
end.

0

3

Пример программы поиска в языке программирования pascal, работа с файлами (подсчитывает количество найденных результатов).

Var k,n,d:integer;
x,y:string;
f1,f2:text;
begin
assign(f1,'input.txt');
assign(f2,'output.txt');
reset(f1);
rewrite(f2);
readln(f1,x);
d:=0;
while not eof(f1) do begin
readln(f1,y);
k:=length(y);
while y<>'' do begin
n:=pos(x,y);
if n>0 then begin
d:=d+1;
delete(y,1,n);
end;
if n=0 then delete(y,1,k);
end
end;
writeln(f2,d);
close(f2);
close(f1);
end.

0

4

Образец для обработки матриц (двумерных динамических массивов).

#include <iostream>
//#include <clocale>
using namespace std;
//----- объявление прототипов используемых функций-----------------
int** Create(int n,int m);           // создание матрицы n строк m столбцов
void Free(int** M,int n);             // освобождение матрицы
void Input(int** M,int n,int m);   // ввод матрицы
void Print(int** M,int n,int m);     // вывод матрицы
//--------------------------------------------------------------------------
void Work(int** M,int n,int m);    // обработка матрицы
//   Сюда добавить протопипы тех функций которые дополнительно напишете
//--------------------------------------------------------------------------

//----------  main() -  точка входа в программу консольного приложения
int main()
{
    //setlocale(LC_ALL,"Rus");
    int n,m;
    cout<<"Количество строк матрицы:?";
    cin>>n;
    cout<<"Количество столбцов матрицы:?";
    cin>>m;
    int** A=Create(n,m);
    Input(A,n,m);
    Work(A,n,m);
    Free(A,n);
    //system("pause");
    return 0;
}

//----   описание функций -----------------------------------------
int** Create(int n,int m)
{
    int** M=new int*[n];
    for(int i=0;i<n;i++)
    {
        M[i]=new int[m];
    }
    return M;
}
//----------------------------
void Free(int** M,int n)
{
    for(int i=0;i<n;i++)
        delete[] M[i];
    delete[] M;
}
//----------------------------
void Input(int** M,int n,int m)
{
    for(int i=0;i<n;i++)
    {
        for(int j=0;j<m;j++)
        {
            cout<<"M["<<i<<"]["<<j<<"]=?";
            cin >> M[i][j];
        }
   
    }
}
//----------------------------
void Print(int** M,int n,int m)
{
    for(int i=0;i<n;i++)
    {
        for(int j=0;j<m;j++)
        {
            cout << M[i][j] << " ";
        }
        cout << endl;
    }
}
// пример обработки - подсчет сумм в каждой строке
void Work(int** M,int n,int m)
{
    for(int i=0;i<n;i++)
    {
        int sum=0;
        for(int j=0;j<m;j++)
        {
             sum+=M[i][j];
        }
        cout<<i<<" sum = " << sum<< endl;
    }
}
// сюда вставить все дополнительные функции которые напишете

0

5

Игра пятнашки Pascal

  Result:=True;
  i:=1;
  for y:=1 to n do
  for x:=1 to n do
  begin
    if p[y,x].Number<>i then
    begin
      Result:=False;
      break;
    end;
    Inc(i);
    if i=n*n then i:=0;
  end;
end;

procedure MouseDown(x,y,mb: integer);
begin
  if EndOfGame then // Если все фишки на своих местах, то не реагировать на мышь и ждать нажатия кнопки "Перемешать"
    exit;
  if ObjectUnderPoint(x,y)=nil then // Eсли мы щелкнули не на объекте, то не реагировать на мышь
    exit;
  var fx := (x-x0) div (sz+zz) + 1; // Вычислить координаты на доске для ячейки, на которой мы щелкнули мышью
  var fy := (y-y0) div (sz+zz) + 1;
  if (fx>n) or (fy>n) then
    exit;
  if Sosedi(fx,fy,EmptyCellX,EmptyCellY) then // Если ячейка соседствует с пустой, то поменять их местами
  begin
    Swap(p[EmptyCellY,EmptyCellX],p[fy,fx]);
    EmptyCellX := fx;
    EmptyCellY := fy;
    Inc(MovesCount);
    StatusRect.Text := 'Количество ходов: ' + IntToStr(MovesCount);
    if IsSolution then
    begin
      StatusRect.Text := 'Победа! Сделано ходов: ' + IntToStr(MovesCount);
      StatusRect.Color := RGB(255,200,200);
      EndOfGame := True;
    end
  end;
end;

begin
  SetSmoothingOff;
  Window.Title := 'Игра в 15';
  Window.IsFixedSize := True;
  SetWindowSize(2*x0+(sz+zz)*n-zz,2*y0+(sz+zz)*n-zz+90);
 
  EndOfGame := False;
  Create15;

  MeshButton := ButtonABC.Create((WindowWidth-200) div 2,2*y0+(sz+zz)*n-zz,200,'Перемешать',clLightGray);
  MeshButton.OnClick := Mesh15;
  StatusRect := new RectangleABC(0,WindowHeight-40,WindowWidth,40,RGB(200,200,255));
  StatusRect.TextVisible := True;
  StatusRect.Text := 'Количество ходов: '+IntToStr(MovesCount);
  StatusRect.BorderWidth := 2;
  StatusRect.BorderColor := RGB(80,80,255);

  MovesCount := 0;

  OnMouseDown := MouseDown;
end.

0

6

Почему некоторые программы выдают ошибку выполнения?

Отредактировано Ваня Козаченко (2016-03-23 00:55:30)

0

7

Скорее всего у вас не установление нужные модули (CRT, GRAPH).

0

8

Игра Жизнь

uses Utils,GraphABC;

const
  w =3;
  w1=1;
  k=20;
  m=300;
  n=220;
  graphW=0;
  mk=m div k;//15;
  nk=n div k;//10;
  mm=m+1;
  nn=n+1;
  x0=1;
  y0=21;
  ClearColor=clBlack;
  FillColor=clLimeGreen;
  FiledColor=RGB(0,40,0);
  FiledColor2=RGB(0,70,0);{}
  {ClearColor=clWhite;
  FillColor=clBlack;
  FiledColor=clLightGray;
  FiledColor2=clGray;{}
 

var
  //a,b,sosedia,sosedib: array [0..nn,0..mm] of byte;
  a,b,sosedia,sosedib:array of array of byte;
  //obnovA,obnovB: array [1..nk,1..mk] of boolean;
  obnovA,obnovB: array of array of boolean;
  count: integer;
  obn: boolean;
  mil,mil1: integer;
  hn,hm: integer;

procedure AssignArray(var arr:array of array of boolean; n,m:integer);
begin
  SetLength(arr,n);
  for var i:=0 to n-1 do
    SetLength(arr[i],m);
end;
procedure AssignArray(var arr:array of array of byte; n,m:integer);
begin
  SetLength(arr,n);
  for var i:=0 to n-1 do
    SetLength(arr[i],m);
end;
procedure CopyArray(arr1,arr2:array of array of byte);
begin
  for var i:=0 to arr1.Length-1 do
    arr1[i].CopyTo(arr2[i],0);
end;
procedure CopyArray(arr1,arr2:array of array of boolean);
begin
  for var i:=0 to arr1.Length-1 do
    arr1[i].CopyTo(arr2[i],0);
end;

procedure DrawCell(i,j: integer);
begin
  if BrushColor<>FillColor then begin
    SetBrushColor(FillColor);
    SetPenColor(FillColor);
  end;
  FillRect(x0+(j-1)*w,y0+(i-1)*w,x0+j*w-w1,y0+i*w-w1);
end;

procedure ClearCell(i,j: integer);
begin
  if BrushColor<>clearColor then begin
    SetBrushColor(clearColor);
    SetPenColor(clearColor);
  end;
  FillRect(x0+(j-1)*w,y0+(i-1)*w,x0+j*w-w1,y0+i*w-w1);
end;

procedure DrawConfiguration;
begin
  for var i:=1 to n do
    for var j:=1 to m do
      if a[i,j]=1 then
        DrawCell(i,j)
end;

procedure DrawField;
begin
  SetBrushColor(ClearColor);
  FillRectangle(x0,y0,x0+m*w,y0+n*w);
  SetPenColor(FiledColor);
  for var i:=0 to m do
    Line(x0+i*w-1,y0,x0+i*w-1,y0+n*w);
  for var i:=0 to n do
    Line(x0,y0+i*w-1,x0+m*w,y0+i*w-1);
  SetPenColor(FiledColor2);
  for var i:=0 to m div hm do
    Line(x0+i*w*hm-1,y0,x0+i*w*hm-1,y0+n*w);
  for var i:=0 to n div hn do
    Line(x0,y0+i*w*hn-1,x0+m*w,y0+i*w*hn-1);   
end;

procedure IncSosedi(i,j: integer);
begin
  var i1 := i=1 ? n : i-1;
  var i2 := i=n ? 1 : i+1;
  var j1 := j=1 ? m : j-1;
  var j2 := j=m ? 1 : j+1;
  SosediB[i1,j1] += 1;
  SosediB[i1,j]  += 1;
  SosediB[i1,j2] += 1;
  SosediB[i,j1]  += 1;
  SosediB[i,j2]  += 1;
  SosediB[i2,j1] += 1;
  SosediB[i2,j]  += 1;
  SosediB[i2,j2] += 1;
end;

procedure DecSosedi(i,j: integer);
begin
  var i1 := i=1 ? n : i-1;
  var i2 := i=n ? 1 : i+1;
  var j1 := j=1 ? m : j-1;
  var j2 := j=m ? 1 : j+1;
  SosediB[i1,j1] -= 1;
  SosediB[i1,j]  -= 1;
  SosediB[i1,j2] -= 1;
  SosediB[i,j1]  -= 1;
  SosediB[i,j2]  -= 1;
  SosediB[i2,j1] -= 1;
  SosediB[i2,j]  -= 1;
  SosediB[i2,j2] -= 1;
end;

procedure SetCell(i,j: integer);
begin
  if b[i,j]=0 then
  begin
    b[i,j]:=1;
    obn:=true;
    IncSosedi(i,j);
  end;
  count += 1;
end;

procedure UnSetCell(i,j: integer);
begin
  if b[i,j]=1 then
  begin
    b[i,j]:=0;
    obn:=true;
    DecSosedi(i,j);
  end;
  count -= 1;
end;

type
  ColonyType = (Big, LD, RD, LU, RU);
procedure AddColonyType(xc,yc:integer; ctype:ColonyType);
begin
case ctype of
    ColonyType.Big:begin
      SetCell(xc,yc);
      SetCell(xc,yc+1);
      SetCell(xc,yc+2);
      SetCell(xc-1,yc+2);
      SetCell(xc+1,yc+1);
    end;
    ColonyType.LD:begin
      SetCell(xc,yc-1);
      SetCell(xc,yc);
      SetCell(xc,yc+1);
      SetCell(xc-1,yc-1);
      SetCell(xc-2,yc);     
    end;
  end;
  //SosediA:=SosediB;
  CopyArray(sosedib,sosedia);
  for var ik:=1 to nk do
    for var jk:=1 to mk do
      obnovB[ik,jk]:=true;
  //obnovA:=obnovB;
  CopyArray(obnovB,obnovA);
end;

procedure Init;
begin
  Count:=0;
  AddColonyType(n div 2,m div 2, ColonyType.Big);
end;

procedure OnlyCase(i,j: integer);
begin
case SosediA[i,j] of
0..1,4..9:
    if b[i,j]=1 then
    begin
      b[i,j]:=0;
      obn:=true;
      DecSosedi(i,j);
      ClearCell(i,j);
      count -= 1;
    end;
3: if b[i,j]=0 then
    begin
      b[i,j]:=1;
      obn:=true;
      IncSosedi(i,j);
      DrawCell(i,j);
      count += 1;
    end;
  end;
end;

procedure NextGen;
var
  i,j,ik1,jk1,ik2,jk2,ifirst,jfirst,ilast,jlast: integer;
  l,r,u,d,lu,ld,ru,rd: boolean;
begin
    for var ik:=1 to nk do
    begin
      for var jk:=1 to mk do
      begin
        obn := false;
        ifirst := (ik-1)*hn+1;
        ilast  := ik*hn;
        jfirst := (jk-1)*hm+1;
        jlast  := jk*hm;
        if obnovA[ik,jk] then
        begin
          for i:=ifirst to ilast do
            for j:=jfirst to jlast do
              OnlyCase(i,j);
        end
        else
        begin
          ik1 := ik=1 ? nk : ik-1;
          ik2 := ik=nk ? 1 : ik+1;
          jk1 := jk=1 ? mk : jk-1;
          jk2 := jk=mk ? 1 : jk+1;
          l:=obnovA[ik,jk1];
          r:=obnovA[ik,jk2];
          u:=obnovA[ik1,jk];
          d:=obnovA[ik2,jk];
          lu:=obnovA[ik1,jk1];
          ld:=obnovA[ik2,jk1];
          ru:=obnovA[ik1,jk2];
          rd:=obnovA[ik2,jk2];
          if u then
          begin
            i:=ifirst;
            for j:=jfirst+1 to jlast-1 do
              OnlyCase(i,j);
          end;
          if d then
          begin
            i:=ilast;
            for j:=jfirst+1 to jlast-1 do
              OnlyCase(i,j);
          end;
          if l then
          begin
            j:=jfirst;
            for i:=ifirst+1 to ilast-1 do
              OnlyCase(i,j);
          end;
          if r then
          begin
            j:=jlast;
            for i:=ifirst+1 to ilast-1 do
              OnlyCase(i,j);
          end;
          if u or l or lu then
            OnlyCase(ifirst,jfirst);
          if u or r or ru then
            OnlyCase(ifirst,jlast);
          if d or l or ld then
            OnlyCase(ilast,jfirst);
          if d or r or rd then
            OnlyCase(ilast,jlast);
        end;
        obnovB[ik,jk]:=obn;
      end;
    end;
end;

procedure MouseDown(x,y,b:integer);
begin
  case b of
    1:AddColonyType((y-y0)div w,(x-x0)div w, ColonyType.LD);
   
  end;
end;

begin
  SetConsoleIO;
  AssignArray(obnovA,nk+1,mk+1);
  AssignArray(obnovB,nk+1,mk+1);
  AssignArray(a,nn+1,mm+1);
  AssignArray(b,nn+1,mm+1);
  AssignArray(sosedia,nn+1,mm+1);
  AssignArray(sosedib,nn+1,mm+1);
  SetWindowCaption('Игра "Жизнь"');
  if (m mod mk<>0) or (n mod nk<>0) then
  begin
    writeln('Размер кластера не согласован с размером поля. Программа завершена');
    exit
  end;
  hm:=m div mk;
  hn:=n div nk;
  SetBrushColor(ClearColor);
  SetWindowSize(x0+m*w,y0+n*w+graphW);
  CenterWindow;
  ClearWindow(ClearColor);
  SetFontName('Courier New');
  SetFontSize(10);
  Init;
  DrawField;
  DrawConfiguration;
  OnMouseDown:=MouseDown;
  mil:=Milliseconds;
  var gen:=0;
  DrawInBuffer := false;
  while true do begin
    gen+=1;
    //SosediA:=SosediB;
    //obnovA:=obnovB;
    CopyArray(sosedib,sosedia);
    CopyArray(obnovB,obnovA);
    NextGen;   
    if gen mod 10 = 0 then begin
      DrawInBuffer := True;
      SetBrushColor(ClearColor);
      SetFontColor(FillColor);
      TextOut(25, 0,'Поколение: '+IntToStr(gen));
      TextOut(765,0,'Жителей: '+IntToStr(count)+'    ');
      if gen mod 1000 = 0 then begin
        mil1:=Milliseconds;
        writeln(gen,'  ',(mil1-mil)/1000);
        mil:=mil1;
      end;
      DrawInBuffer := false;
    end;
  end;
end.

0

9

Дано натуральное число N>10. Вычислить сумму всех чисел Фибоначчи, которые не превышают N. Числа Фибоначчи образуются по закону: f1 =1, f2 =1, f3 =f1 + f2, fk+1 =fk-1 +fk . C++
21:59:27
#include <stdio.h>

int main()
{
unsigned long f1, f2, t, n, sum;

while (printf("enter a number: ") && scanf("%lu", &n) && n) {
sum = 0;
for (f1 = 0, f2 = 1;
f1 < n;
t = f1, f1 = f2, f2 = f2 + t)
sum += f1;
printf("Sum of fibonacci numbers which "
"less than %lu is %lu\n", n, sum);
}
return 0;
}

+1

10

Сортировка вагонов – B

prb4513   К тупику со стороны пути 1 (см. рисунок) подъехал поезд. Разрешается отцепить от поезда один или сразу несколько первых вагонов и завезти их в тупик (при желании, можно даже завезти в тупик сразу весь поезд). После этого часть из этих вагонов вывезти в сторону пути 2. После этого можно завезти в тупик еще несколько вагонов и снова часть оказавшихся вагонов вывезти в сторону пути 2. И так далее (так, что каждый вагон может лишь один раз заехать с пути 1 в тупик, а затем один раз выехать из тупика на путь 2). Заезжать в тупик с пути 2 или выезжать из тупика на путь 1 запрещается. Нельзя с пути 1 попасть на путь 2, не заезжая в тупик.

Известно, в каком порядке изначально идут вагоны поезда. Требуется с помощью указанных операций сделать так, чтобы вагоны поезда шли по порядку (сначала первый, потом второй и т. д., считая от головы поезда, едущего по пути 2 в сторону от тупика). Напишите программу, определяющую, можно ли это сделать.

Технические условия

Входные данные

Вводится число N — количество вагонов в поезде \left(1\leq N\leq100\right). Дальше идут номера вагонов в порядке от головы поезда, едущего по пути 1 в сторону тупика. Вагоны пронумерованы натуральными числами от 1  до N, каждое из которых встречается ровно один раз.

Выходные данные

Если сделать так, чтобы вагоны шли в порядке от 1  до N, считая от головы поезда, когда поезд поедет по пути 2 из тупика, можно, выведите сообщение YES, если это сделать нельзя, выведите NO.

Код

C++

#include <iostream>
using namespace std;
struct stack{                           //стек
int truck[100];
int length = 0;
int pop (){return truck[--length];}
void push (int x){truck[length++] = x;}
int front () {return truck[length-1];}
int size () {return length;}
}car;
int main() {
int amount_n;
cin >> amount_n;                 //Ввод (количество вагонов)
int n;
int count = 1;
while (cin >> n){                //Цикл (для ввода нового вагона)
    car.push(n);             //заводим в стек новый вагон
    if (n == count){count++; car.pop();} //проверяем, если вагон подходит, то выводим его на путь 2
    while (car.size() > 0){  //т.к. перед подходящим вагоном может стоять следующий подходящий вагон или несколько вагонов ,то пока стек не пуст будем проверять последние вагоны в стеке
    if (car.front() == count){count++; car.pop();} //если вагон подходит выводим на путь 2
    else break;
    }
}

if (car.size() == 0) {cout << "YES" << endl;} //если стек пуст, то все вагоны были выведены на путь 2
else cout << "NO" << endl;

return 0;
}

0

11

Красивый графический эффект

uses GraphABC;

type TByteArray = array of byte;
const frames = 25;
      size   = 250;
      dxy    = size div 2;
      dm     = 2*PI/1024;
      flameh = 4;           
      Light: byte = 255;
     
procedure FillPallete(ColorsTable: array of Color);
begin
  for var i:=0 to 255 do
    if(i<128) then
      ColorsTable[i] := RGB(i,0,i div 2)
    else
      ColorsTable[i] := RedColor(i);
end;

begin 
  //Создаюм буфер экрана
  var ScreenBuffer := new TByteArray[size+1];
  for var i:=0 to size do
    ScreenBuffer[i] := new byte[size+1];
  //Создаем палитру
  var ColorsTable := new Color[256];
  FillPallete(ColorsTable);
  //Настраиваем окно
  SetWindowSize(size,size);
  SetBrushColor(clBlack);
  FillRectangle(0,0,WindowWidth,WindowHeight);
  SetSmoothingOff;
  LockDrawing;
  //Поехали
  var x, y, s, tt, xx, yy: Integer;
  var dt := System.DateTime.Now;
  var ds := WindowWidth div 4;
  repeat
    tt := tt + 1;
    xx := dxy + Round(ds*Sin(tt*dm));
    yy := dxy + Round(ds*Cos(tt*dm));
    ScreenBuffer[xx,yy] := Light;
    SetPixel(xx,yy,ColorsTable[Light]);
    for var i:=0 to 5 do begin
      x := Random(size-1) + 1;
      y := Random(size-1) + 1;
      s := ScreenBuffer[Y,X];
      if s>=flameh then
        s := s - flameh;
      if s=0 then
        continue;
      ScreenBuffer[y-1,x+1] := s;
      ScreenBuffer[y-1,x  ] := s;
      ScreenBuffer[y-1,x-1] := s;
      ScreenBuffer[y+1,x  ] := s;
      var c := ColorsTable[s];
      SetPixel(y-1,x+1,c);
      SetPixel(y-1,x,  c);
      SetPixel(y-1,x-1,c);
      SetPixel(y+1,x,  c);
    end;
    if((system.datetime.Now-dt).TotalMilliseconds>1000/frames) then begin
      dt := System.Datetime.Now;
      Redraw;
    end;
  until False;
end.

0

12

// Клонирование графических объектов
uses ABCObjects,GraphABC;

var bt: TextABC;
 
begin
  var x := 224;
  bt := new TextABC(60,110,110,'Привет!',RGB(x,x,x));
  while x>32 do
  begin
    Sleep(40);
    x -= 32;
    bt := bt.Clone;
    bt.Color := RGB(x,x,x);
    bt.MoveOn(7,7);
  end;
end.

0

13

Игра Kill Them

uses ABCObjects,GraphABC,Timers;

const
  clPlayer = Color.BurlyWood;

var
  kLeftKey,kRightKey: boolean;
  kSpaceKey: integer;
  /// Игрок
  Player: RectangleABC;
  /// Таймер движения врагов
  t: Timer;
  /// Флаг конца игры
  EndOfGame: boolean;
  /// Количество неигровых объектов
  StaticObjectsCount: integer;
  /// Счетчик выигрышей
  Wins: integer;
  /// Счетчик проигрышей
  Falls: integer;
  /// Информационная строка
  InfoString: RectangleABC;
  /// Сообщение в начале игры
  NewGame: RoundRectABC;

type
  KeysType = (kLeft,kRight);
 
  /// Класс пули
  Pulya = class(CircleABC)
  public
    constructor Create(x,y: integer);
    procedure Move; override;
  end;
 
  /// Класс врага
  Enemy = class(RectangleABC)
  public
    constructor Create(x,y,w: integer);
    procedure Move; override;
  end;

constructor Pulya.Create(x,y: integer);
begin
  inherited Create(x,y,5,clRed);
  dx := 0;
  dy := -5;
end;

procedure Pulya.Move;
begin
  inherited Move;
  if Top<0 then
    Visible := False;
  for var j:=StaticObjectsCount to Objects.Count-1 do
    // При столкновении пуля и объект становятся невидимыми
    if (Objects[j]<>Self) and Intersect(Objects[j]) then
    begin
      Objects[j].Visible := False;
      Visible := False;
    end;
end;

constructor Enemy.Create(x,y,w: integer);
begin
  inherited Create(x,y,w,20,clRandom);
  if Random(2)=0 then
    dx := 5
  else dx := -5;
  dy := 0;
end;

procedure Enemy.Move;
begin
  if Random(2)<>0 then
    Exit;
  if Random(10)=0 then
    dy := 5;
  if (Left<0) or (Left+Width>Window.Width) or (Random(30)=0) then
    dx := -dx;
  inherited Move;
  if dy<>0 then
    dy := 0;
  if Top>Window.Height-50 then
    EndOfGame := True;
end;

/// Количество врагов
function NumberOfEnemies: integer;
begin
  Result := 0;
  for var i:=0 to Objects.Count-1 do
    if Objects[i] is Enemy then
      Result += 1;
end;

/// Создание игрока и врагов
procedure CreateObjects;
begin
  Player := new RectangleABC(280,WindowHeight-30,100,20,clPlayer);
  for var i:=1 to 100 do
  begin
    var r1 := new Enemy(Random(WindowWidth-50),40+Random(10),50);
    r1.TextVisible := True;
    r1.Number := i;
  end;
end;

/// Разрушение игрока и врагов
procedure DestroyObjects;
begin
  for var i:=Objects.Count-1 downto StaticObjectsCount do
    Objects[i].Destroy;
end;

/// Перемещение врагов
procedure MoveObjects;
begin
  for var i:=StaticObjectsCount+1 to Objects.Count-1 do
    Objects[i].Move;
end;

/// Удаление уничтоженных объектов
procedure DestroyKilledObjects;
begin
  for var i:=ObjectsCount-1 downto StaticObjectsCount+1 do
    if not Objects[i].Visible then
      Objects[i].Destroy;
end;

/// Обработчик нажатия клавиши
procedure KeyDown(Key: integer);
begin
  case Key of
vk_Left:  kLeftKey := True;
vk_Right: kRightKey := True;
vk_Space: if kSpaceKey=2 then kSpaceKey := 1;
  end;
end;

/// Обработчик отжатия клавиши
procedure KeyUp(Key: integer);
begin
  case Key of
vk_Left:  kLeftKey := False;
vk_Right: kRightKey := False;
vk_Space: kSpaceKey := 2;
  end;
end;

/// Изменение информационной строки
procedure ChangeInfoString;
begin
  InfoString.Text := 'Врагов: '+IntToStr(NumberOfEnemies)+'      Побед: '+IntToStr(Wins)+'      Поражений: '+IntToStr(Falls);
end;

/// Обработчик нажатия символьной клавиши
procedure KeyPress(Key: char);
begin
  if (Key in ['G','П','g','п']) and EndOfGame then
  begin
    NewGame.Visible := False;
    EndOfGame := False;
    t.Start;
    CreateObjects;
    kSpaceKey := 2;
    kLeftKey := False;
    kRightKey := False;
  end;
end;

/// Обработчик отжатия мыши
procedure MouseUp(x,y,mb: integer);
begin
  if NewGame.PTInside(x,y) then
    KeyPress('G');
end;

/// Обработчик таймера
procedure TimerProc;
begin
  if kLeftKey and (Player.Left>0) then
    Player.MoveOn(-10,0);
  if kRightKey and (Player.Left+Player.Width<WindowWidth) then
    Player.MoveOn(10,0);
  if kSpaceKey=1 then
  begin
    new Pulya(Player.Left+Player.Width div 2,Player.Top-10);
    kSpaceKey := 0;
  end;
  MoveObjects;
  DestroyKilledObjects;
  RedrawObjects;
  ChangeInfoString;
  var n := NumberOfEnemies;
  // Страховка от случая, когда процедура таймера выполняется одновременно в нескольких потоках
  if n=0 then
    EndOfGame := True;
  if EndOfGame then
  begin
    if t.Enabled=False then Exit; 
    t.Stop;
    if n>0 then
      Falls += 1
    else Wins += 1;
    NewGame.Visible := True;
    DestroyObjects;
    ChangeInfoString;
    RedrawObjects;
  end;
end;

begin
  Window.Title := 'Стрелялка';
  Window.IsFixedSize := True;
  ClearWindow(clBlack);
  LockDrawingObjects;
  EndOfGame := True;
  InfoString := new RectangleABC(0,0,Window.Width,38,Color.DarkBlue);
  InfoString.Bordered := False;
  InfoString.FontColor := clWhite;
  InfoString.TextScale := 0.9;
 
  var zz := 100;
  NewGame := new RoundRectABC(zz,200,400,200,30,Color.Violet);
  NewGame.Center := Window.Center;
  NewGame.Text := 'G - Новая игра';
  StaticObjectsCount := Objects.Count;
  ChangeInfoString;
  RedrawObjects;

  OnKeyDown := KeyDown;
  OnKeyPress := KeyPress;
  OnKeyUp := KeyUp;
  OnMouseUp := MouseUp;

  t := new Timer(1,TimerProc);
end.

0


Вы здесь » Форум программистов » Форум программистов » Программы


Рейтинг форумов | Создать форум бесплатно © 2007–2017 «QuadroSystems» LLC