Threaded Mode | Linear Mode

Gerald H · 12-03-2017, 11:35 AM

This thread

http://www.hpmuseum.org/forum/thread-9610.html

concerning accuracy prompted this posting.

The programme DE & 9 associated sub-programmes are updates for the 49G, 49g+ & 50g of the programme DE from

Ralf Thoma's

book

HP-Taschenrechner
Programmieren mit RPL

ISBN 3-88229-052-8

from 1995 & originally for the 48G.

DE takes real or complex numerical input & seeks a simple symbolic representation of the number, returning the input in the variable DE.OR, error in the symbolic representation in variable DE.ER & the symbolic representation to the stack. The programme also accepts a list of numbers.

Examples:

for input

(.701560760018,.129436325678)

the programme returns

'3*√7/(8*√2)+i*(62/479)'

& similarly

(1.60943791243,.261799387799)

'LN(5)+i*(1/12*π)'

&

(.629960524948,25.2477084857)

'(1/4)^(1/3)+i*(7*√13+1/113)'

The programme warns of a poor approximation & prefers symbolics containing small value integers.

I welcome improvements & am most pleased to hear of bugs.

DE

Code:

::

  CK1

  FPTR2 ^PUSHFLAGS_

  BINT22

  SetSysFlag

  BINT103

  SetSysFlag

  BINT105

  SetSysFlag

  ID x001

  FPTR2 ^POPFLAGS_

;

x001

Code:

::

  DUP'

  ID DE.OR

  ?STO_HERE

  ID x003

  DUP

  ID DE.OR

  ID x002

  '

  ID DE.ER

  ?STO_HERE

  FPTR2 ^QPI

;

x002

Code:

::

  DUPTYPELIST?

  case

  ::

    '

    ID x002

    BINT2

    FALSE

    ROMPTR E8 10

  ;

  x-

  xABS

  CRUNCH

  DUP

  % .00000000001

  %<

  ?SEMI

  " DE DANGER: RESULT NOT ACCURATE!"

  DispCoord1

  SetDA3Temp

;

x003

Code:

::

  DUPTYPELIST?

  case

  ::

    '

    ID x003

    BINT1

    FALSE

    ROMPTR E8 10

  ;

  DUPTYPEREAL?

  case

  ID x006

  DUPTYPECMP?

  NOT?SEMI

  C%>%

  ID x006

  SWAP

  ID x006

  SWAP'

  xi

  SWAP'

  x*

  BINT3

  SYMBN

  x+

;

x004

Code:

::

  DUP

  %SGN

  SWAP

  %ABS

  ID x008

  ROT

  %*

  SWAPDUP

  %1

  %=

  caseDROP

  '

  x/

  BINT3

  SYMBN

;

x005

Code:

::

  SWAP

  CRUNCH

  %SQ_

  ID x008

  %EXPONENT

  SWAP

  %EXPONENT

  %+

  %ABS

  %5

  %<

  IT

  ::

    BINT6

    TestUserFlag

    ?SEMI

    EVAL

    SWAPROT

    BINT6

    SetUserFlag

  ;

  DROP

;

x006

Code:

