6 Заключение.
В ходе выполнения курсовой работы мною был изучен язык програмированния Pascal. Также получены практические навыки работы с текстовыми строками, двумерными массивами, файловыми структурами данных, элементами машинной графики и записями.
7 Приложения А
Код программы 1
program slova1;
uses crt;
type
Stroka250=string[250];
Slovo=string[20];
function Copy1(S: Stroka250; Start, Len: Integer):Stroka250;
var
Rez: Stroka250;
L: Integer;
I, J: Integer;
begin
L:=byte(S[0]);
if (L<Start) then
Rez[0]:=char(0)
else
begin
if (Start+Len-1)>L then
Len:=L-Start+1;
J:=Start;
for I:=1 to Len do
begin
Rez[I]:=S[J];
Inc(J);
end;
Rez[0]:=char(Len);
end;
Copy1:=Rez;
end;
function isletter(C: Char): Boolean;
begin
if ((C>=A) and (C<=Z)) or ((C>=a) and (C<=z)) then
isletter:=True
else
isletter:=False;
end;
function alforder(Sl: Slovo; var Count: Byte): Boolean;
var
I, L: Byte;
F: Boolean;
Buf: Char;
begin
L:=Length(Sl);
Count:=0;
for I:=1 to L do
begin
if (isletter(Sl[I])) then
Inc(Count);
if (Sl[I]>=A) and (Sl[I]<=Z) then
Sl[I]:=char(byte(Sl[I])+32);
end;
{esli v slove net bukv}
if Count=0 then
alforder:=False
else
if Count=1 then
alforder:=True
else
begin
F:=True;
While F do
begin
F:=False;
for I:=1 to L-1 do
if (Not isletter(Sl[I])) And (isletter(Sl[I+1])) then
begin
F:=True;
Buf:=Sl[I];
Sl[I]:=Sl[I+1];
Sl[I+1]:=Buf;
end;
end;
F:=true;
for I:=1 to Count-1 do
if Sl[I]>Sl[I+1] then
begin
F:=False;
break;
end;
alforder:=F;
end;
end;
procedure alfslovo(S: Stroka250);
var
F: boolean;
Len: Byte;
I: Byte;
Counter: Byte;
FSlovo, Buf: Slovo;
Index, L: Byte;
MaxCol: Byte;
begin
Len:=Length(S);
if S[Len]<> then
begin
S:=S+ ;
Inc(Len);
end;
F:=False;
MaxCol:=0;
for I:=1 to Len do
if S[I]<> then
begin
if F=False then
begin
F:=True;
Index:=I;
L:=1;
end
else
Inc(L);
end
else
if F=True then
begin
F:=False;
Buf:=Copy1(S, Index, L);
Buf[0]:=char(L);
if alforder(Buf, Counter) then
begin
if Counter>MaxCol then
begin
FSlovo:=Copy1(S, Index, L);
FSlovo[0]:=char(L);
MaxCol:=Counter;
end;
end;
end;
if MaxCol=0 then
writeln(Net podhodyaschi slov v texte)
else
writeln(FSlovo, kol-vo bukv: , MaxCol);
end;
function simmetr(S: Slovo):boolean;
var
L, I, R: Byte;
F: Boolean;
begin
L:=Length(S);
R:=L div 2;
F:=True;
for I:=1 to R do
if S[I]<>S[L-I+1] then
begin
F:=False;
break;
end;
simmetr:=F;
end;
procedure colsimmslovo(S: Stroka250);
var
F: boolean;
Len: Byte;
I: Byte;
Counter: Byte;
Buf: Slovo;
Index, L: Byte;
MaxCol: Byte;
begin
Len:=Length(S);
if S[Len]<> then
begin
S:=S+ ;
Inc(Len);
end;
F:=False;
Counter:=0;
writeln(Spisok simmetrichnyh slov iz bolshe chem 2 znaka:);
for I:=1 to Len do
if S[I]<> then
begin
if F=False then
begin
F:=True;
Index:=I;
L:=1;
end
else
Inc(L);
end
else
if F=True then
begin
F:=False;
if L>2 then
begin
Buf:=Copy(S, Index, L);
Buf[0]:=char(L);
if simmetr(Buf) then
begin
Inc(Counter);
writeln(Buf);
end;
end;
end;
writeln(Kol-vo naidennyh slov: , Counter);
end;
procedure menu;
begin
writeln;
writeln(++++++++++++++++++++++++++++++++++++++++++++++++);
writeln(+ Vvod texta --> 1 +);
writeln(+ Slovo s max. kol.bukv v alf. poryadke --> 2 +);
writeln(+ Simmetrichnye slova --> 3 +);
writeln(+ Vyvod texta --> 4 +);
writeln(+ +);
writeln(+ Konec --> 0 +);
writeln(++++++++++++++++++++++++++++++++++++++++++++++++);
writeln;
end;
var
Txt: Stroka250;
Vvod, Cont: Boolean;
Rem: Char;
begin
Vvod:=False;
Cont:=True;
while Cont do
begin
clrscr;
menu;
write(Vvedite komandu: );
readln(Rem);
case Rem of
0: Cont:=False;
1: begin
writeln(Text:);
readln(Txt);
Vvod:=True;
end;
2: begin
if Not Vvod then
writeln(Ne vveden text)
else
alfslovo(Txt);
end;
3: begin
if Not Vvod then
writeln(Ne vveden text)
else
colsimmslovo(Txt);
end;
4: begin
if Not Vvod then
writeln(Ne vveden text)
else
writeln(Txt);
end
else
writeln(Neizvestnaya komanda);
end;
if Cont then
begin
write(Nagmite ENTER dlya vvoda sleduyuschei komandy... );
readln;
end
else
clrscr;
end;
end.
8 Приложение Б
Код программы 2
program massiv1;
uses crt;
type
Matrix=array[1..20,1..20] of Integer;
type
Vector=array[1..80] of Integer;
procedure TurnArray(var V: Vector; NN: Integer; Rev: Integer);
var
Buf: Integer;
I, J: Integer;
begin
for J:=1 to Rev do
begin
Buf:=V[NN];
for I:=NN downto 2 do
V[I]:=V[I-1];
V[1]:=Buf;
end;
end;
procedure TurnMatrix(var A: Matrix; N: Integer);
var
Arr: Vector;
I, J, K, Ot, L: Integer;
R: Integer;
Revers: Integer;
Buf1, Buf2: Integer;
begin
R:=N div 2;
Ot:=0;
for K:=1 to R do
begin
L:=0;
for J:=1+Ot to N-Ot do
begin
Inc(L);
Arr[L]:=A[1+Ot, J];
end;
for I:=2+Ot to N-1-Ot do
begin
Inc(L);
Arr[L]:=A[I, N-Ot];
end;
for J:=N-Ot downto 1+Ot do
begin
Inc(L);
Arr[L]:=A[N-Ot, J];
end;
for I:=N-1-Ot downto 2+Ot do
begin
Inc(L);
Arr[L]:=A[I, 1+Ot];
end;
Revers:=N-2*Ot-1;
TurnArray(Arr, L, Revers);
L:=0;
for J:=1+Ot to N-Ot do
begin
Inc(L);
A[1+Ot, J]:=Arr[L];
end;
for I:=2+Ot to N-1-Ot do
begin
Inc(L);
A[I, N-Ot]:=Arr[L];
end;
for J:=N-Ot downto 1+Ot do
begin
Inc(L);
A[N-Ot, J]:=Arr[L];
end;
for I:=N-1-Ot downto 2+Ot do
begin
Inc(L);
A[I, 1+Ot]:=Arr[L];
end;
Inc(Ot);
end;
end;
procedure FormMatrix(var A: Matrix; N, M: Integer);
var
I, J: Integer;
D: Integer;
R: Integer;
begin
randomize;
for I:=1 to N do
for J:=1 to M do
begin
A[I,J]:=random(100);
if (random(1000) mod 2)=0 then
A[I,J]:=0-A[I,J];
end;
end;
procedure PrintMatrix(var A: Matrix; N, M: Integer);
var
I, J: Integer;
begin
for I:=1 to N do
begin
for J:=1 to M do
write(A[I,J]:4);
writeln;
end;
end;
var
Matr: Matrix;
N: Integer;
begin
clrscr;
repeat
write(Razmer matricy (12..20): );
readln(N);
until (N>=12) and (N<=20);
FormMatrix(Matr, N, N);
writeln(Sformirovana matrica:);
PrintMatrix(Matr, N, N);
TurnMatrix(Matr, N);
writeln(Matrica posle povorota);
PrintMatrix(Matr, N, N); readln;
end.
9 Приложение В
Код программы 3
program textfile;
uses
crt;
type
arr = array [1..83] of string;
var
slova1, slova2, slova: arr;
m, m1, m2, k1, k2, k, l, g: integer;
first, second, third: text;
command: char;
p, v, t, S1, S2: string;
pf, vf, tf, cont, flag1, flag2: boolean;
function check2: boolean;
begin
if eof(first) = true then flag1 := true else flag1 := false;
if eof(second) = true then flag2 := true else flag2 := false;
if (flag1 = false) and (flag2 = false) then check2 := false else check2 := true;
end;
procedure closing;
begin
close(first);
close(second);
close(third);
end;
procedure obrslov(a, b: arr; na, nb: integer; var c: arr; var nc: integer);
var
i, j, k: integer;
begin
nc := 0;
for i := 1 to na do
begin
k := 0;
for j := 1 to nb do
if a[i] = b[j] then k := 1;
if k = 0 then
begin
nc := nc + 1;
c[nc] := a[i];
end;
end;
for i := 1 to nb do
begin
k := 0;
for j := 1 to na do
if b[i] = a[j] then k := 1;
if k = 0 then
begin
nc := nc + 1;
c[nc] := b[i];
end;
end;
end;
procedure slv;
var
i, j: integer;
begin
Readln(first, S1);
readln(second, S2);
S1 := + S1 + ;
S2 := + S2 + ;
k1 := 0;
k2 := 0;
for i := 1 to length(S1) do
begin
if s1[i] = then
begin
for j := i + 1 to length(s1) do
if s1[i + 1] <> then
if s1[j] = then begin
k1 := k1 + 1;
slova1[k1] := copy(s1, i + 1, j - i - 1);
break;
end;
end;
end;
for i := 1 to length(S2) do
begin
if s2[i] = then
begin
for j := i + 1 to length(s2) do
if s2[i + 1] <> then
if s2[j] = then begin
k2 := k2 + 1;
slova2[k2] := copy(s2, i + 1, j - i - 1);
break;
end;
end;
end;
end;
procedure chmax;
begin
m1 := 0;
m2 := 0;
while not eof(first) do
begin
readln(first, S1);
m1 := m1 + 1;
end;
while not eof(second) do
begin
readln(second, S2);
m2 := m2 + 1;
end;
if m1 < m2 then m := m1 else m := m2;
close(first);
reset(first);
close(second);
reset(second);
end;
procedure filepr;
begin
assign(first, p);
assign(second, v);
assign(third, t);
reset(first);
reset(second);
rewrite(third);
end;
function check1(x: string): boolean;
begin
if length(x) > 0 then begin
if x[1] <> then
check1 := true;
end;
end;
procedure menu;
begin
writeln;
writeln(++++++++++++++++++++++++++++++++++++++++++++++++);
writeln(+ Vvod imeni pervogo faila --> 1 +);
writeln(+ Vvod imeni vtorogo faila --> 2 +);
writeln(+ Vvod imeni tretiego faila --> 3 +);
writeln(+ Preobrazovat tretii fail --> 4 +);
writeln(+ +);
writeln(+ Konec --> 0 +);
writeln(++++++++++++++++++++++++++++++++++++++++++++++++);
writeln;
end;
begin
menu;
pf := false;
vf := false;
tf := false;
cont := true;
flag1 := false;
flag2 := false;
while cont do
begin
writeln;
write(Vvedite komandu: );
readln(command);
case command of
0: cont := false;
1:
begin
write(Vvedite imja pervogo faila: );
readln(p);
if check1(p) = true then
begin
pf := true;
clrscr;
menu;
end
else
begin
clrscr;
menu;
writeln(Error input);
end;
end;
2:
begin
write(Vvedite imja vtorogo faila: );
readln(v);
if check1(v) = true then
begin;
vf := true;
clrscr;
menu;
end
else
begin
clrscr;
menu;
writeln(Error input);
end;
end;
3:
begin
write(Vvedite imja tretego faila: );
readln(t);
if check1(t) = true then
begin
tf := true;
clrscr;
menu;
end
else
begin
clrscr;
menu;
writeln(Error input);
end;
end;
4:
begin
if (pf = true) and (vf = true) and (tf = true) then
begin
filepr;
chmax;
if check2 = false then
begin
for l := 1 to m do
begin
slv;
obrslov(slova1, slova2, k1, k2, slova, k);
for g := 1 to k do
begin
write(third, slova[g]);
if g < k then write(third, );
end;
writeln(third, );
end;
if m1 <> m2 then
begin
if m1 > m2 then for L := m to m1 do
begin
readln(first, S1);
writeln(third, S1);
end
else
for L := m to m2 do
begin
readln(second, S2);
Writeln(third, S2);
end;
end;
closing;
writeln(Operacia zavershena);
end
else
begin
if flag1 = true then writeln(Pervii fail pustoi);
if flag2 = true then writeln(Vtoroi fail pustoi);
end;
end
else
begin
if pf = false then writeln(Ne vvedeno imja pervogo faila);
if vf = false then writeln(Ne vvedeno imja vtorogo faila);
if tf = false then writeln(Ne vvedeno imja tretego faila);
end;
end;
else
writeln( Neizvestnaya komanda);
end;
end;
end.
10 Приложение Г
Код программы 4
program grafik;
uses
graphabc;
var
xx, yy, a, d, maxy, maxx: integer;
t, k: real;
fileg: text;
cont, namef: boolean;
command: char;
name: string;
function Yfunc(i: real): real;
begin
result := A * sin(i) - D * sin(A * t);
end;
function Xfunc(i: real): real;
begin
result := A * cos(i) + D * cos(A * i);
end;
procedure mnoj;
begin
t := 0;
while t <= 2 * pi do
begin
xx := trunc(Xfunc(t));
if abs(xx) > maxx then maxx := abs(xx);
yy := trunc(Yfunc(t));
if abs(yy) > maxy then maxy := abs(yy);
t := t + 0.001;
end;
if WindowWidth < WindowHeight then
if maxy > maxx then k := (WindowHeight / 2) / maxy else k := (windowWidth / 2) / maxx else
if maxx > maxy then k := (windowheight / 2) / maxx else k := (windowWidth / 2) / maxy;
end;
procedure graf;
begin
k := k - k * 0.1;
moveto(1, windowHeight div 2);
lineto(WindowWidth, WindowHeight div 2);
moveto(WindowWidth div 2, 1);
lineto(WindowWidth div 2, WindowHeight);
moveto(trunc((WindowWidth div 2) * 0.98), trunc(0.04 * WindowHeight));
Lineto((Windowwidth div 2), 1);
lineto(trunc((windowWidth div 2) * 1.02), trunc(0.04 * windowHeight));
moveto(trunc(windowwidth * 0.96), trunc(0.98 * (windowheight div 2)));
lineto(windowwidth, windowheight div 2);
lineto(trunc(windowwidth * 0.96), trunc(1.02 * (windowheight div 2)));
T := 0;
xx := (WindowWidth div 2) + trunc(k * Xfunc(t));
yy := (WindowHeight div 2) + trunc(k * Yfunc(t));
moveto(xx, yy);
while t <= 2 * pi do
begin
xx := (WindowWidth div 2) + trunc(k * Xfunc(t));
yy := (WindowHeight div 2) + trunc(k * Yfunc(t));
lineto(xx, yy);
t := t + 0.0001;
end;
if WindowWidth > 400 then
if Windowheight > 200 then
begin
textout(trunc(1.05 * (windowWidth div 2)), trunc(0.01 * (WindowHeight )), Y);
Textout(trunc(0.95 * WindowWidth), trunc((WindowHeight div 2) * 1.05), X);
end;
end;
function check1: boolean;
begin
if length(name) > 0 then
begin
assign(fileg, name);
reset(fileg);
if eof(fileg) = false then check1 := true else check1 := false;
end;
end;
procedure menu;
begin
writeln;
writeln(++++++++++++++++++++++++++++++++++++++++++++++++);
writeln(+ Vvod imeni faila s parametrami --> 1 +);
writeln(+ Porstroenie grafika --> 2 +);
writeln(+ Vihod --> 0 +);
writeln(++++++++++++++++++++++++++++++++++++++++++++++++);
writeln;
end;
procedure resize;
begin
mnoj;
ClearWindow;
graf;
redraw;
lockdrawing;
end;
begin;
t := 0;
menu;
cont := true;
while cont do
begin
Writeln(Vvedite komady: );
Readln(command);
case command of
0: cont := false;
1:
begin
writeln;
writeln(Vvedite imja faila: );
Readln(name);
if check1 = true then begin
namef := true;
read(fileg, a);
read(fileg, d);
close(fileg);
end else namef := false;
end;
2:
begin
if namef = false then
writeln(Ne Vvedeno imja faila)
else
begin
clearwindow;
SetWindowSize(800, 600);
mnoj;
graf;
cont := false;
end;
end;
end;
end;
lockdrawing;
OnResize := resize;
end.
11 Приложение Д
Код программы 5
program zapisi;
uses
crt;
type
vladelez = record
Familia: string;
Adress: string;
Avto: string;
Nomer: string;
Vypusk: integer;
end;
mas2 = array [1..200] of boolean;
mas = array [1..200] of vladelez;
var
command: char;
cont, fzap, dzap: boolean;
avtovl: mas;
n: integer;
i: integer;
ch: mas2;
marki: set of string;
procedure oprmarki(x: mas);
var
h: integer;
m: string;
begin
Write(Vvedite marku avto: );
readln(m);
for h := 1 to n do
if x[h].Avto = m then
writeln(x[h].Familia, nomer-, x[h].Nomer);
end;
procedure mostold(x: mas);
var
min, nmin, h: integer;
begin
min := x[1].Vypusk;
nmin := 1;
for h := 1 to n do
if x[h].Vypusk < min then
begin
min := x[h].Vypusk;
nmin := h;
end;
Writeln(x[nmin].Familia, - , min, god vypuska);
end;
procedure mark(x: mas);
var
h, l, k: integer;
begin
for h := 1 to n do
begin
if not (x[h].avto in marki) = true then
begin
k := 0;
include(marki, x[h].avto);
for l := h to n do
if x[h] = x[l] then
if x[l].avto in marki then
k := k + 1;
writeln(x[h].avto, -, k);
end;
end;
end;
procedure change(x: integer; var z: mas; var v: mas2);
begin
clrscr;
v[x] := true;
write(Vvedite familiu: );
readln(z[x].familia);
write(Vvedite adress: );
readln(z[x].adress);
write(Vvedite marku avto: );
readln(z[x].avto);
write(Vvedite nomer avto: );
readln(z[x].nomer);
z[x].Vypusk := 0;
while (z[x].Vypusk < 1900) or (z[x].Vypusk > 2000) do
begin
write(Vvedite god vipuska(1900..2000): );
readln(z[x].vypusk);
end;
end;
procedure menu;
begin
writeln;
Writeln(+++++++++++++++++++++++++++++++++++++++++++++++++++++);
writeln(+ Ykazat kolichestvo zapisei ->1 +);
writeln(+ Izmenit vse zapisi ->2 +);
writeln(+ Izmenit odny zapis ->3 +);
writeln(+ Kolichestvo avtomobilei kazdoi marki ->4 +);
writeln(+ Vladelec samogo starogo avtomobila ->5 +);
writeln(+ Familii vladelcev i nomera avto dannoi marki ->6 +);
Writeln(+ +);
writeln(+ Konec ->0 +);
Writeln(+++++++++++++++++++++++++++++++++++++++++++++++++++++);
writeln;
end;
begin
for i := 1 to 200 do
ch[i] := false;
clrscr;
menu;
cont := true;
fzap := false;
while cont do
begin
write(Vvedite komandu: );
readln(command);
case command of
0: cont := false;
1:
begin
Write(Vvedite kol-vo zapisei(1..200): );
readln(n);
if (n > 0) and (n <= 200) then
fzap := true else fzap := false;
end;
2:
begin
if fzap = true then
begin
for i := 1 to n do
change(i, avtovl, ch);
clrscr; menu;
end
else writeln(Ne vvedeno kol-vo zapisei);
end;
3:
begin
if fzap = true then
begin
write(Vvedite nomer redaktiryemoi zapisi: );
readln(i);
if i > n then writeln(Wrong input)
else
begin
change(i, avtovl, ch);
clrscr;
menu;
end;
end
else Writeln(Ne vvedeno obshee chislo zapisei);
end;
4:
begin
if fzap = true then
begin
for i := 1 to n do
if ch[i] = false then
begin
dzap := false;
writeln(Vvedeni ne vse zapisi);
end
else dzap := true;
if dzap = true then
mark(avtovl);
end
else
Writeln(Ne vvedeno obshee chislo zapisei);
end;
5:
begin
if fzap = true then
begin
for i := 1 to n do
if ch[i] = false then
begin
dzap := false;
writeln(Vvedeni ne vse zapisi);
end
else dzap := true;
if dzap = true then
mostold(avtovl);
end
else
Writeln(Ne vvedeno obshee chislo zapisei);
end;
6:
begin
if fzap = true then
begin
for i := 1 to n do
if ch[i] = false then
begin
dzap := false;
writeln(Vvedeni ne vse zapisi);
end
else dzap := true;
if dzap = true then
oprmarki(avtovl);
end
else
Writeln(Ne vvedeno obshee chislo zapisei);
end;
end;
end;
end.