Base conversion (including fractional parts)

[compsystems]

Radix synonymous of base =)

Base conversion is a port of BASECAL (rpn)? As a suggestion to separate the hp-prime code in sub-functions

PHP Code:

%%HP: T(3)A(R)F(.);

@->IB  : Take either a binary or a real from the stack and return
@       it in the base specified in BBASE, rounded off to IBFIX
@        places.

@IB->  : Take an IB string from the stack and convert it to either
@        a binary number or a real.  If IBFIX is set to zero, it will
@        always return a binary number.  If IBFIX is set to somthing
@        other than zero, it will use return a real if the base-10
@        numver is less than 1E12.

@IB2-> : Runs IB-> on the objects in level one and two, leaving their
@        order intact.

@BBASE : The current base. (2-62 is valid)

@IBFIX : Number of desired decimal places. (0 will force all calculations
@                                          to be carried out in binaries)

@->IB2 : Runs ->IB on the objects in level 1 and two, leaving their
@        order intact.


@ BASECALC by Ian Matthew Smith
@ Automatic decimal lengths added by Joe Horn
DIR

  BMTH @ create custom menu
    \<< { Add \<< IB2\-> + \->IB \>> }
        { Sub \<< IB2\-> - \->IB \>> }
        { Mul \<< IB2\-> * \->IB \>> }
        { Div \<< IB2\-> / \->IB \>> }
      BBASE "/" IBFIX + +
      { \<< B\->FIX 'BBASE' STO BMTH \>>
        \<< B\->FIX SWAP IB\-> SWAP 'BBASE' STO \->IB BMTH \>>
        \<< 'IBFIX' STO BMTH \>> }
      2 \->LIST { CONV {
      \<< DUP
        IF TYPE 2 ==
        THEN IB\->
        ELSE \->IB
        END
      \>>
      \<< DUP
        IF TYPE 0 ==
        THEN R\->B
        ELSE DUP
          IF TYPE 10 ==
          THEN B\->R
          END
        END
      \>> } } 6 \->LIST TMENU
    \>>

  \->IB
    \<< DUP
      IF TYPE 0 ==
      THEN DUP FP SWAP IP R\->B
      ELSE 0 SWAP
      END DUP
      IF TYPE 10 ==
      THEN RCWS SWAP "" SWAP 64 STWS
        WHILE DUP B\->R
        REPEAT DUP BBASE DUP2 / * - 1 + BSTR SWAP
          B\->R DUP SUB ROT + SWAP BBASE /
        END DROP SWAP STWS SWAP
        IF DUP BBASE IBFIX ^ * 1 <
        THEN DROP
        ELSE "" SWAP 1 IBFIX
          START
            IF DUP 0 \=/
            THEN BBASE * DUP IP BSTR SWAP 1 + DUP SUB ROT SWAP + SWAP FP
            END
          NEXT DROP "." SWAP + +
        END
      END
    \>>

  IB\->
    \<< DUP
      IF TYPE 2 ==
      THEN RCWS SWAP 64 STWS
        IF DUP "." POS
        THEN DUP DUP "." POS SWAP DUP SIZE ROT 1 + SWAP SUB
          SWAP DUP "." POS 1 - 1 SWAP SUB
        ELSE "" SWAP
        END # 0d SWAP DUP SIZE 1 - 0 SWAP
        FOR j DUP DUP SIZE j - DUP SUB BSTR SWAP POS 1 - # 1d
          IF j 0 >
          THEN BBASE 1 j
            START DUP ROT * SWAP
            NEXT DROP
          END * ROT + SWAP
        NEXT DROP
        IF DUP B\->R 1.E12 < IBFIX AND
        THEN B\->R
        END SWAP
        IF DUP SIZE
        THEN 0 SWAP DUP SIZE 1 SWAP
          FOR j DUP j j SUB BSTR SWAP POS 1 - BBASE j NEG ^ * ROT + SWAP
          NEXT DROP +
        ELSE DROP
        END SWAP STWS
      ELSE
        IF DUP TYPE 0 == IBFIX NOT AND
        THEN R\->B
        END
      END
    \>>

  IB2\->
    \<< IB\-> SWAP IB\-> SWAP
    \>>

  BBASE 16

  IBFIX 0

  \->IB2
    \<< \->IB SWAP \->IB SWAP
    \>>
  B\->FIX  @ this tiny routine was tacked on by Joe Horn
    \<< 2 MAX 62 MIN 12 OVER LOG / IP 'IBFIX' STO
    \>>

  BSTR
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
END