{~ String operations, Numeric conversion, Babylonian digital systems ~}

unit Str_Num; {by Jan Hollan}
(*  Copyright (C) 1999 Jan Hollan;
  by "program" this unit is further meant.

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)

interface

var
 L10: real; {ln(10)}
const
 cl=#13#10; cl2=cl+cl;  {CR+LF, i.e., end of line}
 m2s:real=60;
 Power10: array[0..9] of longint= (
  1,
  10,
  100,
  1000,
  10000,
  100000,
  1000000,
  10000000,
  100000000,
  1000000000
  );
 gm_open:boolean=false;

Function RoundUp(x:real):longint;
  {to ensure rounding of #.5 to #+1,
  even when using mathematic co-processor, which rounds to even number}

Function SI(width:byte; INumb: longint):string;
  {string from integer}
Function SRe(width,decimals:byte; RNumb: real):string;
  {string from real}
function SRx(d:byte;x:real):string;
  {semilogarithmic expression with d decimal places in the form *.dE#,
   or fixed-point expression
    (for would-be exponent in [-3..3], not producing non-significant
    right-hand zeroes)}
function SRxs(d:byte;x:real):string;
  {like SRx, but producing right-hand zeroes even if unsignificant}
function SRxb(d:byte;x:real;l:byte):string;
  {semilogarithmic expression with d decimal places in the form *.dE#,
   or fixed-point expression
    (for would-be exponent in [-3..3], adding blanks at right to 
     achieve a desired width)}
Function N_S(S:string): real;
  {real from string, to be used with caution: 0 may mean nonsense input}
Function R_S(S:string): real;      {same as N_S}
  {real from string, to be used with caution: 0 may mean nonsense input}
Function I_S(S:string): integer;
  {integer from string, to be used with caution: 0 may mean nonsense input}
Function LI_S(S:string): longint;
  {LongInt from string, to be used with caution: 0 may mean nonsense input}
function par_num(s:string):real;
      {number from a string, whose first character (switch) is skipped}
function par2r(s:string):real; {=par_num}
      {number from a string, whose first character (switch) is skipped}
function par2i(s:string):integer;
      {number from a string, whose first character (switch) is skipped}
function ss2r(s:string;start:byte):real; {=par_num}
      {real number from a string, starting at start}
function ss2i(s:string;start:byte):integer;
      {integer number from a string, starting at start}
function rig_ord_val(stn:string):longint;
  {number from a string containing formatted integer;
   its rihtmost places need not be digits if they are unknown
   - even in this case, the right order of the number is returned
     (example: faintness either in magnitudes, dmag, cmag or mmag as I:5)}
