Turbo Pascal[програмыки : текстовая\метод симпсона\метод половинного деления

[qsccsq]

изменил название темы по правилу мб из-за этого мне не отвечают))

вот проверьте пожалуйста эту прогу долго мучался пока проверял почему
не правельно ищет макс слово может быть я что-то упустил?

Program name;
uses
  crt;
const
letter :array[1..20] of char=
('b','c','d','f','g','h','j','k','l','m','n','p','q','r',
's','t','v','w','x','z');
letter1 :array[1..24] of char=
('b','c','d','f','g','h','j','k','l','m','n','p','q','r',
's','t','v','w','x','z','a','o','i','e');

var
st:string[50];
i,j,g:byte;
flag_word:boolean;
all_letter,each_letter,max,k:integer;
t,max_letter: real;
Begin
  clrscr;
  writeln('ўўҐ¤ЁвҐ ЇаҐ¤«®¦Ґ*ЁҐ');
  readln(st);
  writeln;

  max:=1;
  k:=0;
  all_letter:=0;
  each_letter:=0;
  max_letter:=0;
  flag_word:=false;
  st:=' '+st;

   For i:=2 to length(st) do
     begin
       if (st[i]<>' ')and (st[i-1]=' ')
         then
         flag_word:=true;
          if flag_word
           then
            begin
              write(st[i]);
              for g:=1 to 24 do
              if st[i]=letter1[g]
              then
              begin
              inc(k);
              end;
                for j:=1 to 20 do
                if st[i]=letter[j]
                then
                 begin
                  inc(all_letter);
                  inc(each_letter);
                end;
             end;
        t:=each_letter/k;
 If (st[i]=' ')and(st[i-1]<>' ')or (i=length(st))
   then
     begin
      flag_word:=false;
      writeln(' sogl',each_letter,' vsego bukv =' ,k,' dola sogl=',t:3:3);
        if max_letter<t
          then
          begin
            max_letter:=t;
            inc(max);
          end;
        each_letter:=0;
        k:=0;
      end;
   end;

writeln;
max:=max-1;
writeln('vsego sogl,all_letter');
writeln('maks dola sogl v slove nomer = ',max);
readkey;
end.

2ая прога суть задания : методом симпсона приближённо вычислить интеграл . интервал задан [0,1]; в 19 строчке For m:=1 to n-2 do
неверен кажеться

program name;
uses
  crt;
var
a,b,r,r2,eps :real;
n :integer;
function f(x:real):real;
  begin
    f:=x*exp(x)*sin(x);
  end;
function Simpson(a,b:real; n:integer):real;
var
  s,h:real;
  m,mn:integer;
 begin
  h:=(b-a)/(n);
  s:=f(a)+f(b);
  mn:=4;
 for m:=1 to n-2  do
  begin
  s:=s+mn*f(a+h*m);
  if (mn=4)
  then
  mn:=2
  else
  mn:=4;
  end;
  Simpson:=s*h/3;
 end;
Begin
{clrscr;}
writeln ('vvedite granicii a b');
Readln (a,b);
writeln('vvedite pogreshnost');
readln(eps);
n:=2;
r:=simpson(a,b,n);
repeat
 r2:=r;
 n:=n*2;
 r:=simpson(a,b,n);
until (abs(r-r2)<eps);
 Writeln;
 Writeln ('resultat po simpsony',r:6:6);
 writeln ('kol-vo razbienii* ',n,' ®в१Є®ў');
 readkey;
 end.

3 прога.
всё вроде бы правильно написал но пишет что данные не подходят
правильно ли написана? о_О

program pr7;
var a,b,x,x1,e,d,fa,fb,fx:real;
    n:integer;

function FunX(x1:real):real;
begin
     fx:=sqr(x1)*x1-6*sqr(x1)+9*x1+4;
end;

