Может кому интересно... Опции

[sandman]

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

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 поинтересней

Код

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

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.

[sandman]

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

Код

{условие (дословно):
распределение скорости ветра по каждому из восьми направлений
задано массивом из 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.

[AlaRic]

ИнтереснЯ.