IPB
ЛогинПароль:

> Прочтите прежде чем задавать вопрос!

1. Заголовок темы должен быть информативным. В противном случае тема удаляется ...
2. Все тексты программ должны помещаться в теги [code=pas] ... [/code], либо быть опубликованы на нашем PasteBin в режиме вечного хранения.
3. Прежде чем задавать вопрос, см. "FAQ", если там не нашли ответа, воспользуйтесь ПОИСКОМ, возможно такую задачу уже решали!
4. Не предлагайте свои решения на других языках, кроме Паскаля (исключение - только с согласия модератора).
5. НЕ используйте форум для личного общения, все что не относится к обсуждению темы - на PM!
6. Одна тема - один вопрос (задача)
7. Проверяйте программы перед тем, как разместить их на форуме!!!
8. Спрашивайте и отвечайте четко и по существу!!!

 
 Ответить  Открыть новую тему 
> Может кому интересно...
сообщение
Сообщение #1


Пионер
**

Группа: Пользователи
Сообщений: 101
Пол: Мужской

Репутация: -  0  +


Нашел тут в своей файлопомойке несколько лаб... может быть кому нужны...
На лаконичность кода ЭТО не претендует... Если чего еще найду - закину

1:
Код

{Из элементов массива A(2n) получить массивы B(n) и C(n) следующим образом.
Выбрать в массиве A два наиболее близких по значению элемента;
меньший из них поместить в массив B, а больший в массив C.
Продолжить выбор из оставшихся элементов до полного заполнения массивом B и C.}

{$R-}

program Neighbours;

type arr1=array[1..1] of integer;
    arr1Pointer=^arr1;

var dynArray, small1, small2: arr1Pointer;
counter, k, m: integer;
{ counter - вводимое количество элементов массива
 k - число элементов малого массива
 m - номер элемента, удаляемого процедурой delElem }

procedure CreateMainArr(var counter:integer); {создание основного динамического массива и заполнение его числами}
var i, j: integer;
begin
  repeat
     write('Введите чётное число элементов массива: '); {размер массива}
     readln(counter);
  until (counter mod 2)=0; {число элементов массива должно быть четным}
  getMem(dynArray,counter*sizeOf(integer));
  writeln('Значение любого элемента не должно превышать 32766!');
  for i:=1 to counter do
  begin
     write('Введите ',i,' элемент: ');
     readln(j);
     if j>=maxint then
     begin
        writeln('!недопустимое число! попробуйте еще раз...');
        write('Введите ',i,' элемент: ');
        readln(j);
     end
     else
     dynArray^[i]:=j; {заполнение массива значениями}
  end;
end;

{выделение памяти под два малых массива, с кол-вом элементов в 2 раза меньше, чем в основном}
procedure CreateTwoSmallArrays(const counter:integer);
begin
  k:=counter div 2;
  writeln('Создание массивов...');
  getMem(small1,k*sizeOf(integer));
  getMem(small2,k*sizeOf(integer));
end;

{распределение чисел между массивами}
procedure MoreOrLess(const counter:integer);
var l, p, i, j, x: integer;
begin {сортировка пузырьком}
  p:=1;
  for i:=1 to counter-1 do
  begin
     for j:=i+1 to counter do
     begin
        if dynArray^[i]>dynArray^[j] then
        begin
           x:=dynArray^[i]; dynArray^[i]:=dynArray^[j]; dynArray^[j]:=x;
        end;
     end;
  end;
{распределение элементов по малым массивам (парами)}
i:=0;
repeat
     small1^[p]:=dynArray^[i+1];
     small2^[p]:=dynArray^[i+2];
     inc(p); i:=i+2;
until i=counter;
end;

begin
  CreateMainArr(counter);
  CreateTwoSmallArrays(counter);
  MoreOrLess(counter);
  writeln('Первый массив:'); {массив B}
  for m:=1 to k do
  begin
     write(small1^[m],' ');
  end;
  writeln;
  writeln('Второй массив:');
  for m:=1 to k do {массив C}
  begin
     write(small2^[m],' ');
  end;
  writeln;
  k:= counter div 2;
  writeln('Очистка памяти...');
  freeMem(dynArray,counter*sizeOf(integer));
  freeMem(small1,k*sizeOf(integer));
  freeMem(small2,k*sizeOf(integer));
  readln;
  writeln('ok')
