Форум АНТИЧАТ

Форум АНТИЧАТ (https://forum.antichat.xyz/index.php)
-   С/С++, C#, Delphi, .NET, Asm (https://forum.antichat.xyz/forumdisplay.php?f=24)
-   -   Help please with Pascal (https://forum.antichat.xyz/showthread.php?t=40654)

_-[A.M.D]HiM@S-_ 23.05.2007 00:07
Help please with Pascal
 
Hello, help me with pascal please. senks.

5. Исследовать область определения и построить график ф-ции у=х/(х+3х+1).

Thank's for all.

_-[A.M.D]HiM@S-_ 23.05.2007 00:11
senks

LolFEm 23.05.2007 12:53
хм... 8 разых программ... есть легкие есть над которыми думать надо...
Что в виде вознаграждения... может быть предложено>?

Ky3bMu4 23.05.2007 13:39
А на С++ не надо?)

NetMan 25.05.2007 23:55
Цитата:
Сообщение от _-[A.M.D]HiM@S-_
1. Заданы натуральное число n, символы S1, ... , Sn Подсчитать наибольшее количество идущих подряд символов пробела.
uses crt;
var sp,maxsp,i,n:integer;
s:string;
begin
clrscr;
write('N=');readln(n);
write('S=');readln(s);

maxsp:=0;
sp:=0;
for i:=1 to n do begin
if s[i]=' ' then inc(sp)
else sp:=0;
if sp>maxsp then maxsp:=sp;
end;
writeln('Max spaces=',maxsp);
readln;
end.

da_ff 26.05.2007 14:53
Цитата:
Сообщение от _-[A.M.D]HiM@S-_
7. Задан текст. Необходимо построить список слов, который есть в этом тексте. Определить сколько раз встречается каждое слово в этом тексте.
var
f:textfile;
str,word:string;
i,j,m,n:integer;
arrstr:array of string;
begin
assignfile(f,'test.txt');
reset(f);
n:=0;
while not eof(f) do
begin
readln(f,str);
m:=Length(str);
i:=0;
while i<=m do
begin
case str[i] of
'а'..'я','А'..'Я':
begin
word:=word+str[i];
inc(i);
end;
else
begin
if word<>'' then
begin
inc(n);
SetLength(arrstr,n);
word:=AnsiLowerCase(word);
arrstr[n-1]:=word;
word:='';
end;
inc(i);
end;
end;
end;
end;
for i:=0 to n-1 do
begin
if arrstr[i]='' then continue;
m:=1;
for j:=i+1 to n-1 do
begin
if arrstr[j]='' then continue;
if arrstr[i]=arrstr[j] then
begin
inc(m);
arrstr[j]:='';
end;
end;
writeln(arrstr[i]+' '+IntToStr(m));
arrstr[i]:='';
end;
end;

da_ff 27.05.2007 13:59
Цитата:
Сообщение от _-[A.M.D]HiM@S-_
8. Задана последовательность слов, разделенных пропусками. Принимая первое слово за образец, выбрать те слова, которые могут быть получены из образца, путем перестановки букв.
var
f:textfile;
mainword,word,str:string;
i,j,m,n:integer;
arrword:array of string;
fl_is:boolean;
begin
mainword:='';
assignfile(f,'test.txt');
reset(f);
readln(f,str);
m:=Length(str);
i:=1;
n:=0;
while i<=m do
begin
case str[i] of
'а'..'я','А'..'Я':
begin
word:=word+str[i];
inc(i);
end;
else
begin
if word<>'' then
begin
word:=AnsiLowerCase(word);
if mainword='' then
begin
mainword:=word;
word:='';
inc(i);
continue;
end;
inc(n);
SetLength(arrword,n);
arrword[n-1]:=word;
word:='';
end;
inc(i);
end;
end;
end;
if(word<>'')and(arrword[n-1]<>word)then
begin
inc(n);
SetLength(arrword,n);
arrword[n-1]:=word;
end;
//
for i:=0 to n-1 do
begin
if Length(arrword[i])>Length(mainword) then continue;
word:=mainword;
fl_is:=true;
for j:=1 to Length(arrword[i]) do
begin
if fl_is=false then break;
fl_is:=false;
for m:=1 to Length(word) do
begin
if arrword[i][j]=word[m] then
begin
fl_is:=true;
word[m]:=' ';
break;
end;
end;
end;
if fl_is=true then
Writeln(arrword[i]+' in '+mainword);
end;
end;

NetMan 28.05.2007 16:47
Цитата:
Сообщение от _-[A.M.D]HiM@S-_
3. Дан файл f, компоненты которого являются целыми числами. Получить файл g, образованный из файла f исключением повторных вхождений одного и того же числа.
Check dis! ;)
Код:
uses crt;
var a,b:array [1..100] of integer;
    i,j,n,m:integer;
    fi,fo:textfile;
    skip:boolean;