function LTrim(s:string):string;     {like in dBase: leading spaces off}
function ItemCount(s:string):byte;   {like ParamCount}
function ItemCountD(D:char;s:string):byte;  {like Paramcount,
                   but with any delimiter (e.g., ',' instead of space}
function ItemStr(n:byte;s:string):string;     {like ParamStr}
function ItemStrD(D:char;n:byte;s:string):string;


Function h_min_s  (b:real):string; {degrees or hours to h:min:s }
Function hours2hhmmss(b:real;var hh,mi,ss,hs:word ):string; {degrees or hours to h:min:s }
function deg_to_HM(r:real):string;  {degrees to hours:minutes}
function deg_to_dm(r:real):string;  {degrees to degrees:'}

function BabS2Dec(Par:string;var hh,mi,ss,hs:word;var deci:real;kind:char):boolean;
function Bab2Dec(sig:shortint;hh,mi,ss,hs:word;var deci:real;kind:char):boolean;
function BabS2DecO(Par:string;var deci:real;kind:char):boolean;
{decimal equivalent of Babylonian notation: kind='H' for HH:MM:SS.hs --> Deci,
                                              'D' for (-)DD:MM:SS.hs --> Deci.}



implementation
Function RoundUp(x:real):longint;
  {to ensure rounding of #.5 to #+1,
  even when using mathematic co-processor, which rounds to even number,
  and even for negative #}
var aux_l:longint; aux_r:real;
begin
 aux_l:=trunc(x);
 aux_r:=frac(x);
 if aux_r>=0.5 then inc(aux_l)
 else if aux_r<-0.5 then dec(aux_l);
 RoundUp:=aux_l;
end;



Function SI(width:byte; INumb: longint):string;
var aux_s:string;
begin
    str(INumb:width,aux_s); SI:=aux_s;
end;

Function SRe(width,decimals:byte; RNumb: real):string;
var aux_s:string;
begin
    str(RNumb:width:decimals,aux_s); SRe:=aux_s;
end;

function SRx(d:byte;x:real):string;
  {semilogarithmic expression with d decimal places in the form *.dE#,
   or fixed-point expression
   (for would-be exponent in [-3..3] and not producing non-significant
    right-hand zeroes)}
var fullexp:string;ev:integer;
begin
 str(x,fullexp);
 ev:=I_S(ItemStrD('E',2,fullexp));
 if copy(fullexp,2,11)='9.999999999' then
  begin
   fullexp:=copy(fullexp,1,1)+'1.0000000000';
   inc(ev)
  end;
 if abs(ev) <= 3 then
  begin
   if ev<0  then
    begin
     SRx:= SRe(d-ev+3,d-ev,x);
     exit
    end
   else
    if (ev<4) and (d>=ev) then
      begin                     {for exponent=d}
       SRx:= SRe(d+3,d-ev,x);
       exit
      end;
  end;
 str(R_S(copy(fullexp,1,3+d+1)):d+3:d,fullexp);
 SRx:= copy(fullexp,1,3+d)+'E'+SI(1,ev)
end;

function SRxs(d:byte;x:real):string;
  {semilogarithmic expression with d decimal places in the form *.dE#,
   or fixed-point expression for would-be exponent in [-3..3]
  }
var fullexp:string;ev:integer;
begin
 str(x,fullexp);
 ev:=I_S(ItemStrD('E',2,fullexp));
 if copy(fullexp,2,11)='9.999999999' then
  begin
   fullexp:=copy(fullexp,1,1)+'1.0000000000';
   inc(ev)
  end;
 if abs(ev) <= 3 then
  begin
   if ev<0  then
    begin
     SRxs:= SRe(d-ev+3,d-ev,x);
     exit
    end
   else
    if (ev<4) then
      begin                     {for exponent=d}
       if d >= ev then
       SRxs:= SRe(d+3,d-ev,x)
       else SRxs:=SRe(d+3,0,x);
       exit
      end;
  end;
 str(R_S(copy(fullexp,1,3+d+1)):d+3:d,fullexp);
 SRxs:= copy(fullexp,1,3+d)+'E'+SI(1,ev)
end;

function SRxb(d:byte;x:real;l:byte):string;
var auxstr:string;
begin
 auxstr:=SRx(d,x);
 while length(auxstr)<l do auxstr:=auxstr+' ';
 SRxb:=auxstr;    
end;

Function N_S(S:string): real;
  {real from string}
var Wrong_pos:integer; FV:real;
begin
val(S,FV,Wrong_pos);
if Wrong_pos=0 then
 N_S:=FV
else
 N_S:=0;
end;

Function R_S(S:string): real;
  {real from string, to be used with caution: 0 may mean nonsense input}
begin
R_S:=N_S(s);
end;


Function I_S(S:string): integer;
  {Integer from string, to be used with caution: 0 may mean nonsense input}
var Wrong_pos,FV:integer;
begin
val(S,FV,Wrong_pos);
if Wrong_pos=0 then
 I_S:=FV
else
 I_S:=0;
end;

Function LI_S(S:string): longint;
  {LongInt from string, to be used with caution: 0 may mean nonsense input}
var Wrong_pos: integer; FV:longint;
begin
val(S,FV,Wrong_pos);
if Wrong_pos=0 then
 LI_S:=FV
else
 LI_S:=0;
end;


function par_num(s:string):real; {the first character (switch) is skipped}
var j:integer; aux_r:real;
begin
  val(copy(s,2,length(s)-1),aux_r,j);
  if j>0 then
   begin
    writeln(
     'Parameter "',s,'" gives no number introduced by character "',s[1],'"',cl,
     ' - the ',j,'-th character is bad.');
    halt
   end;
  par_num:=aux_r
end;

function par2r(s:string):real; {=par_num}
      {number from a string, whose first character (switch) is skipped}
begin
 par2r:=par_num(s);
end;

function par2i(s:string):integer;
      {number from a string, whose first character (switch) is skipped}
var j,aux_i:integer;
begin
  val(copy(s,2,length(s)-1),aux_i,j);
  if j>0 then
   begin
    writeln(
     'Parameter "',s,'" gives no integer introduced by character "',s[1],'"',cl,
     ' - the ',j,'-th character is bad.');
    halt
   end;
  par2i:=aux_i
end;

function ss2r(s:string;start:byte):real;
      {real from a string, starting at Start}
var j:integer; aux_r:real;
begin
  val(copy(s,Start,length(s)+1-Start),aux_r,j);
  if j>0 then
   begin
    writeln(
     'Parameter "',s,'" gives no number introduced by "',
      copy(s,1,start-1),'"',cl,
     ' - the ',j,'-th character is bad.');
    halt
   end;
  ss2r:=aux_r
end;

function ss2i(s:string;start:byte):integer;
      {integer from a string, starting at Start}
var j:integer; aux_i:integer;
begin
  val(copy(s,Start,length(s)+1-Start),aux_i,j);
  if j>0 then
   begin
    writeln(
     'Parameter "',s,'" gives no number introduced by "',
      copy(s,1,start-1),'"',cl,
     ' - the ',j,'-th character is bad.');
    halt
   end;
  ss2i:=aux_i
end;

function rig_ord_val(stn:string):longint;
  {number from a string containing formatted integer;
   its rihtmost places need not be digits if they are unknown
   - even in this case, the right order of the number is returned
     (example: faintness either in magnitudes, dmag, cmag or mmag as I:5)}
var lstn: byte; j,jaux:integer; vstn:longint;
begin
 j:=1;
 while stn[j]=' ' do inc(j);
 stn:=copy(stn,j,length(stn)-j+1);
 lstn:=length(stn);
 val(stn,Vstn,j);
 if j>0 then
  begin
   val(copy(stn,1,j-1),Vstn,jaux);
   vstn:=vstn*Power10[lstn-j+1];
  end;
 rig_ord_val:=vstn
end;

function LTrim(s:string):string;
var j:byte;
begin
 if s<>'' then
  begin
   j:=1;
   while (j<=length(s)) and (s[j]=' ') do inc(j);
   if j<=length(s) then
    s:=copy(s,j,length(s)-j+1)
   else
    s:=''
  end;
 LTrim:=s;
end;

function ItemCount(s:string):byte;   {like ParamCount}
begin
 ItemCount:=ItemCountD(#32,s);
end;

function ItemCountD(D:char;s:string):byte;  {like Paramcount,
                   but with any delimiter (e.g., ',' instead of space}
var ic,i,it:byte;
begin
 ic:=0;
 s:=LTrim(s);
 while s<>'' do
  begin
   inc(ic);
   i:=pos(D,s);
   if D=#32 then
    begin
     it:=pos(#9,s);
     if (it>0) and ((it<i) or (i=0)) then i:=it;
    end;
   if i>0 then
    s:=LTrim(copy(s,i+1,length(s)-i))
   else s:=''
  end;
 ItemCountD:=ic
end;

function ItemStr(n:byte;s:string):string;     {like ParamStr}
begin
 ItemStr:=ItemStrD(#32,n,s);
end;

function ItemStrD(D:char;n:byte;s:string):string;
var ic,i,it:byte; s1:string;
begin
 s1:='';
 if {n in [0..ItemCountD(D,s)]} {'in' did not work in fpk 0.99.10}
    n <= ItemCountD(D,s)  then
  begin
   ic:=0;
   s:=LTrim(s);
   while (s<>'') and (ic<n) do
    begin
     inc(ic);
     i:=pos(D,s);
     if D=#32 then
      begin
       it:=pos(#9,s);
       if (it>0) and ((it<i) or (i=0)) then i:=it;
      end;
     if i>0 then
      begin
       s1:=copy(s,1,i-1);
       s:=LTrim(copy(s,i+1,length(s)-i))
      end
     else
      begin
       s1:=s;
       s:=''
      end;
    end;
  end;
 ItemStrD:=s1;
end;


Function h_min_s(b:real):string; {degrees or hours to h:min:s }
var h,m,s:integer;
begin
  h:=TRUNC(B);
  m:=TRUNC( (B-h)*m2s );
  s:=RoundUp((B-h-(m/m2s))*3600);
  if s=60 then begin s:=0; inc(m); end;
  if m=60 then begin m:=0; inc(h); end;
  h_min_s:=SI(2,h)+':'+SI(2,m)+':'+SI(2,s)
end;

Function hours2hhmmss(b:real;var hh,mi,ss,hs:word ):string; {degrees or hours to h:min:s }
var h,m,s: integer;
begin
  hh:=TRUNC(B);
  h:=hh;
  mi:=TRUNC( (B-hh)*m2s );
  m:=mi;
  ss:=Trunc( (B-hh-(mi/m2s))*3600);
  s:=RoundUp((B-hh-(mi/m2s))*3600);
  hs:=RoundUp((B-hh-(mi/m2s)-(ss/3600.0)  )*360000);
  if hs=100 then
   begin
    hs:=0; inc(ss);
    if ss=60 then
     begin
      ss:=0; inc(mi);
       if mi=60 then
        begin
         mi:=0; inc(hh);
        end;
     end;
   end;
  if s=60 then begin s:=0; inc(m); end;
  if m=60 then begin m:=0; inc(h); end;
  hours2hhmmss:=SI(2,h)+':'+SI(2,m)+':'+SI(2,s)
end;

function deg_to_HM(r:real):string;
var au_st, au_st2:string;
begin
 str(trunc(r/15):2,au_st);
 if (r<0) and (trunc(r/15)=0) then au_st:='-0';
   {the above important correction added Apr. 18, 2000}
 str(RoundUp(frac(r/15)*m2s):2,au_st2);
 deg_to_HM:=au_st+':'+au_st2;
end;

function deg_to_dm(r:real):string;
var au_st, au_st2:string;
begin
 str(trunc(r):3,au_st);
 if (r<0) and (trunc(r)=0) then au_st:=' -0';
   {the above important correction added Apr. 18, 2000}
 str(RoundUp(frac(abs(r))*m2s):2,au_st2);
 deg_to_dm:=au_st+':'+au_st2;
end;

function BabS2Dec(Par:string;var hh,mi,ss,hs:word;var deci:real;kind:char):boolean;
var j1,j2,j3,j4:integer; sig:shortint; dd:integer;
begin
 hh:=0;mi:=0;ss:=0;hs:=0;deci:=0;sig:=1;
 val(Par,dd,j1);
 if j1>1 then
  begin
   val(copy(Par,1,j1-1),dd,j2);
   if pos('-',Par)>0 then
    begin sig:=-1; hh:=abs(dd) end
   else hh:=dd;
   val(copy(Par,j1+1,length(Par)-j1),Mi,j2);
    if j2>0 then
    begin
     val(copy(Par,j1+1,j2-1),Mi,j3);
     val(copy(Par,j1+j2+1,length(Par)-j1-j2),SS,j3);
     if j3>0 then
      begin
       val(copy(Par,j1+j2+1,j3-1),SS,j4);
       val(copy(Par,j1+j2+j3+1,length(Par)-j1-j2-j3),HS,j4)
      end
    end
  end
 else
  if j1=0 then
   if pos('-',Par)>0 then
    begin sig:=-1; hh:=abs(dd) end
   else hh:=dd;
 if j1<>1 then BabS2Dec:=Bab2Dec(sig,hh,mi,ss,hs,deci,kind)
 else BabS2Dec:=false;
end;

function Bab2Dec(sig:shortint; hh,mi,ss,hs:word;var deci:real;kind:char):boolean;
var aux_boo:boolean;
begin
 aux_boo:=true;

 if (Mi>59) or (SS>59) or (HS>99) then
  aux_boo:=false
 else
  if UpCase(kind)='H' then
   if (HH>24) or (sig=-1) then
    aux_boo:=false;                    {no check for degrees}

 if aux_boo then
  begin
   Deci:=sig*(hh+(mi+(ss+hs/100.0)/m2s)/m2s)
  end;

 Bab2Dec:=aux_boo;
end;

function BabS2DecO(Par:string;var deci:real;kind:char):boolean;
var ho,m,s,hu:word; OK:integer; aux_boo:boolean;
begin
 kind:=UpCase(kind);
 val(Par,deci,OK);
 if OK>0 then
  aux_boo:=BabS2Dec(Par,ho,m,s,hu,deci,'D')  {no check of interval of ho}
 else
  aux_boo:=true;
 case kind of
 'H': BabS2DecO:=aux_boo and (abs(deci)<25);
 'D': BabS2DecO:=aux_boo and (abs(deci)<361);
 else BabS2DecO:=aux_boo;
 end;
end;

begin
 L10:=ln(10);
end.