end.


2 поинтересней smile.gif
Код

{Заданное число (не обязательно целое) отложить на бухгалтерских счётах,
изображённых на экране.}

program Counters;
uses crt, graph;
var s, d, e, sd, dd, ed, code: integer;
{ s - количество сотен во введенном числе
 d - количество десятков
 e - кол-во единиц
 sd - кол-во тысячных долей
 dd - кол-во сотых долей
 ed - кол-во десятых }

{обработка введенного пользователем числа}
procedure InputAndProcess;
var a:real;
   n:string;
   i:integer;

begin
  repeat
  writeln('ВНИМАНИЕ! будут обработаны только первые 3 знака после запятой!');
  write('введите число < 1000 (необязательно целое): ');
  readln(a);
  clrscr;
  until a<1000;
  str(a:5:3,n);
  for i:=2 to length(n) do {разделение целой и дробной частей}
  begin
     if n[i]='.' then
     begin
        if i=4 then
        begin
           val(n[1],s,code);
           val(n[2],d,code);
           val(n[3],e,code);
        end;
           if i=3 then
           begin
              s:=0;
              val(n[1],d,code);
              val(n[2],e,code);
           end;
           if i=2 then
           begin
              s:=0;
              d:=0;
              val(n[1],e,code);
           end;
        val(n[i+1],ed,code);
        val(n[i+2],dd,code);
        val(n[i+3],sd,code);
        break;
     end;
  end;
end;

{создание основы счет (без делений)}
procedure Bones;
var driver, mode, codeError:integer;
              i, j, x0, y0:integer;
begin
  Driver:=Detect;
  InitGraph(driver,mode,'');
  if GraphResult <>0 then writeln(GraphErrorMsg(Codeerror));
  x0:=GetMaxX; y0:=GetMaxY;
  SetBkColor(black);
  SetColor(brown);
  SetLineStyle(0,3,3);

  line(round(x0)div 3,    (round(y0) div 5) , (round(x0) div 3)*2, round(y0)div 5);
  line((round(x0)div 3)*2, round(y0) div 5,   (round(x0) div 3)*2,(round(y0)div 5)*4);
  line((round(x0)div 3)*2,(round(y0) div 5)*4, round(x0)div 3,    (round(y0)div 5)*4);
  line(round(x0)div 3,    (round(y0) div 5)*4, round(x0) div 3,    round(y0) div 5);

  j:=(round(y0)div 5)+(((round(y0)div 5)*4) div 9)-4;
  SetLineStyle(0,3,1);
  for i:=1 to 6 do
  begin
     moveto(round(x0)div 3,j);
     lineto((round(x0)div 3)*2,j);
     j:=j+(((round(y0)div 5)*4) div 9);
  end;
end;


{добавление какого-либо количества делений справа}
procedure AddToRight;
var x, y, xtemp, x0, y0, i: integer;
begin
  SetFillStyle(1,brown);
  x0:=GetMaxX; y0:=GetMaxY;
  {сотни}
  if s<>0 then
  x:=(((round(x0)div 3)*2)-7);
  y:=((round(y0)div 5)+(((round(y0)div 5)*4) div 9)-4);
  for i:=1 to s do
  begin
     pieslice(x,y,0,360,6);
     x:=x-14;
  end;
  {десятки}
  if d<>0 then
  x:=(((round(x0)div 3)*2)-7);
  y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*2)-4);
  for i:=1 to d do
  begin
     pieslice(x,y,0,360,6);
     x:=x-14;
  end;
  {единицы}
  if e<>0 then
  x:=(((round(x0)div 3)*2)-7);
  y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*3)-4);
  for i:=1 to e do
  begin
     pieslice(x,y,0,360,6);
     x:=x-14;
  end;
  {десятые доли}
  if ed<>0 then
  x:=(((round(x0)div 3)*2)-7);
  y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*4)-4);
  for i:=1 to ed do
  begin
     pieslice(x,y,0,360,6);
     x:=x-14;
  end;
  {сотые доли}
  if dd<>0 then
  x:=(((round(x0)div 3)*2)-7);
  y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*5)-4);
  for i:=1 to dd do
  begin
     pieslice(x,y,0,360,6);
     x:=x-14;
  end;
  {тысячные доли}
  if sd<>0 then
  x:=(((round(x0)div 3)*2)-7);
  y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*6)-4);
  for i:=1 to sd do
  begin
     pieslice(x,y,0,360,6);
     x:=x-14;
  end;
