unit Cehui;
{-----------------------------------
== ◎◎◎ 作者：陈明(龙在天) ◎◎◎ ==
QQ:810492306
注：本程序约定写法-->60度20分30秒写为60.20.30
30.20.10为30度20分10秒
其它小数写法均为弧度值
各个函数的参数均以弧度值为实参
------------------------------------}
interface
uses Math,SysUtils;
type Point=record //点坐标的记录类型
x:single;
y:single;
end;
//*****************前方交会的计算,根据AB两点的坐标和两个角求P点的坐标**********
function FrontCross(A,B:Point;a_bear,b_bear:single):Point;
//*****************测边交会的计算,已知A,B,ap长,bp长,求P。P点在A,B下侧则fm=1;在上侧则fm=-1,xx为AB测绘象限序号
function SidesCross(A,B:Point;ap,bp:single;fm,xx:integer):Point;
//*****************将角度转换成弧度如60.30.20(60度30分20秒)化成弧度1.056*******
function MyDegToRad(Deg:string):single;
//*****************将弧度转换成角度,如3转换成171度53分14秒,171.53.14***********
function MyRadToDeg(Rad:single):string;
//*****************奇进偶不进算法函数******************************************
function JustifyFloat(float1:single):integer;
//*****************坐标正算函数,已知A,AB距离,AB坐标方位角,求B******************
function RCalCoordinate(A:Point;Sab:single;ab_bear:single):Point;
//*****************坐标反算函数,已知A,B求AB方位角和Sab,xx为AB测绘象限序号******
function LCalCoordinate(A,B:Point;var ab_bear:single;xx:integer):single;//顺便返回 ab_bear
//*****************将弧(角)度度化到0到2*Pi之间,纠正角度范围********************
function JustifyBear(bear:single):single;overload;
function JustifyBear(bear:string):string;overload;
//*****************余弦函数求角值,已知三边长a,b,c其中c为欲求角的对边***********
function YuXianFunc(a,b,c:single):single;
//*****************已知A,B坐标求AB长度*****************************************
function CalABLong(A,B:Point):single;
//*****************由A,B两点坐标判断AB是在测绘坐标系中哪象限*******************
function JudgeABXX(A,B:Point):integer;
//*****************由A,B坐标计算AB的方位角，xx,象限,FW,方位********************
function CalAB_FWbear(A,B:Point):single;
//*****************正弦函数求边长,已知a边和A,B角*******************************
function ZhengXianFunc(a:single;a_bear,b_bear:single):single;
//*****************将角度转换成秒值，如30.20.10转换成秒值**********************
function CoordinateToSeconds(Deg:string):single;
//*****************将秒值转换成角度值******************************************
function SecondsToCoordinate(Se:single):string;
//*****************两个角(30.20.10的形式)，加减法运算,1234分别为加减乘除*******
function CoordinateAddAndSub(A,B:string;i:integer):string;
//*****************小数转分数**************************************************
function Fraction(decimal: double): string;
implementation
//================================小数转分数===================================
function Fraction(decimal: double): string;
var
intNumerator, intDenominator, intNegative: integer; // 声明整数变量为长整数
dblFraction, dblDecimal, dblAccuracy, dblinteger: Double; // 声明浮点数为双精度
temp:string;
begin
dblDecimal := decimal; //取得目标小数
if trunc(decimal) = decimal then // 如果是整数，则直转
result := floattostr(decimal)
else
begin
if abs(decimal) > 1 then //如果小数大于1 如 10.24 ，进行拆解
begin
dblinteger := trunc(decimal); //取出整数部分
dblDecimal := abs(frac(decimal)); //取出小数部分
end
else dblDecimal := decimal;
dblAccuracy := 0.01; //设置精度
intNumerator := 0; //初始分子为0
intDenominator := 1; //初始分母为1
intNegative := 1; //符号标记为正
if dblDecimal < 0 then intNegative := -1; //如果目标为负，设置负标志位
dblFraction := 0; //设置分数值为 0/1
while Abs(dblFraction - dblDecimal) > dblAccuracy do //如果当前没有达到精度要求就继续循环
begin
if Abs(dblFraction) > Abs(dblDecimal) then //如果我们的分数大于目标
intDenominator := intDenominator + 1 //增加分母
else //否则
intNumerator := intNumerator + intNegative; //增加分子
dblFraction := intNumerator / intDenominator; //计算新的分数
end;
// edit2.Text := inttostr(intNumerator) + '/' + inttostr(intDenominator);
if abs(decimal) > 1 then //如果小数大于1 如 10.24 ，进行拆解
//结果：dblinteger为整数部分， intNumerator为分子，intDenominator为分母
begin
if dblinteger<0 then //如果为负数
begin dblinteger := -dblinteger;
temp := floattostr(dblinteger*intDenominator+intNumerator) + '/' + inttostr(intDenominator);
//result := floattostr(dblinteger) + '又' + inttostr(intNumerator) + '/' + inttostr(intDenominator)
result := '-'+temp;
end else
begin
temp := floattostr(dblinteger*intDenominator+intNumerator) + '/' + inttostr(intDenominator);
result :=temp;
end;
end
else
result := inttostr(intNumerator) + '/' + inttostr(intDenominator);
end;
end;
//============================前方交会的计算(逆时针)===========================
function FrontCross(A,B:Point;a_bear,b_bear:single):Point;
var P:Point;
begin
p.x:=(A.x*cot(b_bear)+B.x*cot(a_bear)+(B.y-A.y))/(cot(a_bear)+cot(b_bear));
p.y:=(A.y*cot(b_bear)+B.y*cot(a_bear)-(B.x-A.x))/(cot(a_bear)+cot(b_bear));
result:=P;
end;
//========================将角度转换成弧度如60.30.20(60度30分20秒)化成弧度1.056
function MyDegToRad(Deg:string):single;
var sum:single;
begin
sum:=CoordinateToSeconds(Deg);
result:=sum/(180*3600)*Pi;
end;
//=============================奇进偶不进算法函数==============================
function JustifyFloat(float1:single):integer;
var temp:integer;
begin
result:=0;
temp:=trunc(float1*2);
if float1<0 then temp:=trunc(-float1*2); //如果目标数为负数
if odd(temp) then //奇进偶不进
begin
if (temp mod 4)=1 then result:=temp div 2
else if (temp mod 4)=3 then result:=(temp+1) div 2;
end
else
begin
result:=temp div 2;
end;
if float1<0 then result:=-result;
end;
//============================将弧度转换成角度,如3转换成171度53分14秒,171.53.14
function MyRadToDeg(Rad:single):string;
var temp1,temp2,temp3:single;
str1,str2,str3:string;
begin
temp1:=Rad/Pi*180;
if Rad<0 then temp1:=-Rad/Pi*180; //如果为负数
str1:=IntToStr(Floor(temp1)); //取整 147
temp2:=Frac(temp1)*60; //Frac取小数部分,
str2:=IntToStr(Floor(temp2)); //算分值
temp3:=Frac(temp2)*60;
str3:=IntToStr(Round(temp3)); //Round四舍五入,算秒值
result:=str1+'.'+str2+'.'+str3; //度.分.秒 的形式输出
if Rad<0 then result:='-'+result;
end;
//========================坐标正算函数,已知A,AB距离,AB坐标方位角,求B===========
function RCalCoordinate(A:Point;Sab:single;ab_bear:single):Point;
var B:Point;
begin
B.x:=A.x+Sab*Cos(ab_bear);
B.y:=A.y+Sab*Sin(ab_bear);
result:=B;
end;
//=======================坐标反算函数,已知A,B求AB方位角和Sab,xx为AB测绘象限序号
function LCalCoordinate(A,B:Point;var ab_bear:single;xx:integer):single;
var Xab,Yab:single; //分别为X,Y坐标差
begin
Xab:=B.x-A.x;
Yab:=B.y-A.y;
ab_bear:=Arctan(Yab/Xab); //改变参数ab_bear值并返回
if ab_bear<0 then ab_bear:=-ab_bear; //如果ab_bear小于0时
case xx of //转换为坐标方位角
1:ab_bear:=ab_bear;
2:ab_bear:=Pi-ab_bear;
3:ab_bear:=Pi+ab_bear;
4:ab_bear:=2*Pi-ab_bear;
end;
result:=Sqrt(Sqr(Xab)+Sqr(Yab));
end;
//========测边交会的计算,已知A,B,ap长,bp长,求P。P点在A,B下侧则fm=1;在上侧则fm=-1,xx为AB测绘象限序号
function SidesCross(A,B:Point;ap,bp:single;fm,xx:integer):Point;
var Sab:single; //AB边长
ab_bear:single; //AB方位角
ap_bear:single; //AP方位角
a_bear:single; //角A值(弧度)
P:Point;
begin
Sab:=LCalCoordinate(A,B,ab_bear,xx); //坐标反算求出AB长和AB方位角
a_bear:=YuXianFunc(Sab,ap,bp); //余弦函数求A角
ap_bear:=JustifyBear(ab_bear+fm*a_bear); //算AP的方位角
P:=RCalCoordinate(A,ap,ap_bear); //坐标正算求出P点坐标
result:=P;
end;
//=======================将弧(角)度度化到0到2*Pi之间,纠正弧(角)度范围==========
function JustifyBear(bear:single):single;overload;
begin
if bear<0 then
repeat
bear:=bear+2*Pi;
until bear>=0;
if bear>2*Pi then
repeat
bear:=bear-2*Pi;
until bear<=2*Pi;
result:=bear;
end;
function JustifyBear(bear:string):string;overload;
var seconds:single;
begin
seconds:=CoordinateToSeconds(bear);
if seconds<0 then
repeat
seconds:=seconds+360*3600;
until seconds>=0;
if seconds>360*3600 then
repeat
seconds:=seconds-360*3600;
until seconds<360*3600;
result:=SecondsToCoordinate(seconds);
end;
//======================余弦函数求角值,已知三边长a,b,c其中c为欲求角的对边======
function YuXianFunc(a,b,c:single):single;
var bear:single;
begin
bear:=Arccos((Sqr(a)+Sqr(b)-Sqr(c))/(2*a*b));
result:=bear;
end;
//=======================已知A,B坐标求AB长度===================================
function CalABLong(A,B:Point):single;
begin
result:=Sqrt(Sqr(A.x-B.x)+Sqr(A.y-B.y));
end;
//======================由A,B两点坐标判断AB是在测绘坐标系中哪象限==============
function JudgeABXX(A,B:Point):integer;
begin
result:=1;
if (B.x-A.x>0) and (B.y-A.y>0) then result:=1;
if (B.x-A.x<0) and (B.y-A.y>0) then result:=2;
if (B.x-A.x<0) and (B.y-A.y<0) then result:=3;
if (B.x-A.x>0) and (B.y-A.y<0) then result:=4;
end;
//=======================由A,B坐标计算AB的方位角，xx,象限,FW,方位==============
function CalAB_FWbear(A,B:Point):single;
var ab_bear:single;
xx:integer;
begin
xx:=JudgeABXX(A,B);
LCalCoordinate(A,B,ab_bear,xx);
result:=ab_bear;
end;
//======================正弦函数求边长,已知a边和A,B角==========================
function ZhengXianFunc(a:single;a_bear,b_bear:single):single;
begin
result:=0;
if sin(a_bear)<>0 then
result:=a*sin(b_bear)/sin(a_bear);
end;
//======================将角度转换成秒值，如30.20.10转换成秒值=================
function CoordinateToSeconds(Deg:string):single;
var deg1,deg2:string;
sum:single;
temp:string;
begin
sum:=0;
temp:=Deg;
if copy(Deg,1,1)='-' then Deg:=Copy(Deg,2,Length(Deg)-1);//如果为负数则化为正的
if pos('.',Deg)=0 then
begin
sum:=StrToInt(Deg)*3600;
end;
if pos('.',Deg)<>0 then
begin
deg1:=copy(deg,pos('.',deg)+1,length(deg)-pos('.',deg)); //deg1=30.20
deg2:=copy(deg,1,pos('.',deg)-1); //deg2=60
sum:=StrToInt(deg2)*3600; //化成秒
if pos('.',deg1)=0 then
begin
sum:=sum+StrToInt(deg1)*60;
end;
if pos('.',deg1)<>0 then
begin
deg2:=copy(deg1,1,pos('.',deg1)-1);
sum:=sum+StrToInt(deg2)*60;
deg2:=copy(deg1,pos('.',deg1)+1,length(deg1)-pos('.',deg1));
sum:=sum+StrToFloat(deg2);
end;
end;
result:=sum;
if copy(temp,1,1)='-' then result:=-result;
end;
//=======================将秒值转换成角度值====================================
function SecondsToCoordinate(Se:single):string;
var str1:string;
temp:integer;
o:single;
begin
if Se<0 then Se:=-Se;
temp:=Trunc(Se);
o:=se-Trunc(Se); //如果目标为负数
str1:=IntToStr(temp div 3600)+'.';
str1:=str1+IntToStr((temp mod 3600) div 60)+'.';
str1:=str1+FloatToStr((temp mod 60)+o);
result:=str1;
if se<0 then result:='-'+result;
end;
//========================两个角(30.20.10的形式)，加减法运算,1234分别为加减乘除
function CoordinateAddAndSub(A,B:string;i:integer):string;
var temp:single;
temp1:single;
begin
case i of
1:begin //加法运算
temp:=CoordinateToSeconds(A)+CoordinateToSeconds(B);
result:=SecondsToCoordinate(temp);
end;
2:begin //减法运算
temp:=CoordinateToSeconds(A)-CoordinateToSeconds(B);
result:=SecondsToCoordinate(temp);
end;
3:begin //乘法运算
temp:=CoordinateToSeconds(A) * StrToInt(B);
result:=SecondsToCoordinate(temp);
end;
4:begin //除法运算
temp1:=CoordinateToSeconds(A) / StrToInt(B);
temp:=JustifyFloat(temp1); //奇进偶不进
result:=SecondsToCoordinate(temp);
end;
end;
end;
end.
