freepascal.ru

форум
https://freepascal.ru/forum/

Спасите кто-нибудь от циклов и массивов

https://freepascal.ru/forum/viewtopic.php?t=7055

Страница 3 из 4

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 24.05.2011 15:12:59
daesher
While довольно хорошо работает как if, например, по первому заданию с ходу могу предложить:

Код: Выделить всё

var a,b:integer;
begin
  writeln('Enter a=');readln(a);
  writeln('Enter b=');readln(b);
  while a<b do a:=b;
  writeln(a);
end.

Правда, теряется значение a, но при желании его можно сохранить, да и программа больше ничего не делает
Со вторым аналогично.

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 25.05.2011 03:24:44
Vadim
informat писал(а):Из управляющих конструкций можно использовать только while.

Операции сравнения тоже нельзя использовать? :)

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 25.05.2011 10:54:20
Maxizar
Vadim Ради смеха сделал и без операций сравнения и даже без While только чистый АСМ, (ММХ) вот что я сделал:

Код: Выделить всё

unit Unit1; 

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;

type

IntArray = array [0..1] of integer;
  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end; 

var
  Form1: TForm1; 

implementation

{$R *.lfm}

{ TForm1 }

Function Maximum2(a,b:integer):Integer;
var Temp:IntArray ;
  {$AsmMode INTEL}
begin
   Temp[0]:=a;
   Temp[1]:=b;
 asm
   MOVq    mm0, Temp
   PshufW  mm1, mm0, 01001110b
   PmaxSW  mm1, mm0
   MOVd    Result, mm1
   EMMS
 end;

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Caption:=IntToStr(Maximum2(5,-200));
end;

end.



Вроде все правильно :D

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 25.05.2011 11:46:11
Putnick
Vadim писал(а):Операции сравнения тоже нельзя использовать? :)

Естественно, со сравнениями-то каждый может. А ты "без единого гвоздя" попробуй :wink:
Я, например, попробовал так:

Код: Выделить всё

var
vars:array [0..1] of integer;
c:Integer;
begin
  vars[0]:=random(100);
  vars[1]:=random(100);
c:=(vars[0]-vars[1]) shr (sizeof(integer)*8-1);
writeln('Из двух чисел: ',vars[0],' и ',vars[1], ' наибольшее - ',vars[c]);
end.

и так:

Код: Выделить всё

var
vars:array [0..2] of integer;
c:Integer;
x:array [1..5] of byte; // исключительно для наглядности и удобочитаемости
begin
  vars[0]:=random(100);
  vars[1]:=random(100);
  vars[2]:=random(100);
x[1]:=(vars[0]-vars[1]) shr (sizeof(integer)*8-1);
x[2]:=(vars[0]-vars[2]) shr (sizeof(integer)*8-1);
x[3]:=(vars[1]-vars[2]) shr (sizeof(integer)*8-1);
writeln(x[1],' ',x[2],' ',x[3]);
x[4]:=x[2] and x[3];
x[5]:=x[1] and (not(x[3]));
writeln(x[4],' ',x[5]);
c:=(x[4] shl 1)+x[5];
writeln('Из трех чисел: ',vars[0],', ',vars[1],' и ',vars[2], ' наибольшее - ',vars[c]);
end.

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 25.05.2011 12:18:30
daesher
Putnick писал(а):Я, например, попробовал так:

Код: Выделить всё

var
vars:array [0..1] of integer;
c:Integer;
begin
  vars[0]:=random(100);
  vars[1]:=random(100);
c:=(vars[0]-vars[1]) shr (sizeof(integer)*8-1);
writeln('Из двух чисел: ',vars[0],' и ',vars[1], ' наибольшее - ',vars[c]);
end.



Слишком уж "типоориентированно" получилось. Например, с вещественным типом пришлось бы "измываться" совсем иначе.
Если использовать тройку встроенных функций (Round, sqr - можно обойтись и sqrt) и взять за основу предыдущий код - то получится более универсально:

Код: Выделить всё

program Project1;
{$apptype console}
{$mode objfpc}{$H+}
type AType=integer;//real;
var
vars:array [0..1] of AType;
c:Integer;
a:atype;

begin
  Readln(vars[0]);
  Readln(vars[1]);
  a:=vars[1]-vars[0];
  c:=(Round(a/sqrt(sqr(a)))+1) div 2;
  writeln(vars[c]);
  readln;
end.

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 25.05.2011 13:49:00
kipar
У меня была идея сделать через abs:
max :=(abs(a-b)+(a-b))/(a-b)/2*a+(abs(a-b)+(b-a))/(b-a)/2*b;
(заменить / на div для целых чисел)

Но как и вариант
Если использовать тройку встроенных функций (Round, sqr - можно обойтись и sqrt) и взять за основу предыдущий код - то получится более универсально:
он не работает (если числа а и b равны), получается деление на 0.

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 25.05.2011 18:03:12
vada
Помоему, топик надо переименовать во что-то такое: "Новичкам на заметку. Как никогда нельзя делать."

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 25.05.2011 18:20:29
Oleg_D
vada писал(а):Помоему, топик надо переименовать во что-то такое: "Новичкам на заметку. Как никогда нельзя делать."

Тоже подумал об этом :)
По крайней мере, над пояснить новичкам, что трюки (в этой и других ветках) - это всего лишь упражнения для углубления понимания языка программирования. В "боевых" программах надо писать просто и ясно.

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 26.05.2011 09:18:33
Putnick
daesher писал(а):Слишком уж "типоориентированно" получилось. Например, с вещественным типом пришлось бы "измываться" совсем иначе.

Ну, почему же СОВСЕМ иначе? Принцип тот же:

Код: Выделить всё

