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

[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.