Помогите оптимизировать программу..., Программа на системы счисления. Опции

[Elen]

Помогите пожалуйста оптимизировать программу, говорят, что можно написать намного короче, я же ума не приложу, что можно от нее отрезать...

Исходный код

uses crt;
const s=10;
var sett:set of char;
ch:char;
s1,s2,s3,LER,e:integer;
ploxayperem,i,tochek,ll:integer;
aa,bb,cc,smac:string;
f:boolean;
a,b,c:extended;

Function Pe(sed:extended;st:integer):string;
var nass:array[1..6] of integer;
nass2:array[1..6] of char;
sew,qqq:longint;
z,ssss:integer;
pro,nov,drobi:extended;
na:array[1..9] of integer;
na2:array[1..9] of char;
stroka:string;
begin
pe:='0';
sew:=trunc(sed);
drobi:=sed-sew;
pro:=0;
pro:=drobi;
for z:=1 to 6 do nass[z]:=0;
for z:=1 to 6 do
begin
nov:=pro*st;
nass[z]:=trunc(nov);
pro:=frac(nov);
end;
for z:=1 to 6 do nass2[z]:=' ';
for z:=1 to 6 do
begin
if (nass[z]>=0) and (nass[z]<10) then
nass2[z]:=chr(nass[z]+48)
else nass2[z]:=chr(nass[z]+55);
end;
for z:=1 to 9 do
begin
na[z]:=0;
na2[z]:=' ';
end;
z:=9; qqq:=sew;
while qqq>=st do
begin
na[z]:=qqq mod st;
z:=z-1;
qqq:=qqq div st;
end;
na[z]:=qqq;
for z:=1 to 9 do
begin
if (na[z]>=0) and (na[z]<10) then
na2[z]:=chr(na[z]+48)
else na2[z]:=chr(na[z]+55);
end;
stroka:='';
for z:=1 to 9 do Insert(na2[z],stroka,length(stroka)+1);
Insert('.',stroka,length(stroka)+1);
for z:=1 to 5 do Insert(nass2[z],stroka,length(stroka)+1);
z:=1;
ssss:=1;
while stroka[z]='0' do
begin
ssss:=ssss+1;
z:=z+1;
end;
for z:=1 to ssss-1 do delete(stroka,1,1);
pe:=stroka;
{}
end;

Function perev10(q:string):extended;
var t:integer;
mass:array[1..20] of integer;
mass2:array[1..20] of char;
ma:array[1..20] of integer;
ma2:array[1..20] of char;
ppp:extended;
q1,q2:string;
z:integer;
br:integer;
begin
perev10:=0;
ppp:=0;
t:=pos('.',q);
q1:=copy(q,1,t-1);
q2:=copy(q,t+1,length(q)-t);
for z:=1 to 20 do mass[z]:=0;
for z:=1 to 20 do mass2[z]:=' ';
for z:=1 to 20 do ma[z]:=0;
for z:=1 to 20 do ma2[z]:=' ';
for z:=1 to length(q1) do mass2[z]:=q1[z];
for z:=1 to length(q2) do ma2[z]:=q2[z];
t:=1;
while (mass2[t]<>' ') and (t<=20) do
begin
z:=ord(mass2[t]);
if (z>47) and (z<58) then
mass[t]:=z-48
else mass[t]:=z-55;
t:=t+1;
end;
t:=1;
while (ma2[t]<>' ') AND (t<=20) do
begin
z:=ord(ma2[t]);
if (z>47) and (z<58) then
ma[t]:=z-48
else ma[t]:=z-55;
t:=t+1;
end;
{}
for z:=1 to 20 do
ppp:=ppp+ma[z]*Exp((-1)*z*ln(s1));
for z:=1 to length(q1) do ppp:=ppp+mass[z]*Exp((length(q1)-z)*ln(s1));
{}
perev10:=ppp;
end;