begin
        Assign(fi,'in.txt');
        Reset(fi);
        Assign(fo,'out.txt');
        Rewrite(fo);
        n:=1;
        while not eof(fi) do begin
                read(fi,a[n]);
                inc(n);
        end;
        m:=1;
        for i:=1 to n do begin
        skip:=false;
          for j:=1 to m do
            if b[j]=a[i] then
                        begin
                                skip:=true;
                                break
                        end;


        if skip then continue
                else begin
                        inc(m);
                        b[m]:=a[i];
                        write(fo,a[i],' ');
                    end;

        end;
        Close(fi);
        Close(fo);
end.

NetMan 28.05.2007 19:18
Цитата:
Сообщение от _-[A.M.D]HiM@S-_
4. Заданы два массива записей, каждый из которых содержит фамилии и адреса сотрудников. Составленная программа должна перенести (в любом порядке) записи с двух массивов в третий, причем с двух одинаковых записей переносится только одна.
Код:
uses crt;

type sotr=record
fam:string;
adr:string;
end;

var a,b:array [1..50] of sotr;
    c:array [1..100] of sotr;
    i,j,na,nb,nc:integer;
    skip:boolean;
begin
        clrscr;
        write('Введите количество записей первого массива: ');readln(na);
        for i:=1 to na do begin
                write('Введите фамилию ',i,'-ого сотрудника: ');readln(a[i].fam);
                write('Введите адрес ',i,'-ого сотрудника: ');readln(a[i].adr);
                c[i].fam:=a[i].fam;
                c[i].adr:=a[i].adr;
        end;

        writeln;

        write('Введите количество записей второго массива: ');readln(nb);
        for i:=1 to nb do begin
                write('Введите фамилию ',i,'-ого сотрудника: ');readln(b[i].fam);
                write('Введите адрес ',i,'-ого сотрудника: ');readln(b[i].adr);
        end;

        writeln;

        nc:=na;
        for i:=1 to nb do begin
        skip:=false;
                for j:=1 to nc do
                        if (b[i].fam=c[j].fam) and (b[i].adr=c[j].adr) then
                                        begin
                                              skip:=true;
                                              break
                                        end;
        if skip then continue
                else begin
                          inc(nc);
                          c[nc]:=b[i];
                    end;

        end;

        for i:=1 to nc do begin
                writeln('Фамилия ',i,'-ого сотрудника: ',c[i].fam);
                writeln('Адрес ',i,'-ого сотрудника: ',c[i].adr);
        end;
        readln;
end.

valiko 29.05.2007 01:46
Цитата:
Сообщение от _-[A.M.D]HiM@S-_
2. Вычислить Z = (X1 + Y1) / (Х2 - Y2), где Х1 и Х2 - корни уравнения 2x2 +x – 4=0;Y1 и Y2 – корни уравнения ay2 + 2у - 1 = 0. (Все корни действительные).
Код:
uses crt;
const
  eps = 10E-9;