end;

{добавление какого-либо количества делений слева}
procedure AddToLeft;
var s1, d1, e1, sd1, dd1, ed1, x, y, x0, y0, i: integer;
begin
  s1:=9-s; d1:=9-d; e1:=9-e; sd1:=9-sd; dd1:=9-dd; ed1:=9-ed;
  SetFillStyle(1,brown);
  x0:=GetMaxX; y0:=GetMaxY;
  {сотни}
  if s1<>0 then
  x:=((round(x0)div 3)+7);
  y:=((round(y0)div 5)+(((round(y0)div 5)*4) div 9)-4);
  for i:=1 to s1 do
  begin
     pieslice(x,y,0,360,6);
     x:=x+14;
  end;
  {десятки}
  if d1<>0 then
  x:=((round(x0)div 3)+7);
  y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*2)-4);
  for i:=1 to d1 do
  begin
     pieslice(x,y,0,360,6);
     x:=x+14;
  end;
  {единицы}
  if e1<>0 then
  x:=((round(x0)div 3)+7);
  y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*3)-4);
  for i:=1 to e1 do
  begin
     pieslice(x,y,0,360,6);
     x:=x+14;
  end;
  {десятые доли}
  if ed1<>0 then
  x:=((round(x0)div 3)+7);
  y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*4)-4);
  for i:=1 to ed1 do
  begin
     pieslice(x,y,0,360,6);
     x:=x+14;
  end;
  {сотые доли}
  if dd1<>0 then
  x:=((round(x0)div 3)+7);
  y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*5)-4);
  for i:=1 to dd1 do
  begin
     pieslice(x,y,0,360,6);
     x:=x+14;
  end;
  {тысячные доли}
  if sd1<>0 then
  x:=((round(x0)div 3)+7);
  y:=((round(y0)div 5)+((((round(y0)div 5)*4) div 9)*6)-4);
  for i:=1 to sd1 do
  begin
     pieslice(x,y,0,360,6);
     x:=x+14;
  end;
end;

begin
InputAndProcess;
Bones;
AddToRight;
AddToLeft;
readln;
closegraph;
writeln('.');
readln;
end.


--------------------
Плавают разными стилями, тонут-одним (ц) Кирпичи
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


Пионер
**

Группа: Пользователи
Сообщений: 101
Пол: Мужской

Репутация: -  0  +


О... еще нашел... только в одной из версий этой лабы бага была.. непомню тут она пофикшена или нет ;)

Код

{условие (дословно):
распределение скорости ветра по каждому из восьми направлений
задано массивом из 8 чисел. Построить "розу ветров" с указанием
направлений}

program PO3A_BETPOB;

uses crt, graph;


type Napr_N=1..8;
    Koord=1..2;

var
  Napr:Napr_N;
  Napr_text:string[16];
  data:array[Napr_N] of word;
  Karta:array[Napr_N,Koord] of real;{Koord=1 - ось X, Koord=2 - ось Y}
  Xmin,Xmax,Ymin,Ymax:real;
  Simvol:char;

{процедура ввода чисел в массив}
Procedure input;
var i: integer;