Function Summa(r1,r2:string):string;
var t1,t2,t,z:integer;
d1,d2,d6:array[1..20] of char;
d3,d4,d5:array[1..20] of integer;
as:integer;
u:integer;
ph:string;
begin

t1:=pos('.',r1);
t2:=pos('.',r2);

If t1>t2 then
Begin
t:=t1-t2;
For z:=1 to t do Insert('0',r2,1);
End
else
Begin
If t1=t2 then
Begin
t:=0;
End
else
Begin
t:=t2-t1;
For z:=1 to t do Insert('0',r1,1);
End;
End;

t1:=length(r1);
t2:=length(r2);


If t1>t2 then
Begin
t:=t1-t2;
For z:=1 to t do Insert('0',r2,t2+1);
End
ELSE
bEGIN
If t1<t2 then
Begin
t:=t2-t1;
For Z:=1 to T do Insert('0',r1,t1+1);
End;
eND;


t:=length(r1)-pos('.',r1);
Delete(r1,pos('.',r1),1);
Delete(r2,pos('.',r2),1);


For z:=1 to 20 do
Begin
d1[z]:=' ';
d2[z]:=' ';
d3[z]:=0;
d4[z]:=0;
d5[z]:=0;
d6[z]:=' ';
End;
{}
u:=20;
For z:=length(r1) downto 1 do
Begin
d1[u]:=r1[z];
u:=u-1;
End;

u:=20;
For z:=length(r2) downto 1 do
Begin
d2[u]:=r2[z];
u:=u-1;
End;

For z:=1 to 20 do
Begin

as:=ord(d1[z]);
If (as>47) and (as<58) then d3[z]:=as-48
else
Begin
If as<>32 then d3[z]:=as-55 else d3[z]:=0;
End;

as:=ord(d2[z]);
If (as>47) and (as<58) then d4[z]:=as-48
else
Begin
If as<>32 then
d4[z]:=as-55
else d4[z]:=0;
End;
End;

{}
For z:=20 downto 1 do
Begin
d5[z]:=d5[z]+(d3[z]+d4[z]) mod s1;
d5[z-1]:=d5[z-1]+(d3[z]+d4[z]) div s1;;
End;

For z:=1 to 20 do
Begin
If (d5[z]<10) and (d5[z]>=0) then d6[z]:=chr(d5[z]+48)
else d6[z]:=chr(d5[z]+55);
End;

ph:='';
For z:=1 to 20 do
Insert(d6[z],ph,length(ph)+1);

Insert('.',ph,length(ph)-t+1);

t:=1;
While ph[t]='0' do
Begin
t:=t+1;
End;
t:=t-1;

For z:=1 to t do delete(ph,1,1);

summa:=ph;
{}
End;

Procedure redact(Var cursor:string);
Var k:integer;
toch:integer;
Begin
k:=length(cursor);
toch:=pos('.',cursor);
If toch=0 then Insert('.0',cursor,k+1);
End;






Function pravka(Var chislo:string; sys:integer):boolean;
Begin
pravka:=true;
If length(chislo)=0 then pravka:=false
else
Begin
If (chislo[1]='.') or (chislo[length(chislo)]='.') then pravka:=false
else
Begin
tochek:=0;
For i:=1 to length(chislo) do If chislo[i]='.' then tochek:=tochek+1;
If tochek>1 then pravka:=false
else
Begin
For i:=1 to length(chislo) do
If not (chislo[i] in sett) then
pravka:=false;
End;
End;
End;
End;


{Текст основной программы}
Begin
Clrscr;
sett:=[];
sett:=sett+['.']+['0']+['1'];
s1:=3;
If s1<=10 then
Begin
For i:=1 to (s1-1) do sett:=sett+[chr(i+48)];
End
else
Begin
For i:=48 to 57 do sett:=sett+[chr(i)];
For i:=10 to (s1-1) do sett:=sett+[chr(i+55)];
End;


s2:=20;
s3:=18;


Repeat
Clrscr;

