home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / CNC11TP.ZIP / MINCOSH.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-11-04  |  3.7 KB  |  142 lines
  1. { Copyright (C) 1988 Adam Fritz, 133 Main St., Afton, NY 13730 }
  2.  
  3. program MinimumHyperbolicCosine (output) ;
  4.  
  5.      {    MinCosh - Compute cosh scaled Bxx for sinh       }
  6.      {              scaled Bxx and list distinct set bit   }
  7.      {              counts.                                }
  8.  
  9. type
  10.    hexstr = string[9] ;
  11.  
  12. {~~~~~~~~~~~~~~~~~~~~ count set bits ~~~~~~~~~~~~~~~~~~~~~~}
  13.  
  14. function nBits ( n : longint ) : integer ;
  15. var
  16.    iBits : integer ;
  17. begin
  18.    iBits := 0 ;
  19.    while n <> 0 do begin
  20.       if Odd(n) then
  21.          Inc(iBits) ;
  22.       n := n shr 1
  23.    end ;
  24.    nBits := iBits
  25. end ;
  26.  
  27. {~~~~~~~~~~~ convert integer to hex string ~~~~~~~~~~~~~~~~}
  28.  
  29. procedure itoh ( var sn : hexstr ; n : longint ) ;
  30. const
  31.    hexchr : array[0..15] of char = ('0','1','2','3','4','5','6','7',
  32.                                     '8','9','A','B','C','D','E','F') ;
  33. var
  34.    lsn : hexstr ;
  35.    ih,nh : integer ;
  36. begin
  37.    lsn := '' ;
  38.    if abs(n) < 65536 then
  39.       nh := 4
  40.    else
  41.       nh := 8 ;
  42.    for ih := 1 to nh do begin
  43.       lsn := hexchr[n and $000F] + lsn ;
  44.       n := n shr 4
  45.    end ;
  46.    sn := '$' + lsn
  47. end ;
  48.  
  49. {~~~~~~~~~~~~~~~~~ hyperbolic functions ~~~~~~~~~~~~~~~~~~~}
  50.  
  51. function sinh ( x : single ) : single ;
  52. begin
  53.    sinh := (exp(x) - exp(-x)) / 2.0
  54. end ;
  55.  
  56. function cosh ( x : single ) : single ;
  57. begin
  58.    cosh := (exp(x) + exp(-x)) / 2.0
  59. end ;
  60.  
  61. function arctanh ( x : single ) : single ;
  62. var
  63.    z,dz0,dz1        : single ;
  64.    coshz, tanhz     : single ;
  65.    n : integer ;
  66. begin
  67.    if abs(x) < 1.0 then begin
  68.       if abs(x) > 0.5 then
  69.          z := ln((1.0 + Sqrt(2.0*x-1.0))/(1.0-x)) / 2.0
  70.       else
  71.          z := ln(2.0 / (1.0 - abs(x))) / 2.0 ;
  72.       dz1 := 1.0 ;
  73.       n := 0 ;
  74.       repeat
  75.          Inc(n) ;
  76.          dz0 := dz1 ;
  77.          coshz := cosh(z) ;
  78.          tanhz := sinh(z) / coshz ;
  79.          dz1 := (abs(x) - tanhz) / Sqr(coshz) ;
  80.          z := z + dz1 ;
  81.       until (abs(dz1) >= abs(dz0)) or (abs(dz1) < 5.0e-7) or (n >= 1000) ;
  82.       if x >= 0 then
  83.          arctanh := abs(z)
  84.       else
  85.          arctanh := -abs(z)
  86.    end
  87.    else begin
  88.       writeln('ERROR: Invalid arctanh argument.') ;
  89.       Halt
  90.    end
  91. end ;
  92.  
  93. {~~~~~~~~~~~~~~~~~~~~~ main program ~~~~~~~~~~~~~~~~~~~~~~~}
  94.  
  95. var
  96.    ib : integer ;
  97.    is : longint ;
  98.    dx,sinhdx,coshdx : single ;
  99.    r : longint ;
  100.    isinhdx,icoshdx,i2coshdx : longint ;
  101.    ni2coshdx,nidx : integer ;
  102.    sisinhdx,sicoshdx,si2coshdx : hexstr ;
  103.  
  104. begin
  105.                                 { get scale }
  106.    repeat
  107.       write ('Scale: ') ;
  108.       readln (ib)
  109.    until (ib > 0) and (ib < 31) ;
  110.    is := longint(1) shl ib ;
  111.  
  112.    i2coshdx := 2*(is + is div 4) ;
  113.    r := 0 ;
  114.    repeat
  115.                                 { sinh and cosh }
  116.       Dec(i2coshdx) ;
  117.       coshdx := i2coshdx / (2*is) ;
  118.       sinhdx := sqrt(sqr(coshdx) - 1.0) ;
  119.                                 { cosine scaled Bxx }
  120.       isinhdx := Round(sinhdx * is) ;
  121.                                 { count distinct set bits }
  122.       ni2coshdx := nBits(i2coshdx) ;
  123.       if ni2coshdx > ib div 2 then
  124.          ni2coshdx := ni2coshdx - ib - 2 ;
  125.       nidx := abs(ni2coshdx) ;
  126.                                 { hex strings }
  127.       if nidx < 3 then begin
  128.          itoh(sisinhdx,isinhdx) ;
  129.          icoshdx := Round(coshdx * is) ;
  130.          itoh(sicoshdx,icoshdx) ;
  131.          itoh(si2coshdx,i2coshdx) ;
  132.          dx := arctanh(sinhdx/coshdx) ;
  133.          r := Round(4.0/sqr(dx)) ;
  134.          writeln (output,dx:10:5,' ',r:5,
  135.                   '   ',sisinhdx,'   ',sicoshdx,'   ',si2coshdx,
  136.                   ' ',ni2coshdx:4,' ',nidx:4)
  137.       end
  138.    until (i2coshdx <= 2*is+1) or (r > 2000)
  139. end.
  140.  
  141. { Copyright (C) 1988 Adam Fritz, 133 Main St., Afton, NY 13730 }
  142.