begin
    TextColor(yellow);
    TextBackGround(blue);
    clrscr;
    for Napr:=1 to 8 do  {Ввод чисел, каждое - сила ветра}
                         {по одному из восьми направлений}
              begin
                   case Napr of  {Выбор одного направления ветра}
                        1:Napr_text:='восточного';
                        2:Napr_text:='северо-восточного';
                        3:Napr_text:='северного';
                        4:Napr_text:='северо-западного';
                        5:Napr_text:='западного';
                        6:Napr_text:='юго-западного';
                        7:Napr_text:='южного';
                        8:Napr_text:='юго-восточного'
                   end;
                   {Ввод и проверка числа дней с выбранным направлением ветра}
                   repeat
                         TextColor(white);
                         write('Сила ',Napr_text,' ветра: ');
                         TextColor(lightred);
                       readln(data[Napr]);
                       clrscr;
                 until data[Napr]>=0;
end;
end;

{просчет пропорций области карты}
procedure Oblast;
         var
            Koeff:real;
begin
    Koeff:=Sqrt(2)/2; {Коэффициент для промежуточных направлений ветра}
    for Napr:=1 to 8 do
        begin
             case Napr of
                  1:begin Karta[Napr,1]:=data[Napr];
                          Karta[Napr,2]:=0 end;
                  2:begin Karta[Napr,1]:=data[Napr]*Koeff;
                          Karta[Napr,2]:=Karta[Napr,1] end;
                  3:begin Karta[Napr,1]:=0;
                          Karta[Napr,2]:=data[Napr] end;
                  4:begin Karta[Napr,1]:=-data[Napr]*Koeff;
                          Karta[Napr,2]:=-Karta[Napr,1] end;
                  5:begin Karta[Napr,1]:=-data[Napr];
                          Karta[Napr,2]:=0 end;
                  6:begin Karta[Napr,1]:=-data[Napr]*Koeff;
                          Karta[Napr,2]:=Karta[Napr,1] end;
                  7:begin Karta[Napr,1]:=0;
                          Karta[Napr,2]:=-data[Napr] end;
                  8:begin Karta[Napr,1]:=data[Napr]*Koeff;
                          Karta[Napr,2]:=-Karta[Napr,1] end
             end;
        end;
    Xmin:=Karta[1,1]; Xmax:=Karta[1,1];
    Ymin:=Karta[1,2]; Ymax:=Karta[1,2];
    for Napr:=2 to 8 do
        begin
             if Karta[Napr,1]<Xmin then Xmin:=Karta[Napr,1];
             if Karta[Napr,1]>Xmax then Xmax:=Karta[Napr,1];
             if Karta[Napr,2]<Ymin then Ymin:=Karta[Napr,2];
             if Karta[Napr,2]>Ymax then Ymax:=Karta[Napr,2];
        end;
    if (Xmin=Xmax) or (Ymin=Ymax) then
       begin
            writeln('С этими данными график не построить -');
            writeln('Xmin=',Xmin:0:2,' Xmax=',Xmax:0:2,' Ymin=',Ymin:0:2,' Ymax=',Ymax:0:2);
            writeln('Попробуйте использовать другие значения');
            halt;
       end;
    writeln; TextColor(yellow);
    writeln('Область графика: ',Xmin:0:2,'<=X<=',Xmax:0:2,';', Ymin:0:2,'<=Y<=',Ymax:0:2);
    writeln; TextColor(white);
    writeln('Здесь учтен коэффициент, равный SQRT(2)/2 для направлений:');
    writeln('северо-восток, северо-запад, юго-запад, юго-восток');
    writeln;
    write('Если Вас устраивает область графика, нажмите клавишу 1 и <Enter> ');
    readln(Simvol);
    if Simvol<>'1' then
                    begin
                         writeln('Готовьте новые значения переменных и',
                                ' запускайте программу. Желаем успехов.');
                         readln;
                         halt
                    end;
end;

{построение графика}

procedure Grafik;
         var
            Driver,Mode,Code_error:integer;
            X0,Y0:integer;
            Coords:array[Napr_N,Koord] of word;
            Mx,My,M:real;