begin
     write('vvedite tocnost opredelenia korna:');
     readln (e);
     repeat
           write('Vvedite granic promegytka a,b:');
           readln (a,b);
           fa:=FunX(a);
           FunX(b);
           fb:=fx;
           If (fa*fb)>0 then writeln('Dannie ne podxodat dla metoda!')
     until(fa*fb)<0;
     n:=0;
     repeat
           x:=(a+b)*0.5;
           FunX (x);
           If (fa*fx)>0 then a:=x
           else b:=x;
           d:=abs((b-a)/x);
           n:=n+1;
     until d<=e;
     writeln('Otvet: x=',x:9:4);
     writeln('f(x)=',fx:7:4);
     writeln('Kollichestvo operacii:',n);
end.

[qsccsq]

ап же. почему игнорите?

[GetMax]

прога 3

  repeat
           write('Vvedite granic promegytka a,b:');
           readln (a,b);
           fa:=FunX(a);
           FunX(b);
           fb:=fx;
           If (fa*fb)>0 then writeln('Dannie ne podxodat dla metoda!')
     until(fa*fb)<0;

Что вы вобще хотели сказать данным условием. Вы,как я понял, ищите значение функции на концах отрезка. Так вот произведение всегда будет болшьше нуля

[qsccsq]

да тут я понял что так. просто по методу симпсона функция от границ а и б должна быть меньше нуля.

помогите с 1ой а блин сижу пытаюсь исправить не понимаю почему при многократных проверках всё таки показывает не правильно

[GetMax]

помогите с 1ой

А что должна делать эта программа?

[qsccsq]

вот условие того что я писал. в 1 проге

Для каждого слова заданного предложения указать долю согласных латинского алфавита. Определить слово, в котором доля согласных максимальна.

3 прогу свою додумал больше не нуждаюсь в 3ей
вот она

program z7;
uses crt;
var a,b,x,eps,dx,f1,f2:real;
i:integer;
function f(x:real):real;
begin
f:=sqr(x)*x-6*sqr(x)+9*x+4;
end;
BEGIN
clrscr;
write('vvedite a,b->');
readln(a,b);
write('vvedite eps->');
readln(eps);
writeln('f(a)=',f(a):1:5,' f(b)=',f(b):1:5);
x:=(a+b)/2;
dx:=eps*2;
i:=1;
repeat
f1:=f(x-dx);
f2:=f(x+dx);
if f1<f2 then b:=x else a:=x;
x:=(a+b)/2;
i:=i+1;
until abs(b-a)<=eps;
writeln;
writeln('min: ','x=',x:1:7, ' y=',f(x):1:7);
writeln('i=',i);
readln;
END.

[GetMax]

По первой предлагаю такой вариант

const
letter :Set of char=
['b','c','d','f','g','h','j','k','l','m','n','p','q','r',
's','t','v','w','x','y','z'];
letter1 :Set Of Char =
['B','C','D','F','G','H','J','K','L','M','N','P','Q','R',
'S','T','V','W','X','Y','Z'];

var
st,st2,BufStr:string[50];
i,j,g:byte;
flag_word:boolean;
all_letter,each_letter,k:integer;
t,max: real;
Begin
  write('Vvedite stroku(V konce postavte tochku) ');
  readln(st);
  writeln;
  st2:='';
  Max:=0;
  i:=1;
  For i:=1 to Length(St) do
  Begin
    If (St[i] <> ' ') and (St[i] <> '.')  then St2:=St2+St[i]
    Else
    If (St[i] = ' ') or (St[i] = '.') then
    Begin
       K:=0;
       For j:=1 to Length(St2) do
       Begin
         If (St[j] in Letter) or (St[j] in Letter1) then
         Begin
           Inc(K)
         End;
       End;
        T:=k/Length(St2);
       If T > Max then
       Begin
         Max:=T;
         BufStr:=St2
       End;
       Writeln('V slove ',St2,' kol sogl = ',K,' ih Dolya = ',t:4:2);
       st2:=''
     End;
  End;
  Writeln('Iskomoe Slovo - ',BufStr);
Readln

[qsccsq]

.cпасибо.

. .