::

  CRUNCH

  DUP%0=

  ?SEMI

  DUP

  ID x004

  editdecomp$w

  LEN$

  BINT14

  #>

  NOTcase

  ID x004

  DUP

  xSQ

  ID x004

  editdecomp$w

  LEN$

  BINT14

  #>

  NOTcase

  ID x009

  BINT6

  ClrUserFlag

  DUP

  %SGN

  SWAP

  %ABS

  DUP

  %LN

  '

  ::

    %LN

    '

    xEXP

    ID x007

  ;

  ID x005

  DUP

  %EXP

  '

  ::

    %EXP

    '

    xLN

    ID x007

  ;

  ID x005

  DUP

  %PI

  %*

  '

  ::

    %PI

    %*

    ID x006

    xPI

    x/

    OVER

  ;

  ID x005

  DUP

  %PI

  %/

  '

  ::

    %PI

    %/

    ID x006

    xPI

    x*

    OVER

  ;

  ID x005

  DUP

  %PI

  xSQ

  %/

  '

  ::

    %PI

    xSQ

    %/

    ID x006

    xPI

    xSQ

    x*

    OVER

  ;

  ID x005

  DUP

  %ALOG

  '

  ::

    %ALOG

    '

    xLOG

    ID x007

  ;

  ID x005

  x*

  %0

  BEGIN

  % .25

  %+

  2DUP

  %1/

  %-

  '

  ::

    %1/

    2DUP

    %-

    ID x006

    OVER

    ID x006

    x+

  ;

  ID x005

  2DUP

  %1/

  %+

  '

  ::

    %1/

    2DUP

    %+

    ID x006

    OVER

    ID x006

    x-

  ;

  ID x005

  2DUP

  %SQRT

  %-

  '

  ::

    %SQRT

    2DUP

    %-

    ID x006

    OVER

    ID x006

    x+

  ;

  ID x005

  2DUP

  %SQRT

  %+

  '

  ::

    %SQRT

    2DUP

    %+

    ID x006

    OVER

    ID x006

    x-

  ;

  ID x005

  DUP

  %10

  %>=

  BINT6

  TestUserFlag

  OR

  UNTIL

  DROP

  %1

  BEGIN

  %1+

  2DUP

  %SQRT

  %MOD

  '

  ::

    %SQRT

    2DUP

    %MOD

    ROTOVER

    %-

    ID x006

    OVER

    ID x006

    x+

  ;

  ID x005

  2DUP

  %SQRT

  DUPUNROT

  %MOD

  %-

  '

  ::

    %SQRT

    2DUP

    %MOD

    %MOD

    2DUP

    %+

    ID x006

    OVER

    ID x006

    x-

  ;

  ID x005

  DUP

  %16

  %=

  BINT6

  TestUserFlag

  OR

  UNTIL

  DROP

  %0

  BEGIN

  DUP

  %10

  %<=

  BINT6

  TestUserFlag

  NOTAND

  WHILE

  ::

    % .25

    %+

    2DUP

    %-

    '

    ::

      2DUP

      %-

      ID x006

      OVER

      ID x006

      x+

    ;

    ID x005

    2DUP

    %+

    '

    ::

      2DUP

      %+

      ID x006

      OVER

      ID x006

      x-

    ;

    ID x005

    2DUP

    %1/

    %SQRT

    %-

    '

    ::

      %1/

      %SQRT

      2DUP

      %-

      ID x006

      OVER

      ID x006

      x+

    ;

    ID x005

    2DUP

    %1/

    %SQRT

    %+

    '

    ::

      %1/

      %SQRT

      2DUP

      %+

      ID x006

      OVER

      ID x006

      x-

    ;

    ID x005

  ;

  REPEAT

  DROPDUP

  %ABS

  BINT6

  BINT2

  DO

  DUPINDEX@

  FPTR2 ^PPow#

  '

  ::

    OVER

    %SGN

    OVER

    INDEX@

    FPTR2 ^PPow#

    ID x006

    INDEX@

    UNCOERCE

    %1/

    ID x006

    x^

    x*

  ;

  ID x005

  LOOP

  DROP

;

x007

Code:

::

  SWAP

  ID x006

  SWAP

  BINT2

  SYMBN

  OVER

;

x008

Code:

::

  %9

  OVER

  %EXPONENT

  %1

  %MAX

  %-

  %ALOG

  DUPUNROT

  %*

  2DUP

  BEGIN

  OVER

  %MOD

  DUPUNROT

  % 50.

  %<

  UNTIL

  SWAPDROP

  ROTOVER

  %/

  %IP

  3UNROLL

  %/

  %IP

;

x009

Code:

::

  DUP

  %SGN

  SWAP

  %SQ_

  ID x008

  BINT2

  ZERO_DO

  % 49.

  OVER

  %SQRT

  %IP

  %MIN

  %1

  %MAX

  BEGIN

  2DUP

  %SQ_

  %MOD

  %0<>

  OVER

  %2

  %>=

  AND

  WHILE

  %1-

  REPEAT

  DUPUNROT

  %SQ_

  %/

  DUP

  %1

  %=

  ITE

  DROP

  ::

    '

    xSQRT

    BINT2

    SYMBN

    x*

  ;

  SWAPLOOP

  SWAP

  x/

  x*

;