Writeln('Для начала перевода нажмите ПРОБЕЛ.');
Writeln('Выход осуществляется по нажатию любой другой клавиши.');
ch:=readkey;
e:=ord(ch);
If e=32 then
Begin
Clrscr;
Repeat
Writeln('В ',s1,' ','с/с',' ','можно вводить только цифры от 0 до 2');
Writeln('Введите начало диапозона');
Readln(aa);
f:=pravka(aa,s1);
If f=false then
Begin
Writeln('Ошибка при вводе! Введите начало диапозона правильно!');
Writeln('Для продолжения нажмите Enter');
Readln;
End;
Until f=true;

Repeat
Writeln('Введите шаг');
Readln(cc);
f:=pravka(cc,s1);
If f=false then
Begin
Writeln('Ошибка при вводе! Введите шаг правильно!');
Writeln('Для продолжения нажмите Enter');
Readln;
End;
Until f=true;

Repeat
Writeln('Введите конец диапозона');
Readln(bb);
f:=pravka(bb,s1);
If f=false then
Begin
Writeln('Ошибка при вводе! Введите конец диапозона правильно!');
Writeln('Для продолжения нажмите Enter');
Readln;
End;
Until f=true;

redact(aa);
redact(bb);
redact(cc);

a:=perev10(aa);
c:=perev10(cc);
b:=perev10(bb);
smac:=aa;

If (a>b) then
Begin
Clrscr;
Writeln('Ошибка! Начальное значение превышает конечное. Для продолжения нажмите Enter');
readln;
End
else
Begin

Repeat
Clrscr;
Writeln;
Writeln('ПЕРЕВОД ЧИСЕЛ ИЗ ',S1,'-НОЙ СИСТЕМЫ СЧИСЛЕНИЯ В ',S2,'-НУЮ И ',S3,'-НУЮ СИСТЕМЫ СЧИСЛЕНИЯ');
Writeln('-------------------------------------------------------------------------------');
Writeln;

Write('Начало диапозона - '); Gotoxy(30,Wherey); Writeln(aa);
Write('Шаг перевода - '); Gotoxy(30,Wherey); Writeln(cc);
Write('Конец диапозона - '); Gotoxy(30,Wherey); Writeln(bb);
Writeln;
Writeln(' ',s1,'-ная ',s,'-ная ',s2,'-ная ',s3,'-ная ');

Write(copy(smac,1,pos('.',smac)+5));

Gotoxy(21,wherey); Write(Perev10(smac):12:5);
Gotoxy(43,wherey); Write(pe(perev10(smac),s2));
Gotoxy(62,wherey); Write(pe(perev10(smac),s3));
Writeln;

While (wherey<=12) and (Perev10(smac)<=b) do
Begin

smac:=summa(smac,cc);
If (Perev10(smac)<=b) then Begin
Write(copy(smac,1,pos('.',smac)+5));
Gotoxy(21,wherey); Write(Perev10(smac):12:5);
Gotoxy(43,wherey); Write(pe(perev10(smac),s2));
Gotoxy(62,wherey); Write(pe(perev10(smac),s3));

Writeln;
End;
End;


If wherey>12 then
Begin
Writeln;
Writeln('Для продолжения нажмите Enter');

CH:=READKEY;
iF CH=#27 THEN HALT;

End;




{}
Until (Perev10(smac)>b);
Writeln;
Writeln('После окончания просмотра результата программы нажмите Enter');


{}
readln;
End;
{}

End


Until e<>32;

End.

Сообщение отредактировано: klem4 - 11.12.2005 13:36

[klem4]

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


p.s. FAQ : Системы счисления

Сообщение отредактировано: klem4 - 11.12.2005 13:37

[Гость]

Должна вывести на экран в виде таблицы значения чисел из интервала от A до B с шагом C в системах счисления с основаниями S, P, Q, R. Числа A, B, C задаются в системе счисления с основанием S, A>=0, B>A. Обеспечить точность 5 знаков после запятой во всех системах счисления. Разработайте функцию для сложения двух чисел в системе счисления с основанием S.