Postanowiłem sprawdzić czy da się to napisać trzy razy krótsze z łatwą możliwością rozszerzenia, no i się udało:
uses Crt,Math;
type TParamKind=(pkSideA,pkSideB,pkSideC,pkHeight,pkRadius);
type TParamKindSet=set of TParamKind;
type TParams=array[TParamKind]of Double;
type TCalcFun=function(const arg:TParams):Double;
type TSubFun=procedure(Kind:Byte);
type TSubMenuItem=record Kind:Byte; Name,Info:String; Params:TParamKindSet; Fun:TCalcFun; end;
function Square(const arg:TParams):Double; begin Result:=Sqr(arg[pkSideA]); end;
function Mul2(const arg:TParams):Double; begin Result:=arg[pkSideA]*arg[pkSideB]; end;
function Trap(const arg:TParams):Double; begin Result:=(arg[pkSideA]+arg[pkSideB])*arg[pkHeight]/2; end;
function Kolo(const arg:TParams):Double; begin Result:=2*Pi*arg[pkRadius]; end;
function HalfMul(const arg:TParams):Double; begin Result:=arg[pkSideA]*arg[pkHeight]/2; end;
function Ball(const arg:TParams):Double; begin Result:=4*arg[pkRadius]*arg[pkRadius]*arg[pkRadius]/3; end;
function Mul3(const arg:TParams):Double; begin Result:=arg[pkSideA]*arg[pkSideB]*arg[pkSideC]; end;
function Cube(const arg:TParams):Double; begin Result:=arg[pkSideA]*arg[pkSideA]*arg[pkSideA]; end;
function Info(const arg:TParams):Double;
begin
WriteLn(' ***************************************************');
WriteLn(' *-==Program do obliczania pol i objętości figur==-*');
WriteLn(' ***************************************************');
end;
const Prog:array[0..10]of TSubMenuItem=
(
(Kind:0;Name:'Informacje o programie';Info:'Informacja o programie';Params:[];Fun:@Info),
(Kind:0;Name:'Oblicz objętości';Info:'';Params:[];Fun:@Info),
(Kind:0;Name:'Oblicz pola';Info:'';Params:[];Fun:@Info),
(Kind:1;Name:'Objętość kuli';Info:'Obliczenie objętości kuli';Params:[pkRadius];Fun:@Ball),
(Kind:1;Name:'Objętość prostopadłościanu';Info:'Obliczenie objętości prostopadłościanu';Params:[pkSideA,pkSideB,pkSideC];Fun:@Mul3),
(Kind:1;Name:'Objętość sześcianu';Info:'Obliczenie objętości sześcianu';Params:[pkSideA];Fun:@Cube),
(Kind:2;Name:'Pole kwadratu';Info:'Obliczenie pola kwadratu';Params:[pkSideA];Fun:@Square),
(Kind:2;Name:'Pole prostokąta';Info:'Obliczenie pola prostokąta';Params:[pkSideA,pkSideB];Fun:@Mul2),
(Kind:2;Name:'Pole trapezu';Info:'Obliczenie pola trapezu';Params:[pkSideA,pkSideB,pkHeight];Fun:@Trap),
(Kind:2;Name:'Pole koła';Info:'Obliczenie pola koła';Params:[pkRadius];Fun:@Kolo),
(Kind:2;Name:'Pole trójkąta';Info:'Obliczenie pola trójkąta';Params:[pkSideA,pkHeight];Fun:@HalfMul)
);
procedure Calc(P:Integer);
var K:TParamKind;
const arg:TParams=(0,0,0,0,0);
const Params:array[TParamKind]of String=( 'bok a','bok b','bok c','wysokość h','promień r' );
begin
TextBackGround(black);
ClrScr;
if P=0 then Prog[P].Fun(arg)
else
begin
TextColor(green);
WriteLn(Prog[P].Info);
WriteLn;
for K:=Low(TParamKind) to High(TParamKind) do
begin
if K in Prog[P].Params then
begin
TextColor(magenta);
Write('Podaj '+Params[K]+': ');
TextColor(yellow);
Readln(arg[K]);
WriteLn;
end;
end;
WriteLn;
TextColor(cyan);
WriteLn(Prog[P].Name+' wynosi: ',Prog[P].Fun(arg):1:2);
end;
WriteLn;
WriteLn;
TextColor(white);
Write('Naciśnij dowolny klawisz ');
if ReadKey=#0 then ReadKey;
end;
procedure Menu(Kind,HalfWidth,Top:Byte);
var I,P,S,N:Integer;
var Key:Word;
var Name:String;
const FgClr:array[Boolean]of Word=(white,yellow);
const BgClr:array[Boolean]of Word=(black,blue);
begin
TextBackGround(black);
ClrScr;
S:=0;
while true do
begin
P:=0;
N:=0;
for I:=Low(Prog) to Length(Prog) do
begin
if I>High(Prog) then Name:='Powrót'
else if Kind=Prog[I].Kind then Name:=Prog[I].Name
else Continue;
TextColor(FgClr[P=S]);
TextBackGround(BgClr[P=S]);
GotoXY(HalfWidth-(Length(Name)-1)shr(1),Top+P);
Write(' '+Name+' ');
if P=S then N:=I;
Inc(P);
end;
GotoXY(HalfWidth,Top+P);
Key:=Ord(ReadKey);
if Key=0 then Key:=Ord(ReadKey)shl(8);
case Key of
$4800: S:=(S+P-1)mod(P);
$5000: S:=(S+1)mod(P);
27: Break;
13:
begin
if S+1=P then Break;
if (Prog[N].Params=[])and(N>0) then Menu(S,HalfWidth,Top) else Calc(N);
TextBackGround(black);
ClrScr;
end;
end;
end;
end;
begin
Menu(0,40,11);
end.
Druga wersja, jeszcze krótsza bo bez funkcji:
uses Crt,Math;
type TParamKind=(pkSideA,pkSideB,pkSideC,pkHeight,pkRadius);
type TParamKindSet=set of TParamKind;
type TSubMenuItem=record
Kind:Byte;
Name,Info:String;
Params:TParamKindSet;
Equal:array[0..1]of record Mul:Double; Tb:array[TParamKind]of Byte; end;
end;
const Prog:array[0..10]of TSubMenuItem=
(
(Kind:0;Name:'Informacje o programie';Info:'';Params:[];Equal:((Mul:0;Tb:(0,0,0,0,0)),(Mul:0;Tb:(0,0,0,0,0)))),
(Kind:0;Name:'Oblicz objętości';Info:'';Params:[];Equal:((Mul:0;Tb:(0,0,0,0,0)),(Mul:0;Tb:(0,0,0,0,0)))),
(Kind:0;Name:'Oblicz pola';Info:'';Params:[];Equal:((Mul:0;Tb:(0,0,0,0,0)),(Mul:0;Tb:(0,0,0,0,0)))),
(Kind:1;Name:'Objętość kuli';Info:'Obliczenie objętości kuli';Params:[pkRadius];Equal:((Mul:4*Pi/3;Tb:(0,0,0,0,3)),(Mul:0;Tb:(0,0,0,0,0)))),
(Kind:1;Name:'Objętość prostopadłościanu';Info:'Obliczenie objętości prostopadłościanu';Params:[pkSideA,pkSideB,pkSideC];Equal:((Mul:1;Tb:(1,1,1,0,0)),(Mul:0;Tb:(0,0,0,0,0)))),
(Kind:1;Name:'Objętość sześcianu';Info:'Obliczenie objętości sześcianu';Params:[pkSideA];Equal:((Mul:1;Tb:(3,0,0,0,0)),(Mul:0;Tb:(0,0,0,0,0)))),
(Kind:2;Name:'Pole kwadratu';Info:'Obliczenie pola kwadratu';Params:[pkSideA];Equal:((Mul:1;Tb:(2,0,0,0,0)),(Mul:0;Tb:(0,0,0,0,0)))),
(Kind:2;Name:'Pole prostokąta';Info:'Obliczenie pola prostokąta';Params:[pkSideA,pkSideB];Equal:((Mul:1;Tb:(1,1,0,0,0)),(Mul:0;Tb:(0,0,0,0,0)))),
(Kind:2;Name:'Pole trapezu';Info:'Obliczenie pola trapezu';Params:[pkSideA,pkSideB,pkHeight];Equal:((Mul:0.5;Tb:(1,0,0,1,0)),(Mul:0.5;Tb:(0,1,0,1,0)))),
(Kind:2;Name:'Pole koła';Info:'Obliczenie pola koła';Params:[pkRadius];Equal:((Mul:Pi;Tb:(0,0,0,0,2)),(Mul:0;Tb:(0,0,0,0,0)))),
(Kind:2;Name:'Pole trójkąta';Info:'Obliczenie pola trójkąta';Params:[pkSideA,pkHeight];Equal:((Mul:0.5;Tb:(1,0,0,1,0)),(Mul:0;Tb:(0,0,0,0,0))))
);
procedure Info;
begin
WriteLn(' ***************************************************');
WriteLn(' *-==Program do obliczania pol i objętości figur==-*');
WriteLn(' ***************************************************');
end;
procedure Calc(P:Integer);
var K:TParamKind;
var Value,Add0,Add1:Double;
const Params:array[TParamKind]of String=( 'bok a','bok b','bok c','wysokość h','promień r' );
begin
TextBackGround(black);
ClrScr;
TextColor(2);
WriteLn(Prog[P].Info);
WriteLn;
Add0:=Prog[P].Equal[0].Mul;
Add1:=Prog[P].Equal[1].Mul;
for K:=Low(TParamKind) to High(TParamKind) do
begin
if K in Prog[P].Params then
begin
TextColor(magenta);
Write('Podaj '+Params[K]+': ');
TextColor(yellow);
Readln(Value);
Add0:=Add0*Power(Value,Prog[P].Equal[0].Tb[K]);
Add1:=Add1*Power(Value,Prog[P].Equal[1].Tb[K]);
WriteLn;
end;
end;
WriteLn;
TextColor(cyan);
WriteLn(Prog[P].Name+' wynosi: ',Add0+Add1:1:2);
WriteLn;
WriteLn;
TextColor(white);
Write('Naciśnij dowolny klawisz ');
if ReadKey=#0 then ReadKey;
end;
procedure Menu(Kind,HalfWidth,Top:Byte);
var I,P,S,N:Integer;
var Key:Word;
var Name:String;
const FgClr:array[Boolean]of Word=(white,yellow);
const BgClr:array[Boolean]of Word=(black,blue);
begin
TextBackGround(black);
ClrScr;
S:=0;
while true do
begin
P:=0;
N:=0;
for I:=Low(Prog) to High(Prog)+1 do
begin
if I>High(Prog) then Name:='Powrót'
else if Kind=Prog[I].Kind then Name:=Prog[I].Name
else Continue;
TextColor(FgClr[P=S]);
TextBackGround(BgClr[P=S]);
GotoXY(HalfWidth-(Length(Name)-1)shr(1),Top+P);
Write(' '+Name+' ');
if P=S then N:=I;
Inc(P);
end;
GotoXY(HalfWidth,Top+P);
Key:=Ord(ReadKey);
if Key=0 then Key:=Ord(ReadKey)shl(8);
case Key of
$4800: S:=(S+P-1)mod(P);
$5000: S:=(S+1)mod(P);
27: Break;
13:
begin
if S+1=P then Break;
if N=0 then Info else if Prog[N].Params=[] then Menu(S,HalfWidth,Top) else Calc(N);
TextBackGround(black);
ClrScr;
end;
end;
end;
end;
begin
Menu(0,40,11);
end.