43 lines
1.5 KiB
Text
43 lines
1.5 KiB
Text
\ diff-bearings.8th
|
|
\ Rosetta Code -- angle difference between two bearings
|
|
\ by John I. Helmers 2026.04.04
|
|
\ 8th version 26.02 Professional
|
|
|
|
11 ## \ sets the precision to 11 decimal places
|
|
|
|
\ data array
|
|
[ [ 20 , 45 ] , [ -45 , 45 ] , [ -85 , 90 ] , [ -95 , 90 ] , [ -45 , 125 ] , [ -45 , 145 ] , [ 29.4803 , -88.6381 ] , [ -78.3251 , -159.036 ] ] constant BEARINGS
|
|
|
|
\ test array
|
|
[ [ -70099.74233810938 , 29840.67437876723 ] , [ -165313.6666297357 , 33693.9894517456 ] , [ 1174.8380510598456 , -154146.66490124757 ] , [ 60175.77306795546 , 42213.07192354373 ] ] constant TEST
|
|
|
|
360 constant LIMIT \ sets circle limit to 360 degrees
|
|
|
|
: make-big-floats \ [ a0, a1, a2 ... ] -- [ a'0, a'1, a'2 ... ]
|
|
( ( n:bfloat ) a:map ) a:map ;
|
|
|
|
: subtract-bearings \ [b1,b2] -- n
|
|
0 a:@ swap 1 a:@ rot n:- ;
|
|
|
|
: simplify LIMIT n:fmod ;
|
|
|
|
: find-acute \ n -- n
|
|
dup 180 > if 360 n:- else dup -180 < if 360 n:+ then then ;
|
|
|
|
: compute-angles \ a -- a'
|
|
( subtract-bearings simplify find-acute 2 swap a:! drop ) a:each! ;
|
|
|
|
: .table-header \ --
|
|
" b1___________________ b2__________________ diff_________________" . cr ;
|
|
|
|
: .lines \ a -- | print each line of table
|
|
( ( "%>24.11f" s:strfmt . ) a:each! drop cr ) a:each! ;
|
|
|
|
: .table .table-header .lines ;
|
|
|
|
: process-data make-big-floats compute-angles ;
|
|
|
|
: do-it BEARINGS process-data .table drop cr
|
|
TEST process-data .table drop cr ;
|
|
|
|
do-it bye
|