begin

    Driver:=Detect; {Автоопределяющийся тип драйвера}
    InitGraph(driver,mode,''); {Файл Graph.tpu - в текущем каталоге ('')}
    if GraphResult <>0 then writeln(GraphErrorMsg(Code_error));

    {Определение масштабного множителя М=min(Mx,My)}
    Mx:=(GetMaxX-30)/(Xmax-Xmin);    {15 - отступ по оси X от края окна}
    My:=(GetMaxY-20)/(Ymax-Ymin);    {10 - отступ по оси Y от края окна}
    if Mx<My then M:=Mx else M:=My;
    SetBkColor(black);

    {Определение местонахождения точки (Х0,У0) - начала координат}
    X0:=round(-Xmin*M+(GetMaxX-(Xmax-Xmin)*M)/2);
    Y0:=round(Ymax*M+(GetMaxY-(Ymax-Ymin)*M)/2);
    SetLineStyle(0,3,2);
    SetColor(green);
    Coords[1,1]:=X0+round(Karta[1,1]*M);
    Coords[1,2]:=Y0-round(Karta[1,2]*M);
    MoveTo(Coords[1,1],Coords[1,2]);
    for Napr:= 2 to 8 do
         begin
              Coords[Napr,1]:=X0+round(Karta[Napr,1]*M);
              Coords[Napr,2]:=Y0-round(Karta[Napr,2]*M);
              {Проводим отрезок прямой от текущего указателя до точки Napr}
              LineTo(Coords[Napr,1],Coords[Napr,2])
         end;
    LineTo(Coords[1,1],Coords[1,2]); {Замыкаем ломаную}
    SetFillStyle(11,lightred);
    FloodFill(X0,Y0,green);
    SetColor(white);
    SetLineStyle(0,0,1);
    Line(0,Y0,GetMaxX-10,Y0); OutTextXY(GetMaxX-15,Y0-3,'>');
    Line(X0,4,X0,GetMaxY); OutTextXY(X0-3,1,'^');
    SetTextStyle(2,0,0);
    OutTextXY(GetMaxX-25,Y0+6,'X');
    OutTextXY(X0-12,1,'Y');
    OutTextXY(X0-12,Y0+6,'0');
    SetColor(yellow);
    SetLineStyle(3,0,1);
    Napr:=2;
    repeat
          Line(X0,Y0,Coords[Napr,1],Coords[Napr,2]);
          Napr:=Napr+2;
    until Napr>8;
    {Надписи сторон света}
    SetTextStyle(3,HorizDir,1);
    OutTextXY(10,Y0-10,'West');
    OutTextXY(GetMaxX-40,Y0-10,'East');
    SetTextStyle(3,VertDir,1);
    OutTextXY(X0-5,10,'North');
    OutTextXY(X0-5,GetMaxY-40,'South');
    SetViewPort(10,5,130,55,ClipOn);
    SetColor(green);
    SetTextStyle(DefaultFont,HorizDir,1);
    SetTextJustify(CenterText,CenterText);
    {OutTextXY(60,15,'Р О З А');
    OutTextXY(60,30,'В Е Т Р О В');  }
readln;
end;

{main}

begin
    repeat
          input;       {Ввод исходных данных}
          Oblast;      {Нахождение границ области графика, преобр.координат}
          Grafik;      {Построение графика}
          readln;
          RestoreCrtMode; {Временный выход в текстовый режим работы монитора}
          readln;
          TextBackGround(blue);
          TextColor(yellow);
          ClrScr; GoToXY(15,10);
          write('Повторить c начала? Да - введите 1 и нажмите <Enter> ');
          readln(Simvol)
    until Simvol <> '1';
    CloseGraph;
    TextMode(Co40);
    TextBackGround(white); TextColor(magenta);
    Window(2,5,39,19);
    ClrScr; GoToXY(4,7);
    writeln('...press a key to exit...');
    ReadKey;
end.


--------------------
Плавают разными стилями, тонут-одним (ц) Кирпичи
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


...
*****

Группа: Пользователи
Сообщений: 1 347
Пол: Мужской

Репутация: -  3  +


ИнтереснЯ.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 28.03.2024 21:39
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name