數據結構——Pascal實現
pascal求最大公約數html
program mygcd;
function gcd(a,b:longint):longint;
begin
if b=0 then gcd:=a
else gcd:=gcd(b,a mod b);
end;
var
x,y:longint;
begin
x:=24;
y:=36;
writeln('最大公約數爲:',gcd(x,y));
readln;
end.
------------------------非遞歸算法-------------------------------------------------
program mygcd;
function gcd(a,b:longint):longint;
Var
c:longint;
begin
repeat
c:=a mod b;
a:=b;
b:=c;
until c=0;
exit(a)
end;
var
x,y:longint;
begin
x:=24;
y:=36;
writeln('最大公約數爲:',gcd(x,y));
readln;
end.
任意輸入一正整數N，把它拆成質因子node
program factorization;
var n,k,i:longint;
begin
writeln('你好,請輸入一個正整數,分解爲質因子:');
readln(n);
k:=n;
while k>1 do
for i:=2 to n do
if k mod i=0 then
begin
write(i,' ');
k:=k div i;
break;
end;
writeln
end.
判斷是否爲素數：算法
program getPrime(input,output);
const m=1000;
var
i,mycount:integer;
function IsPrime (x: integer): Boolean;
var
f:boolean;
begin
f:=true;
if x<2 then
begin
write('F');
halt
end;
for i:=2 to trunc(sqrt(x)) do
if x mod i=0 then f:=false;
if f then IsPrime:=true
else IsPrime:=false
end;
begin
writeln('prime number Less than ',m);
mycount:=0;
for i:=2 to m do begin
if IsPrime(i) then
begin
mycount:=mycount+1;
write(i:4);
if (mycount mod 30) = 0 then writeln
end
end;
writeln
end.
1、線性表
program linearList;
const maxlen=100;
type mylist=record
data : array[1..maxlen] of char;
last : 0..maxlen
end;
var
i,p: integer;
l,l1,l2 : mylist;
x:char;
function length(var sq:mylist) : integer;
begin
length :=sq.last;
end;
function locate(var sq:mylist;x:char):integer;
var
i:integer;
begin
for i:=1 to length(sq) do begin
if(sq.data[i]=x) then begin
exit(i);
end;
end;
exit(0);
end;
procedure intlist(var sq:mylist);
begin
randomize;
for i:=1 to 10 do
begin
sq.data[i]:=chr(65+round(random(26)));
inc(sq.last);
end;
end;
procedure intlist0(var sq:mylist);
begin
sq.last:=0
end;
procedure printlist(var sq:mylist);
begin
for i:=1 to length(sq) do write(sq.data[i]);
writeln;
end;
procedure insert(var sq:mylist;x:char;p:integer);
var
i:integer;
begin
for i:=sq.last+1 downto p do
sq.data[i+1]:=sq.data[i];
sq.data[p]:=x;
sq.last:=sq.last+1;
end;
procedure delete(var sq:mylist;p:integer);
var
i:integer;
begin
for i:=p to sq.last do
sq.data[i]:=sq.data[i+1];
sq.last:=sq.last-1;
end;
procedure merge(var A:mylist;B:mylist);
var
i:integer;
begin
for i:=1 to B.last do begin
if(locate(A,B.data[i])=0) then insert(A,B.data[i],length(A)+1);
end;
end;
procedure merge_list( A,B:mylist;var C:mylist);
{已知非遞減線性表A、B，合併後的C仍然非遞減}
var
i,j,k:integer;
begin
intlist0(C);
i:=1;j:=1;k:=0;
while(i<=length(A))and(j<=length(B)) do
if ord(A.data[i]) <=ord(B.data[j]) then
begin
insert(C,A.data[i],k+1);
k:=k+1;
i:=i+1;
end
else begin
insert(C,B.data[j],k+1);
k:=k+1;
j:=j+1;
end;
while i<=length(A) do begin
insert(C,A.data[i],k+1);
k:=k+1;
i:=i+1;
end;
while j<=length(B) do begin
insert(C,B.data[j],k+1);
k:=k+1;
j:=j+1;
end;
end;
begin
intlist(l);
printlist(l);
writeln('輸入一個字符和整數如:c 4,將字符c插如到第四個字符:');
readln(x,p);
insert(l,x,p);
printlist(l);
writeln('輸入一個整數如:4,將字符第四個字符刪除');
readln(p);
delete(l,p);
printlist(l);
writeln('合併兩個線性表:');
intlist(l1);
printlist(l1);
merge(l,l1);
printlist(l);
intlist0(l); intlist0(l1);
for i:=1 to 10 do
begin
if (i<=5) then begin
insert(l,chr(65+2*i),i);
insert(l1,chr(65+2*i-1),i)
end
else begin
insert(l,chr(65+11+i),i);
insert(l1,chr(65+14+i),i)
end;
end;
printlist(l);
printlist(l1);
merge_list(l,l1,l2);
printlist(l2);
end.
運行數組
$ fpc linearList.pas Free Pascal Compiler version 3.0.0+dfsg-2 [2016/01/28] for x86_64 Copyright (c) 1993-2015 by Florian Klaempfl and others Target OS: Linux for x86-64 Compiling linearList.pas Linking linearList /usr/bin/ld.bfd: 警告: link.res 含有輸出節；您忘記了 -T？ 137 lines compiled, 0.1 sec :~/prg/mypas$ ./linearList LVHIVBPUWY 輸入一個字符和整數如:c 4,將字符c插如到第四個字符: c 4 LVHcIVBPUWY 輸入一個整數如:4,將字符第四個字符刪除 4 LVHIVBPUWY 合併兩個線性表: WMGOPGCMOF LVHIVBPUWYMGOCF CEGIKRSTUV BDFHJUVWXY BCDEFGHIJKRSTUUVVWXY
用類來實現：數據結構
program linearListObj;
const maxlen=100;
type
mylist = object
private
data : array[1..maxlen] of char;
last : 0..maxlen;
public
constructor init(l: integer);
function length() : integer;
procedure printlist();
procedure insert(x:char;p:integer);
function locate(x:char):integer;
procedure empty();
function get(i:integer):char;
end;
var
l,l1 : mylist;
p: integer;
x:char;
constructor mylist.init(l: integer);
var
i:integer;
begin
randomize;
if (l<= 0) then begin
last:=0;
exit;
end;
if (l>maxlen) then l:= maxlen;
for i:=1 to l do
begin
data[i]:=chr(65+round(random(26)));
inc(last);
end;
end;
function mylist.length() : integer;
begin
length := last;
end;
procedure mylist.printlist();
var
i:integer;
begin
for i:=1 to last do write(data[i]);
writeln;
end;
procedure mylist.insert(x:char;p:integer);
var
i:integer;
begin
if (p<= 1) then p:= 1;
if (p>last) then p:= last+1;
for i:=last+1 downto p do
data[i+1]:=data[i];
data[p]:=x;
last:=last+1;
end;
function mylist.locate(x:char):integer;
var
i:integer;
begin
for i:=1 to last do begin
if(data[i]=x) then begin
exit(i);
end;
end;
exit(0);
end;
procedure mylist.empty();
begin
last := 0;
end;
function mylist.get(i:integer):char;
begin
if ((i< 1) or(i>last) ) then exit(chr(0));
exit(data[i]);
end;
operator +(A:mylist; B:mylist) C:mylist;
var
i:integer;
begin
C.init(0);
for i:=1 to A.last do begin
C.insert(A.data[i],C.length+1);
end;
for i:=1 to B.last do begin
C.insert(B.data[i],C.length+1);
end;
end;
operator *(A:mylist; B:mylist) C:mylist;
var
i:integer;
begin
C.init(0);
for i:=1 to A.last do begin
if(C.locate(A.data[i])=0) then C.insert(A.data[i],C.length+1);
end;
for i:=1 to B.last do begin
if(C.locate(B.data[i])=0) then C.insert(B.data[i],C.length+1);
end;
end;
begin
l.init(10);
l.printlist();
writeln('輸入一個字符和整數如:c 4,將字符c插如到第四個字符:');
readln(x,p);
l.insert(x,p);
l.printlist();
writeln('再生成個線性表:');
l1.init(10);
l1.printlist();
writeln('合併兩個線性表:');
l:=l*l1;
l.printlist();
writeln('不去重複項合併兩個線性表:');
l:=l+l1;
for p:=1 to l.length() do write(l.get(p));
writeln;
end.
運行：less
$ fpc linearListObj.pas Free Pascal Compiler version 3.0.0+dfsg-2 [2016/01/28] for x86_64 Copyright (c) 1993-2015 by Florian Klaempfl and others Target OS: Linux for x86-64 Compiling linearListObj.pas Linking linearListObj /usr/bin/ld.bfd: 警告: link.res 含有輸出節；您忘記了 -T？ 108 lines compiled, 0.1 sec $ ./llObjects DXIFTWVNES 輸入一個字符和整數如:c 4,將字符c插如到第四個字符: u 11 DXIFTWVNESu 再生成個線性表: CPLCOTZMAJ 合併兩個線性表: DXIFTWVNESuCPLOZMAJ 不去重複項合併兩個線性表: DXIFTWVNESuCPLOZMAJCPLCOTZMAJ
標準pascal版本（在bsd4.3 vax780編譯經過）dom
program linearList(input, output);
const maxlen=100;
type mylist=record
data : array[1..maxlen] of char;
last : 0..maxlen
end;
var
i,p: integer;
l,l1,l2 : mylist;
x:char;
function length(var sq:mylist) : integer;
begin
length :=sq.last;
end;
function locate(var sq:mylist;x:char):integer;
var
i:integer;
begin
for i:=1 to length(sq) do begin
if(sq.data[i]=x) then begin
locate:=i;
end;
end;
locate:=0;
end;
procedure intlist(var sq:mylist);
begin
sq.last:=0;
for i:=1 to 10 do
begin
sq.data[i]:=chr(65+round(random(26)));
sq.last:=sq.last+1
end;
end;
procedure intlist0(var sq:mylist);
begin
sq.last:=0
end;
procedure printlist(var sq:mylist);
begin
for i:=1 to length(sq) do write(sq.data[i]);
writeln;
end;
procedure insert(var sq:mylist;x:char;p:integer);
var
i:integer;
begin
for i:=sq.last+1 downto p do
sq.data[i+1]:=sq.data[i];
sq.data[p]:=x;
sq.last:=sq.last+1;
end;
procedure delete(var sq:mylist;p:integer);
var
i:integer;
begin
for i:=p to sq.last do
sq.data[i]:=sq.data[i+1];
sq.last:=sq.last-1;
end;
procedure merge(var A:mylist;B:mylist);
var
i:integer;
begin
for i:=1 to B.last do begin
if(locate(A,B.data[i])=0) then insert(A,B.data[i],length(A)+1);
end;
end;
{Known non-decreasing linear tables A and B,merged C is still non-decreasing}
procedure mergeList( A,B:mylist;var C:mylist);
var
i,j,k:integer;
begin
intlist0(C);
i:=1;j:=1;k:=0;
while(i<=length(A))and(j<=length(B)) do
if ord(A.data[i]) <=ord(B.data[j]) then
begin
insert(C,A.data[i],k+1);
k:=k+1;
i:=i+1;
end
else begin
insert(C,B.data[j],k+1);
k:=k+1;
j:=j+1;
end;
while i<=length(A) do begin
insert(C,A.data[i],k+1);
k:=k+1;
i:=i+1;
end;
while j<=length(B) do begin
insert(C,B.data[j],k+1);
k:=k+1;
j:=j+1;
end;
end;
begin
intlist(l);
printlist(l);
writeln('Enter a character and an integer such as: C 4, and insert the character c into the fourth character:');
readln(x,p);
insert(l,x,p);
printlist(l);
writeln('Enter an integer such as: 4, delete the fourth character of the character');
readln(p);
delete(l,p);
printlist(l);
writeln('Merge two linear tables:');
intlist(l1);
printlist(l1);
merge(l,l1);
printlist(l);
intlist0(l); intlist0(l1);
for i:=1 to 10 do
begin
if (i<=5) then begin
insert(l,chr(65+2*i),i);
insert(l1,chr(65+2*i-1),i)
end
else begin
insert(l,chr(65+11+i),i);
insert(l1,chr(65+14+i),i)
end;
end;
printlist(l);
printlist(l1);
mergeList(l,l1,l2);
printlist(l2);
end.
鏈表實現創建一個有10個結點的鏈表，並輸出該鏈表，而後刪除數據爲2的節點並輸出（vax780）yii
{
procedure printlist(var list:point);
function creatlist(lenth:integer):point;
procedure inserthead(var list:point;item:datatype);
procedure insertail(var list:point;item:datatype);
procedure insertloc(var list:point;loc:integer;item:datatype);
procedure PurgeItem(var list:point;item:datatype); Clear items from the list
procedure delItem(var list:point;item:datatype); Delete the first item in the list
}
program mylinkedList(input, output);
type
datatype=integer;
point=^pp;
pp=record
data:datatype;
link:point;
end;
var
head:point;
ListLenth,i:integer;
procedure printlist(var list:point);
var
k:point;
begin
k:=list;
writeln('total number is :',ListLenth);
if (list = nil) then
writeln('List is empty:')
else begin
while k^.link<>nil do
begin
write(k^.data,'->');
k:=k^.link;
end;{end of while}
write(k^.data,'->')
end;{end of else}
writeln;
end;{end of procedure printlist}
function creatlist(lenth:integer):point;
var
p1,p2,k:point;
begin
if lenth < 1 then begin
writeln('List lenth is less than 0,empty list created');
ListLenth:=0;
creatlist:=nil
end{create empty list}
else
begin
new(p1);
writeln('input data');
readln(p1^.data);
k:=p1; {Pointer K points to the list head}
{Generate nine new nodes with a loop, each of which is connected after the last node}
for i:=1 to lenth-1 do
begin
new(p2);
writeln('input data');
readln(p2^.data);
p1^.link:=p2;
p1:=p2;
end;
{Assign a null value NIL to the LINK field of the last node}
p2^.link:=nil; {Assign a null value NIL to the LINK field of the last node}
ListLenth:=lenth;
creatlist:=k
end{else}
end;{end of function creatlist}
{Insert item before the header of the list}
procedure inserthead(var list:point;item:datatype);
var
p:point;
begin
new(p);
p^.data:=item;
p^.link:=nil;
if (list = nil) then begin
ListLenth:=1;
list:=p
end
else begin
p^.link:=list;
ListLenth:=ListLenth+1;
list := p
end
end;{end of procedure inserthead}
procedure insertail(var list:point;item:datatype);
var
p,q:point;
begin
new(p);
p^.data:=item;
p^.link:=nil;
if (list = nil) then begin
ListLenth:=1;
list:=p
end
else begin
q:=list;
while (q^.link <>nil) do q:=q^.link;
q^.link:=p;
ListLenth:=ListLenth+1
end
end;{end of procedure insertail}
procedure insertloc(var list:point;loc:integer;item:datatype);
var
p,q:point;
begin
if (loc > ListLenth) then insertail(list,item)
else if (loc <= 1) then inserthead(list,item)
else begin
q:=list;
for i:=2 to loc-1 do q:=q^.link;
new(p);
p^.data:=item;
p^.link:=q^.link;
q^.link:=p;
ListLenth:=ListLenth+1
end
end;{end of procedure insertloc}
procedure PurgeItem(var list:point;item:datatype);
var
p,q:point;
begin
while (list <>nil)and(list^.data = item) do
begin
q := list;
list:= list^.link;
dispose(q);
ListLenth:=ListLenth-1
end;
if (list <>nil) and (list^.link <>nil) then
begin
p := list;
q := list;
p := list^.link;
while p^.link<>nil do
if (p^.data = item) then begin
q^.link := p^.link;
dispose(p);
p := q^.link;
ListLenth:=ListLenth-1
end
else begin
q := p;
p := p^.link;
end;
if (p^.data = item) then begin
q^.link := nil;
dispose(p);
ListLenth:=ListLenth-1
end;
end{end of if (list <>nil) and (list^.link <>nil) }
end;{end of procedure PurgeItem}
procedure delItem(var list:point;item:datatype);
var
p,q:point;
begin
p := list;
while (p <>nil)and(p^.data <> item) do
begin
q := p;
p:= p^.link;
end;
if (list = p) then
begin if (list <> nil) then
begin
list := list^.link;
ListLenth:=ListLenth-1;
dispose(p)
end
end {end of if (list = p) then}
else if (p^.data = item) then
begin
q^.link := p^.link;
dispose(p);
ListLenth:=ListLenth-1
end
end;{end of procedure delItem}
begin {Generate a new node head as the head of the list}
head:=creatlist(10);
{Output the DATA fields in the list from the list head in turn}
printlist(head);
writeln('call procedure delItem to del first data 2');
delItem(head,2);
printlist(head);
writeln('call procedure PurgeItem to del all data 2');
PurgeItem(head,2);
printlist(head);
writeln('call procedure inserthead & insertail to insert data 2 before head&tail of list:');
inserthead(head,2);
insertail(head,2);
printlist(head);
writeln('call procedure insertloc(head,3,100) to insert 100 as 3th item of list:');
insertloc(head,3,100);
printlist(head);
end.
2、二叉樹的遍歷和生成 ()jsp
program mybtree(input, output);
type
btree=^node;
node=record
data:char;
l,r:btree;
end;
var
head : btree;
procedure inittree(var t:btree);
var
ch:char;
begin
read(ch);
if (ch<>'#') then begin
new(t);
t^.data:=ch;
t^.l:=nil;
t^.r:=nil;
inittree(t^.l);
inittree(t^.r);
end
else t:=nil
end;
procedure TBTpre(var p:btree);
begin
if (p<>nil) then begin
write(p^.data:2);
TBTpre(p^.l);
TBTpre(p^.r)
end;
end;
procedure TBTin(var p:btree);
begin
if (p<>nil) then begin
TBTin(p^.l);
write(p^.data:2);
TBTin(p^.r);
end;
end;
procedure TBTpost(var p:btree);
begin
if (p<>nil) then begin
TBTpost(p^.l);
TBTpost(p^.r);
write(p^.data:2);
end
end;
begin
new(head);
writeln('please input string like ABD##E##C## to make preorder binary tree(#:means nil)');
inittree(head);
readln;
write('this binary tree preorder is: ');
TBTpre(head);
writeln;
write('this binary tree inorder is: ');
TBTin(head);
writeln;
write('this binary tree postorder is:');
TBTpost(head);
readln;
end.
約瑟夫問題 設有n我的圍坐在一個圓桌周圍，現從第s我的開始報數，數到第m我的出列，而後從出列的下一我的從新開始所數，數到第m我的又出列...函數
{Joseph's problem:consists of n people sitting around a round table.
Now we start counting from the s person to the m person.
Then we start counting from the next person to the m person.
}
program josephus(input, output);
var
i,n,k,m,s,w,j :integer;
p:array[1..100] of integer;
begin
writeln('Enter n s m:n for total people ,start counting from the s person,m out:');
repeat readln(n,s,m); until s<=n;
for i:=1 to n do p[i]:=i;
k:=s;
for i:=n downto 2 do
begin
k:=(k+m-1)mod i;
if k=0 then k:=i;
w:=p[k];
if k<i then for j:=k to i-1 do p[j]:=p[j+1];
p[i]:=w;
end;
for i:=n downto 1 do writeln(n-i+1,':',p[i],' ');
writeln;
end.
約瑟夫問題用循環鏈表實現：
program linkjsph(input, output);
type
datatype=integer;
point=^pp;
pp=record
data:datatype;
link:point;
end;
var
head,p,q:point;
i:integer;
function linkcreate(n:integer):point;
var
p1,p2,k:point;
begin
if n < 1 then linkcreate:=nil
else
begin
new(p1);
p1^.data:=1;
p1^.link:=p1;
k:=p1;
for i:=2 to n do
begin
new(p2);
p2^.data:=i;
p2^.link:=p1^.link;
p1^.link:=p2;
p1:=p2
end;
linkcreate:=k
end{else}
end;{end of function linkcreate}
procedure linkprocess(var head:point;k:integer;m:integer); {Start counting from the person numbered K (1 <= K <= n), and list the person counting to M.}
begin
p:=head;
while p^.data<>k do p := p^.link;
while p^.link <> p do
begin
for i:=0 to m-1 do
begin
q := p;
p := p^.link;
end;
write(p^.data,' ');
q^.link:= p^.link;
dispose(p);
p := q^.link;
end;
write(p^.data,' ');
dispose(p)
end;{linkprocess}
begin
head := linkcreate(10);
linkprocess(head,3,1);
writeln
end.
先進先出鏈表（或稱隊）
讀入一批數據，遇負數時中止，將讀入的正數組成先進先出的鏈表並輸出。
分析：首先應定義指針類型，結點類型和指針變量，讀入第一個值，創建首結點，讀入第二個值，判斷它是否大於零，如果，創建新結點。
{
Establishing First in First Out Link List.Read in a batch of data, stop when the number is negative,
and compose the positive number into a first-in-first-out list and output it.
}
program linkfifo(input,output);
type
point=^node;
node=record
data:real;
link:point
end;
var
head,last,next:point;
x:real;
begin
{Read in the first value and establish the first node}
read(x);
write(x:6:1);
new(head);
head^.data:=x;
last:=head; {Read in the second value}
read(x);
write(x:6:1);
while x>=0 do
begin {Establishing New Nodes,if x is Negative then Exit }
new(next);
next^.data:=x; {Link to the end of the table }
last^.link:=next; {Pointer down}
last:=next; {Read in the next value}
read(x);
write(x:6:1)
end;
writeln;
last^.link:=nil; { tail pointer field set NIL }
next:=head;
while next<>nil do
begin {Output Link List}
write(next^.data:6:1);
next:=next^.link
end;
writeln
end.
先進後出鏈表：
{Read in a batch of integer data, stop when the number is negative,
and make up a list of the positive numbers read in and output them.}
program linkfilo(input,output);
type
point=^node;
node=record
data:integer;
link:point
end;
var
head,next:point;
x:integer;
begin
next:=nil;
writeln('input data');
read(x);
writeln(x);
while x>=0 do
begin
new(head);
head^.data:=x; {Link to the header }
head^.link:=next;{Pointer forward }
next:=head; {Read in the next value}
writeln('input data,Negative to Exit ');
read(x);
writeln(x)
end;
writeln;
while next<>nil do
begin {Output Link List}
write(next^.data);
next:=next^.link
end;
writeln
end.
選擇排序：
{
$ pc selSorting.p
$ a.out
Enter 10 integer for sorting:1
3
11
211
101
-1
20
18
19
17
211 101 20 19 18
17 11 3 1 -1
}
program selSorting(input,output);
const NUM=10;
var
a:array[1..NUM] of integer;
temp: integer;
i,j:integer;
begin
write('Enter',NUM,' integer for sorting:');
for i:=1 to NUM do
read(a[i]);
for i:=1 to NUM-1 do
for j:=i+1 to NUM do
if a[i]<a[j] then begin
temp:= a[i];
a[i]:= a[j];
a[j]:=temp
end;
for i:=1 to NUM do {Output sorted results }
begin
write(a[i]:5);
if i mod 5=0 then writeln {Control output of 5 data per line}
end
end.
冒泡算法：
program bubblesort(input,output);
const NUM=10;
var
a:array[1..NUM] of integer;
t: integer;
i,j:integer;
begin
write('Enter ',NUM,' integer for sorting:');
for i:=1 to NUM do
read(a[i]);
for i:=2 to NUM do
begin
t:=a[i];
j:=i-1;
while (j>0) and (a[j]<t) do {Move the number ahead of it backwards one by one.}
begin
a[j+1]:=a[j];
j:=j-1;
end;
a[j+1]:=t;{When encounter a number no smaller than it, place the data after that number.}
end;
for i:=1 to NUM do {Output sorted results }
begin
write(a[i]:5);
if i mod 5=0 then writeln {Control output of 5 data per line}
end
end.
快速排序：
program qsort(input,output);
const NUM=10;
var p:integer;
a:array[0..NUM] of integer;
{Let's assume that the ordered array is a, and that the fast-ranked arrays are arranged in ascending order.}
procedure qs(l,r:integer);
var i,j,m,t:integer;
begin
i:=l;
j:=r;{(l (left), R (right) denotes the left and right intervals of a fast row.}
m:=a[(l+r)div 2];{not m:=(l+r)div 2;}
repeat
while a[i]<m do i:=i+1;
while a[j]>m do j:=j-1;{If descending order, interchange'<'and'>'}
if i<=j then
begin
t:=a[i];
a[i]:=a[j];
a[j]:=t;
i:=i+1;
j:=j-1;
end;
until i>j;
if l<j then qs(l,j);
if i<r then qs(i,r);
end;
begin
write('Enter',NUM,' integers for sorting:');
for p:=1 to NUM do read(a[p]);
qs(1,NUM);
for p:=1 to NUM do {Output sorted results }
begin
write(a[p]:5);
if p mod 5=0 then writeln {Control output of 5 data per line}
end
end.
堆排序：
program heapSort(input,output);
const NUM=10;
var
p:integer;
a:array[0..NUM] of integer;
procedure sift(i,m:integer);{Adjust i-rooted subtrees to heap and m to total number of nodes}
var
k:integer;
begin
a[0]:=a[i]; k:=2*i;{In a complete binary tree, the left child of node I is 2*i and the right child is 2*i+1.}
while k< =m do
begin
if (k< m) and (a[k]< a[k+1]) then k:=k+1;{Find out the larger values in a[k] and a[k+1]}
if a[0]< a[k] then
begin
a[i]:=a[k];
i:=k;
k:=2*i;
end
else k:=m+1;
end;
a[i]:=a[0]; {Put the root in the right place}
end;{end of procedure sift}
procedure heapsort(n:integer);
var
t,j:integer;
begin
n:=NUM;
for j:=n div 2 downto 1 do sift(j,n);
for j:=n downto 2 do
begin
{swap(a[1],a[j]);}
t:=a[1];
a[1]:=a[j];
a[j]:=t;
sift(1,j-1);
end
end;{end of procedure heapsort}
begin
write('Enter',NUM,' integers for sorting:');
for p:=1 to NUM do read(a[p]);
heapsort(NUM);
for p:=1 to NUM do {Output sorted results }
begin
write(a[p]:5);
if p mod 5=0 then writeln {Control output of 5 data per line}
end
end.
數列倒置：
program RevArray(input,output);
const NUM=11;
var
a:array[0..NUM] of integer;
p:integer;
procedure Reverse(n:integer);
var
i,t:integer;
begin
for i:=1 to (n div 2) do
begin
t := a[i];
a[i] :=a[n-i+1];
a[n-i+1] := t
end
end;{end of procedure Reverse}
begin
write('Enter',NUM,' integers for array:');
for p:=1 to NUM do read(a[p]);
Reverse(NUM);
writeln('Array Reversed:');
for p:=1 to NUM do {Output Reversed array }
begin
write(a[p]:5);
if p mod 5=0 then writeln {Control output of 5 data per line}
end;
writeln
end.
乘法表：
program multab(input,output);
var
i,j:integer;
begin
i:=1;
while i<=9 do
begin
j:=1;
while j<=i do
begin
write(j:2,'*',i:2,'=',j*i:2,' ');
j:=j+1;
end;
writeln;
i:=i+1;
end;
end.
或用for語句
program multab(input,output);
var
i,j:integer;
begin
for i:=1 to 9 do
begin
for j:=1 to i do
write(j:2,'*',i:2,'=',j*i:2,' ');
writeln
end
end.
解二次方程：
program quadratic(input,output);
type
roottype=(UniReal,TwoComplex,TwoReal,NotQuadra);
var
a,b,c,d:real;
rt:roottype;
begin
writeln('Input Coefficient of Quadratic Equation:a b c');
readln(a,b,c);
d:=b*b-4*a*c;
if d=0 then rt:=UniReal
else if d>0 then rt:=TwoReal
else rt:=TwoComplex;
if a=0 then rt:=NotQuadra;
case rt of
UniReal : begin
writeln('the equation has a Multiple real root.');
writeln('x1=x2=',-b/(2*a):0:5)
end;
TwoComplex :
begin
writeln(' the equation has a pair of conjugate complex roots.');
writeln('x1=',-b/(2*a):0:5,'+',sqrt(-d)/abs(2*a):0:5,'i; x2=',-b/(2*a):0:5,'-',sqrt(-d)/abs(2*a):0:5,'i');
end;
TwoReal :
begin
writeln('the equation has two real roots.');
writeln('x1=',(-b-sqrt(d))/(2*a):0:5,'; x2=',(-b+sqrt(d))/(2*a):0:5)
end;
NotQuadra :
writeln('Quadratic term is 0 , not a quadratic equation.');
end; {end of case}
end.
解三次方程（盛金公式，用標準pascal，有些函數沒有如arccos等，因此代碼相對複雜了些）
{
Shengjin's Formulas Univariate cubic equation aX ^ 3 + bX ^ 2 + cX + d = 0, (a, b, c, d < R, and a!= 0).
Multiple root discriminant: delta1 = b^2-3*a*c; delta2 = b*c-9*a*d; delta3 = c^2-3*b*d,
The total discriminant is delta=delta2^2-4*delta1*delta3.
When delta1 = delta2 = 0, Shengjin Formula (1): X1=X2=X3=-b/(3*a)=-c/b=-3d/c.
When delta=B^2-4*A*C>0, Shengjin Formula II:
Y1= delta1*b + 3*a *((-B + (delta)^1/2))/ 2.
Y2= delta1*b + 3*a *((-B - (delta)^1/2))/ 2.
x1=(-b-Y1^(1/3) - Y1^(1/3)/(3*a);
X2=(-2*b+Y1^(1/3)+Y2^(1/3)/(6*a)+3^(1/2)* (Y1^(1/3)-Y2^(1/3)/(6a)i,
X3=(-2*b+Y1^(1/3)+Y2^(1/3)/(6*a)-3^(1/2)* (Y1^(1/3)-Y2^(1/3)/(6a)i,
When delta=B^2-4AC=0, Shengjin Formula 3:
X1=-b/a+K; X2=X3=-K/2, K = delta2/delta1, (A<>0).
When delta=B^2-4AC<0, Shengjin Formula 4:
X1= (-b-2*sqrt(delta1)*cos(theta/3))/(3*a);
X2= (-b+sqrt(delta1)*(cos(theta/3)+sqrt(3)*sin(theta/3)))/(3*a);
X3= (-b+sqrt(delta1)*(cos(theta/3)-sqrt(3)*sin(theta/3)))/(3*a)
theta=arccosT,T=(2Ab-3aB)/(2A^(3/2))
Shengjin's Distinguishing Means
(1)A = B = 0, the equation has a triple real root.
(2) When delta =B^2-4AC>0, the equation has a real root and a pair of conjugate complex roots.
(3) When delta=B^2-4AC=0, the equation has three real roots, one of which has two double roots.
(4) When delta=B^2-4AC<0, the equation has three unequal real roots.
}
program cubic1(input,output);
const
PI=3.14159265359;
type
roottype=(UniReal,OneRPairComplex,TwoReal,UnequalReal,NotCubic);
var
a,b,c,d:real;{Coefficient of cubic Equation}
delta1,delta2,delta3,delta:real;
Y1,Y2,expY1,expY2:real;
K,theta,T:real;
rt:roottype;
begin
writeln('Input Coefficient of cubic Equation:a b c d');
readln(a,b,c,d);
delta1 := b*b-3*a*c;
delta2 := b*c-9*a*d;
delta3 := c*c-3*b*d;
delta := delta2*delta2-4*delta1*delta3;
if (delta1=0 )and (delta2=0) then rt:=UniReal
else if delta>0 then rt:=OneRPairComplex
else if delta=0 then rt:=TwoReal
else if delta<0 then rt:=UnequalReal;
if a=0 then rt:=NotCubic;
case rt of
UniReal : begin
writeln('the equation has a triple real root.');
writeln('x1=x2=x3=',-b/3/a:0:5)
end;
OneRPairComplex :
begin
writeln(' the equation has a real root and a pair of conjugate complex roots.');
Y1 := delta1*b + 3*a *((-delta2 + sqrt(delta)))/2;
Y2 := delta1*b + 3*a *((-delta2 - sqrt(delta)))/2;
if Y1>0 then expY1 := exp((1/3)*ln(Y1))
else if Y1=0 then expY1 := 0
else expY1 := (-1)*exp((1/3)*ln(abs(Y1)));
if Y2>0 then expY2 := exp((1/3)*ln(Y2))
else if Y2=0 then expY2 := 0
else expY2 := (-1)*exp((1/3)*ln(abs(Y2)));
writeln('x1=',(-b-expY1 - expY2)/(3*a):0:5);
writeln('x2=',(-2*b+expY1 +expY2)/(6*a):0:5,'+',sqrt(3.0)* (expY1-expY2)/(6*a):0:5,'i');
writeln('x3=',(-2*b+expY1 +expY2)/(6*a):0:5,'-',sqrt(3.0)* (expY1-expY2)/(6*a):0:5,'i')
end;
TwoReal :
begin
writeln('the equation has three real roots, one of which has two double roots.');
K :=delta2/delta1;
writeln('X1=X2=',-K/2:0:5);
writeln('X3=',-b/a+K:0:5)
end;
UnequalReal :
begin
writeln('the equation has three unequal real roots.');
T:=(2*delta1*b-3*a*delta2)/(2*sqrt(delta1*delta1*delta1));
if T=0 then theta:=PI/2.0 else theta:=arctan(sqrt(1-T*T)/T); { theta:=arccos(T); }
if theta<0 then theta:=PI+theta;
writeln('X1=',(-b-2*sqrt(delta1)*cos(theta/3.0))/(3*a):0:5);
writeln('X2=',(-b+sqrt(delta1)*(cos(theta/3.0)+sqrt(3.0)*sin(theta/3)))/(3*a):0:5);
writeln('X3=',(-b+sqrt(delta1)*(cos(theta/3.0)-sqrt(3.0)*sin(theta/3)))/(3*a):0:5)
end;
NotCubic : begin
writeln('the equation is not a cubic equation.');
end;
end; {end of case}
end.
運行測試：
$ a.out Input Coefficient of cubic Equation:a b c d 1 -6 11 -6 the equation has three unequal real roots. X1=1.00000 X2=3.00000 X3=2.00000 $ a.out Input Coefficient of cubic Equation:a b c d 1 2 3 4 the equation has a real root and a pair of conjugate complex roots. x1=-1.65063 x2=-0.17469+1.54687i x3=-0.17469-1.54687i $ a.out Input Coefficient of cubic Equation:a b c d 1 -2 3 -4 the equation has a real root and a pair of conjugate complex roots. x1=1.65063 x2=0.17469+1.54687i x3=0.17469-1.54687i $ a.out Input Coefficient of cubic Equation:a b c d. 1 -3 -3 1 the equation has three unequal real roots. X1=-1.000000 X2=3.732051 X3=0.267949 $ a.out Input Coefficient of cubic Equation:a b c d 1 -3 3 -1 the equation has a triple real root. x1=x2=x3=1.00000 $ a.out Input Coefficient of cubic Equation:a b c d 1 -7.5 18.75 -15.625 the equation has a triple real root. x1=x2=x3=2.50000 $ a.out Input Coefficient of cubic Equation:a b c d 1 2 2 2 the equation has a real root and a pair of conjugate complex roots. x1=-1.54369 x2=-0.22816+1.11514i x3=-0.22816-1.11514i $ a.out Input Coefficient of cubic Equation:a b c d 1 -5.4 8.6 -4.2 the equation has three unequal real roots. X1=1.00000 X2=3.00000 X3=1.40000 $ a.out Input Coefficient of cubic Equation:a b c d 1 5.5 9.92 5.888 the equation has a real root and a pair of conjugate complex roots. x1=-2.30000 x2=-1.60000+0.00000i x3=-1.60000-0.00000i $ a.out Input Coefficient of cubic Equation:a b c d 1 5.4 9.72 5.832 the equation has a real root and a pair of conjugate complex roots. x1=-1.80000 x2=-1.80000+0.00000i x3=-1.80000-0.00000i $ a.out Input Coefficient of cubic Equation:a b c d 1 -4.9 7.94 -4.256 the equation has three unequal real roots. X1=1.40000 X2=1.90000 X3=1.60000 $ a.out Input Coefficient of cubic Equation:a b c d 1 -6 11.25 -6.25 the equation has three real roots, one of which has two double roots. X1=X2=2.50000 X3=1.00000
參考：
http://www.yiibai.com/pascal/pascal_3718.html#pascal_3718
http://blog.csdn.net/g1342522389/article/details/49532015
Pascal數據結構與算法
相關文章
- 1. pascal 實現permute
- 2. 數據結構：圖結構的實現
- 3. 順序結構實現【數據結構】
- 4. OOD + 數據結構實現
- 5. JAVA 實現 數據結構
- 6. 數據結構java實現
- 7. 數據結構KMP實現
- 8. Pascal VOC 數據集
- 9. PASCAL VOC 數據集
- 10. 數據結構-JAVA實現數組
- 更多相關文章...
- • Rust 結構體 - RUST 教程
- • XML 樹結構 - XML 教程
- • Flink 數據傳輸及反壓詳解
- • TiDB 在摩拜單車在線數據業務的應用和實踐
相關標籤/搜索
每日一句
-
每一个你不满意的现在，都有一个你没有努力的曾经。
最新文章
- 1. vs2019運行opencv圖片顯示代碼時，窗口亂碼
- 2. app自動化 - 元素定位不到？別慌，看完你就能解決
- 3. 在Win8下用cisco ××× Client連接時報Reason 422錯誤的解決方法
- 4. eclipse快速補全代碼
- 5. Eclipse中Java/Html/Css/Jsp/JavaScript等代碼的格式化
- 6. idea+spring boot +mabitys(wanglezapin)+mysql (1)
- 7. 勒索病毒發生變種 新文件名將帶有「.UIWIX」後綴
- 8. 【原創】Python 源文件編碼解讀
- 9. iOS9企業部署分發問題深入瞭解與解決
- 10. 安裝pytorch報錯CondaHTTPError：******
歡迎關注本站公眾號,獲取更多信息
相關文章
- 1. pascal 實現permute
- 2. 數據結構：圖結構的實現
- 3. 順序結構實現【數據結構】
- 4. OOD + 數據結構實現
- 5. JAVA 實現 數據結構
- 6. 數據結構java實現
- 7. 數據結構KMP實現
- 8. Pascal VOC 數據集
- 9. PASCAL VOC 數據集
- 10. 數據結構-JAVA實現數組