procedure sqr_urav(a,b,c:double;var x1,x2:double);
var
d,t,y,u:double;
r:real;
begin

  if abs(a) < eps then
    begin
      if abs(b) < eps then
        begin
          if abs(c) < eps then
            writeln('infinitnoye mnojestvo')
          else
            writeln('korney net');
          end
      else
      begin
          x1:=-c/b;
          writeln('koren ',x1);
      end;
    end
  else
  begin
    d:=(sqr(b)-4*a*c);
    t:=sqrt(d);
    if (d<0) then writeln('deystvitelnyh korney net')
    else
      begin
      x1:=(-b-t)/(2*a);
      x2:=(-b+t)/(2*a);
      end;
  end;
end;

var a,b,c,x1,x2,y1,y2,z:double;

begin
  clrscr;
{2x2+x-4=0}
  sqr_urav(2,1,-4,x1,x2);
  writeln('x1= ',x1);
  writeln('x2= ',x2);
  writeln;
{ay2+2y-1=0}
  write('a= '); readln( a );
  sqr_urav(a,2,-1,y1,y2);
  writeln('y1= ',y1);
  writeln('y2= ',y2);
{z=(x1+y1)/(x2-y2)}
  z:=(x1+y1)/(x2-y2);
  writeln;
  writeln('z=(x1+y1)/(x2-y2)=',z);
  readln;
end.

valiko 29.05.2007 02:47
Цитата:
Сообщение от _-[A.M.D]HiM@S-_
6. Разработать программу, которая при нажатии клавиши F9 выводит на экран текстовое окно. При нажатой клавиши ? сдвигается влево левая рамка окна, при нажатии ? вправо правая рамка окна, при нажатии ? - вниз нижняя рамка окна, при нажатии ? - вверх верхняя рамка окна.
Код:
Uses CRT;
var
x1,x2,y1,y2: integer; {координаты левого верхнего (x1,y1) и правого нижнего (x2,y2) углов окна}
c,s:char;

begin
 TextBackground(Black);
 clrscr;
 writeln('Нажмите F9 для создания текстового окна');
 s:= readkey;
 if s=#0 then s:=readkey;
 if s=#67 then {F9}
 begin
 clrscr;
 x1:=10; x2:=20; y1:=10; y2:=20;
{Создаем окно - желтые символы на синем фоне}
 Window(x1,y1,x2,y2);
 TextBackground(Blue);
 TextColor(Yellow);
 clrscr;

 repeat
  c := readkey;
  case c of
  #72:y1:=y1-1; {вверх}
  #75:x1:=x1-1; {влево}
  #80:y2:=y2+1; {вниз}
  #77:x2:=x2+1; {вправо}
  end;
writeln (ord(c));
  Window(x1,y1,x2,y2);
  clrscr;
 until c=#27 {выход по Esc}
  end;
end.

NetMan 29.05.2007 18:27
Цитата:
Сообщение от _-[A.M.D]HiM@S-_
ф-ции у=х/(х+3х+1)
Функция указана верно?
Эту функцию можно было бы задать как y=x/(4x+1)...

_-[A.M.D]HiM@S-_ 03.06.2007 20:16
Help please

“Множества” 8. Задан текст из латинских букв, в конце – точка. Вывести на печать все буквы, которые входят в текст один раз.

The_HuliGun 03.06.2007 20:41
Держи задачку с множествами

Код:
uses crt;
var s:string;
i:integer;
c:char;
mn, mn2 : set of char;
begin
 clrscr;
 mn:=[];
 s:='Test string.';
 for i:=1 to  length(s)-1 do
        begin
        if s[i] in mn then mn2:=mn2+[s[i]] else
        mn:=mn+[s[i]];
        end;
 mn:=mn-mn2;
for c:='a' to 'z' do
 if c in mn then writeln(c);
for c:='A' to 'Z' do
 if c in mn then writeln(c);

 readln
end.


Время: 06:50