type
  TMyType=byte;
  PMyType=^TMyType;
  TWorkType=real;//integer
var
vars:array [0..1] of TWorkType;
c:Integer;
x:PMyType;
tmp:TWorkType;
begin
  vars[0]:=random(100);
  vars[1]:=random(100);
  tmp:=vars[0]-vars[1];
  x:=PMyType(@tmp)+sizeof(TWorkType)-1;
  c:=x^ shr 7;
writeln('Из двух чисел: ',vars[0],' и ',vars[1], ' наибольшее - ',vars[c]);
end.

Ведь в любом типе, определенном от -... до +..., 0 бит используется для знака.

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 29.05.2011 12:48:52
Putnick
Кстати, придумал более универсальный вариант решения

Код: Выделить всё

program Project1;

{$mode objfpc}{$H+}
type
  TMyProc=procedure(i:integer);
  TMyType=byte;
  PMyType=^TMyType;
  TWorkType=real;//integer
var
  Procs:array [0..2] of TMyProc;
  A:^TWorkType;
  MaxN:integer;
  XA:Array [0..1] of Integer;
{$F+}
procedure DoNothing(i:integer);
begin
  //пустая процедура
end;
procedure GetValue(i:integer);
var
  c:integer;
  CE:^TWorkType;
  x:PMyType;
begin
  CE:=A+i;
  CE^:=random(100);
  Write(CE^:0:0,' ');
  c:=(i-MaxN+1);
  x:=PMyType(@c)+sizeof(integer)-1;
  c:=x^ shr 7;
  Procs[c](i+1);
end;
procedure FindMax(i:integer);
var
  c:integer;
  x:PMyType;
  tmp:TWorkType;
begin
  XA[1]:=i;
  tmp:=(A+XA[0])^-(A+XA[1])^;
  x:=PMyType(@tmp)+sizeof(TWorkType)-1;
  c:=x^ shr 7;
  XA[0]:=XA[c];
  c:=(i-MaxN+1);
  x:=PMyType(@c)+sizeof(integer)-1;
  c:=x^ shr 7;
  Procs[c*2](i+1)
end;
{$F-}
begin
  Procs[0]:=@DoNothing;
  Procs[1]:=@GetValue;
  Procs[2]:=@FindMax;
  Write('Количество чисел (не меньше 2) - ');
  Readln(MaxN);
  GetMem(A, MaxN*Sizeof(TMyType));
  Procs[1](0);
  Writeln;
  XA[0]:=0;
  Procs[2](1);
  Writeln('Наибольший элемент№',XA[0]+1,' = ',(A+XA[0])^:0:0);
  Readln;
  FreeMem(A)
end.

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 30.05.2011 06:49:07
informat
Сколько оказалось любителей "одевать штаны через голову", да ещё разными способами. :D
Немного отойду от проверки ЕГЭ и ещё подкину задачи на "технику" программирования.

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 01.06.2011 06:57:27
informat
Есть такая классическая задача.
Поменять значения двух переменных целого типа не используя дополнительных переменных.
Конечно, писать нужно только в базовых операциях, без использования всяких swap и т.п.
Эта задача давно известна и полезна для развития понимания сути переменной, бесполезна с практической точки зрения.

А вот мои задачи на ту же тему.
:?: Обменять значение логических переменных (boolean). Есть два варианта решения: с if и без него.

:?: Обменять два множества (set of TYPE).

:?: Можно ли так обменять строки (string)?

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 01.06.2011 11:25:02
kipar
Для булевых: (спойлер)
b2 := b2 xor b1;
b1 := b1 xor b2;
b2 :=(b1 xor b2);

Для строк (ограничился длинами до 256):
s1 := 'ABCD';
s2 := 'abcd';
writeln(s1, ',', s2);
s1 := Char(Length(s1))+s1+s2;
s2 := Copy(s1, 2, Byte(s1[1]));
Delete(s1, 1, Byte(s1[1])+1);
writeln(s1, ',', s2);

Для множеств.... надо подумать. Можно использовать полное множество (типа [0..255])?

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 01.06.2011 11:44:11
Putnick
Ну, как вариант:

Код: Выделить всё

type
  TMySet=set of byte;
var
  a, b:boolean;
  c, d:TMySet;
  i:byte;
  e, f:string;
begin
  Writeln('Task #1');
  a:=true;
  b:=false;
  writeln(a,' ',b);
  writeln('Processing...');
  a:=a xor b;
  b:=a xor b;
  a:=a xor b;
  writeln(a,' ',b);
  Writeln('Task #2');
  c:=[1..3];
  d:=[3..5];
  for i:=0 to 255 do
    if i in(c) then writeln(i,' in set C');
  for i:=0 to 255 do
    if i in(d) then writeln(i,' in set D');
  writeln('Processing...');
  c:=c+d-c*d;
  d:=(d-c)+(c-d);
  c:=(c-d)+(d-c);
  for i:=0 to 255 do
    if i in(c) then writeln(i,' in set C');
  for i:=0 to 255 do
    if i in(d) then writeln(i,' in set D');
  Writeln('Task #3');
  e:='1''st string';
  f:='2''nd string';
  writeln(e);
  writeln(f);
  writeln('Processing...');
  e:=e+f;
  f:=copy(e,1, Length(e)-Length(f));
  Delete(e,1,Length(e)-Length(f));
  writeln(e);
  writeln(f);
end.

Re: Спасите кто-нибудь от циклов и массивов

Добавлено: 01.06.2011 11:59:21
kipar
for i:=0 to 255 do

Нее, это дополнительная переменная, их нельзя использовать!
Часовой пояс: UTC+03:00
Страница 3 из 4

Создано на основе phpBB® Forum Software © phpBB Limited

Русская поддержка phpBB