(50G) PDQ Algorithm in SRPL and URPL

[Joe Horn]

PDQ Algorithm in HP 50g System RPL and User RPL, by Joe Horn

Here are two HP 50g versions of the "PDQ Algorithm", fully described HERE. The first version is in System RPL (more or less), and the second is 100% User RPL. They are identical in operation except for speed: the System RPL version is roughly twice as fast as the User RPL version. Example:

5. √ 2 PDQ --> 29/13
SRPL version: 0.37 seconds
URPL version: 0.78 seconds

Differences from the Prime version linked above:

(1) Inputs:
Stack level 2: Number to be approximated (as a real decimal, integer ratio, or string).
Stack level 1: Tolerance (as a real decimal, or integer ratio).
Allowing the inputs to be in the form of integer ratios or strings is what lets the user tap the "infinite precision" of the algorithm (see examples below).

(2) Outputs:
Stack level 2: Exact best fraction
Stack level 1: Exact error (tagged "N" or "X")
"N" means "Normal" (principal) convergent
"X" means "eXtra" (intermediate) convergent

Examples:

3.14159265359 7 PDQ
--> 75948/24175, X:-9602153/96700000000000
What this means: The input means, "What is the simplest fraction within ±1/10^7 of 3.14159265359?" The answer is 75948/24175, which is an intermediate convergent of the input (that's what the "X" indicates). The answer differs from the input by exactly -9602153/96700000000000.

'31415926535897932384626/10000000000000000000000' '1/800' PDQ
--> 179/57, X:exact error (ratio of two large integers)

"3.1415926535897932384626" .00125 PDQ
--> same as previous example

(3) 'ic' and 'err' global variables are not created.

(4) Since the 50g uses 12-digit BCD, and Prime's CAS uses 48-bit binary floating point, real inputs on both machines will usually be slightly different, which can cause PDQ's results to differ on both machines. When their inputs are actually identical (e.g. when they are exact ratios of integers), PDQ's results will also be identical on both machines.

PDQ in System RPL
BYTES (when assembled): 852. #A4ABh

Code:

%%HP: T(3)A(R)F(.);
"::
  CK2NOLASTWD
  STRIPTAGS
  STRIPTAGSl2
  '
  ::
    DUP
    xTYPE
    %9
    %-
    xTHEN
    %0
    xELSE
    ::
      DUP
      x\->LST
      DUP
      %1
      '
      xTYPE
      xDOSUBS
      xR>I
      {
        ZINT 28
        ZINT 28
        ZINT 18
      }
      xSAME
      SWAPDUP
      xSIZE
      xGET
      '
      x/
      xSAME
      xAND
    ;
    xTHEN
    xFXND
    xELSE
    ::
      DUP
      xFXND
      xMOD
      xTHEN
      ::
        % 11.
        OVER
        %EXPONENT
        %-
        %ALOG
        SWAPOVER
        %*
        xR>I
        SWAP
        xR>I
        xSIMP2
      ;
      xELSE
      ZINT 1
    ;
  ;
  xRPN->
  LAM tof
  x<<
  OVER
  xTYPE
  %2
  xSAME
  xTHEN
  ::
    SWAPDUP
    \".\"
    xPOS
    2DUP
    %1
    %-
    %1
    SWAP
    xSUB
    3PICK
    3PICK
    ZINT 1
    x+
    OVER
    xSIZE
    xSUB
    x+
    xSTR>
    ROT
    xSIZE
    ROT
    x-
    xR>I
    xALOG
    x/
    SWAP
  ;
  xIF
  OVER
  xFXND
  xMOD
  ZINT 0
  x#?
  xTHEN
  ::
    DUP
    ZINT 1
    x>=?
    OVER
    xTYPE
    % 28.
    xSAME
    xAND
    xTHEN
    ::
      xNEG
      xALOG
    ;
    xIFEND
    LAM tof
    EVAL
    UNROT
    xABS
    UNROT
    LAM tof
    EVAL
    2DUP
    ZINT 0
    ZINT 1
    xRPN->
    LAM a
    LAM b
    LAM n0
    LAM d0
    LAM n
    LAM d
    LAM cd
    LAM pd
    x<<
    ZINT 1
    LAM d0
    LAM a
    FPTR2 ^QMul
    BEGIN
    LAM pd
    LAM cd
    DUP
    '
    LAM pd
    STOLAM
    LAM n
    LAM d
    DUP
    '
    LAM n
    STOLAM
    FPTR2 ^IDIV2
    '
    LAM d
    STOLAM
    FPTR2 ^QMul
    FPTR2 ^QAdd
    '
    LAM cd
    STOLAM
    SWAP
    FPTR2 ^QNeg
    SWAP
    LAM b
    LAM d
    FPTR2 ^QMul
    OVER
    LAM cd
    FPTR2 ^QMul
    Z<=
    UNTIL
    DUP
    LAM cd
    FPTR2 ^QMul
    LAM b
    LAM d
    FPTR2 ^QMul
    FPTR2 ^QSub
    SWAP
    LAM pd
    FPTR2 ^QMul
    LAM b
    LAM n
    FPTR2 ^QMul
    FPTR2 ^QAdd
    FPTR2 ^IDIV2
    DROP
    LAM n
    OVER
    FPTR2 ^QMul
    LAM d
    FPTR2 ^QAdd
    ROT
    FPTR2 ^QMul
    OVER
    FPTR2 ^QNeg
    LAM pd
    FPTR2 ^QMul
    LAM cd
    FPTR2 ^QAdd
    2DUP
    LAM n0
    FPTR2 ^QMul
    FPTR2 ^QAdd
    LAM d0
    ROT
    FPTR2 ^QMul
    SWAPOVER
    FPTR2 ^QDiv
    UNROT
    FPTR2 ^QDiv
    ROT
    ZINT 0
    Z<>
    ITE
    \"X\"
    \"N\"
    >TAG
    ABND
  ;
  xELSE
  ::
    DROP
    TAG N
    ZINT 0
  ;
  ABND
;
@"

PDQ in User RPL
BYTES: 818.5 #7596h

Code:

%%HP: T(3)A(R)F(.);
\<< DTAG SWAP DTAG SWAP
  \<<
    IF
      IF DUP TYPE 9. -
      THEN 0.
      ELSE DUP \->LST DUP 1.
        \<< TYPE
        \>> DOSUBS R\->I { 28 28 18 } SAME SWAP DUP SIZE GET { / } 1. GET SAME AND
      END
    THEN FXND
    ELSE
      IF DUP FXND MOD
      THEN 11. OVER XPON - ALOG SWAP OVER * R\->I SWAP R\->I SIMP2
      ELSE 1
      END
    END
  \>> \-> tof
  \<<
    IF OVER TYPE 2. SAME
    THEN SWAP DUP "." POS DUP2 1. - 1. SWAP SUB PICK3 PICK3 1 + OVER SIZE SUB + STR\-> ROT SIZE ROT - R\->I ALOG / SWAP
    END
    IF OVER FXND MOD 0 \=/
    THEN
      IF DUP 1 \>= OVER TYPE 28. SAME AND
      THEN NEG ALOG
      END tof EVAL ROT tof EVAL DUP2 0 1 \-> a b n0 d0 n d cd pd
      \<< 1 d0 a *
        DO pd cd DUP 'pd' STO n d DUP 'n' STO IDIV2 'd' STO * + 'cd' STO SWAP NEG SWAP
        UNTIL b d * OVER cd * \<=
        END DUP cd * b d * - SWAP pd * b n * + IQUOT n OVER * d + ROT * OVER NEG pd * cd + DUP2 n0 * + d0 ROT * SWAP OVER / UNROT /
        IF ROT 0 \=/
        THEN "X"
        ELSE "N"
        END \->TAG
      \>>
    ELSE DROP :N: 0
    END
  \>>
\>>