home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / CNC11TP.ZIP / MINHANG.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-11-04  |  3.8 KB  |  146 lines
  1. { Copyright (C) 1988 Adam Fritz, 133 Main St., Afton, NY 13730 }
  2.  
  3. program MinimumHyperbolicAngle (output) ;
  4.  
  5.      {    MinHAng - 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 longint 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. {         writeln (n,' ',dz1,' ',z:10:5) }
  82.       until (abs(dz1) >= abs(dz0)) or (abs(dz1) < 5.0e-7) or (n >= 1000) ;
  83.       if x >= 0 then
  84.          arctanh := abs(z)
  85.       else
  86.          arctanh := -abs(z)
  87.    end
  88.    else begin
  89.       writeln('ERROR: Invalid arctanh argument.') ;
  90.       Halt
  91.    end
  92. end ;
  93.  
  94. {~~~~~~~~~~~~~~~~~~~~~ main program ~~~~~~~~~~~~~~~~~~~~~~~}
  95.  
  96. var
  97.    ib : integer ;
  98.    is : longint ;
  99.    dx,dxd,sinhdx,coshdx : single ;
  100.    r : longint ;
  101.    isinhdx,icoshdx : longint ;
  102.    nisinhdx,nicoshdx,nidx : integer ;
  103.    sisinhdx,sicoshdx : hexstr ;
  104.  
  105. begin
  106.                                 { get scale }
  107.    repeat
  108.       write ('Scale: ') ;
  109.       readln (ib)
  110.    until (ib > 0) and (ib < 31) ;
  111.    is := longint(1) shl ib ;
  112.  
  113.    isinhdx := is ;
  114.    r := 0 ;
  115.    repeat
  116.                                 { sinh and cosh }
  117.       Dec(isinhdx) ;
  118.       sinhdx := isinhdx / is ;
  119.       coshdx := sqrt(1.0 + sqr(sinhdx)) ;
  120.                                 { cosine scaled Bxx }
  121.       icoshdx := Round(coshdx * is) ;
  122.                                 { count distinct set bits }
  123.       nisinhdx := nBits(isinhdx) ;
  124.       if nisinhdx > ib div 2 then
  125.          nisinhdx := nisinhdx - ib ;
  126.       nicoshdx := nBits(icoshdx) ;
  127.  
  128.       if nicoshdx > ib div 2 then
  129.          nicoshdx := nicoshdx - ib - 1 ;
  130.       nidx := abs(nisinhdx) + abs(nicoshdx) ;
  131.                                 { hex strings }
  132.       if nidx < 5 then begin
  133.          itoh(sisinhdx,isinhdx) ;
  134.          itoh(sicoshdx,icoshdx) ;
  135.          dx := arctanh(sinhdx/coshdx) ;
  136.          r := Round(4.0/sqr(dx)) ;
  137.          writeln (output,dx:10:5,' ',r:5,
  138.                   '   ',sisinhdx,'   ',sicoshdx,
  139.                   ' ',nisinhdx:4,' ',nicoshdx:4,' ',nidx:4)
  140.       end
  141.    until (isinhdx < 512) or (r > 2000)
  142. end.
  143.  
  144. { Copyright (C) 1988 Adam Fritz, 133 Main St., Afton, NY 13730 }
  145.  
  146.