(49G) Arabic to Pseudo-Roman Representation (OEIS A093788)

[Gerald H]

The programme takes an integer as input & returns the Roman representation in Arabic numerals.

eg For input

1953

otherwise known as

MCMLIII

the programme returns

1000100100050111

which is the letter by letter, left to right, value of the Roman letters.

For further info see

http://oeis.org/A093788

Code:


::
  CK1&Dispatch
  # FF
  ::
    FPTR2 ^DupQIsZero?
    caseSIZEERR
    FPTR2 ^Z>S
    TOTEMPOB
    CODE 00048 8FB97601438F15811137135CD472819F1CCC4C213414F14A14C149171181CD5BE8F34150
    NULL$SWAP
    DUPLEN$
    #1+_ONE_DO
    DUPINDEX@
    SUB$1#
    BINT48
    #-
    ::
      DUP#0=
      ?SEMI
      BINT1
      #=casedrop
      {
        Z1_
      }
      BINT2
      #=casedrop
      {
        Z1_
        Z1_
      }
      BINT3
      #=casedrop
      {
        Z1_
        Z1_
        Z1_
      }
      BINT4
      #=casedrop
      {
        Z5_
        Z1_
      }
      BINT5
      #=casedrop
      {
        Z5_
      }
      BINT6
      #=casedrop
      {
        Z1_
        Z5_
      }
      BINT7
      #=casedrop
      {
        Z1_
        Z1_
        Z5_
      }
      BINT8
      #=case
      {
        Z1_
        Z1_
        Z1_
        Z5_
      }
      {
        Z10_
        Z1_
      }
    ;
    DUP#0=ITE
    DROPNULL$
    ::
      INNERCOMP
      NULL$SWAP
      ZERO_DO
      SWAP
      Z10_
      JINDEX@
      #1-
      FPTR2 ^RP#
      FPTR2 ^RMULText
      FPTR2 ^Z>S
      &$
      LOOP
    ;
    ROT
    &$SWAP
    LOOP
    DROP
    FPTR2 ^S>Z
  ;
;

[Gerald H]

Here a slightly improved version of the programme:

Code:


::
  CK1&Dispatch
  # FF
  ::
    FPTR2 ^DupQIsZero?
    caseSIZEERR
    FPTR2 ^Z>S
    NULL$SWAP
    DUPLEN$
    ZERO_DO
    DUP
    ISTOP-INDEX
    SUB$1#
    BINT48
    #-
    ::
      DUP#0=csDROP
      ::
        BINT1
        #=casedrop
        {
          Z1_
        }
        BINT2
        #=casedrop
        {
          Z1_
          Z1_
        }
        BINT3
        #=casedrop
        {
          Z1_
          Z1_
          Z1_
        }
        BINT4
        #=casedrop
        {
          Z5_
          Z1_
        }
        BINT5
        #=casedrop
        {
          Z5_
        }
        BINT6
        #=casedrop
        {
          Z1_
          Z5_
        }
        BINT7
        #=casedrop
        {
          Z1_
          Z1_
          Z5_
        }
        BINT8
        #=case
        {
          Z1_
          Z1_
          Z1_
          Z5_
        }
        {
          Z10_
          Z1_
        }
      ;
      INNERCOMP
      NULL$SWAP
      ZERO_DO
      SWAP
      Z10_
      JINDEX@
      FPTR2 ^RP#
      FPTR2 ^RMULText
      FPTR2 ^Z>S
      &$
      LOOP
      ROT
      &$SWAP
    ;
    LOOP
    DROP
    FPTR2 ^S>Z
  ;
;

[Gerald H]

Another improved(?) version:

Code:


::
  CK1&Dispatch
  # FF
  ::
    FPTR2 ^DupQIsZero?
    caseSIZEERR
    {
      {
        Z1_
      }
      {
        Z1_
        Z1_
      }
      {
        Z1_
        Z1_
        Z1_
      }
      {
        Z1_
        Z5_
      }
      {
        Z5_
      }
      {
        Z5_
        Z1_
      }
      {
        Z5_
        Z1_
        Z1_
      }
      {
        Z5_
        Z1_
        Z1_
        Z1_
      }
      {
        Z1_
        Z10_
      }
    }
    NULL$
    ROT
    FPTR2 ^Z>S
    DUPLEN$
    ZERO_DO
    DUP
    ISTOP-INDEX
    SUB$1#
    BINT48
    #-
    ::
      DUP#0=csedrp
      NULL$
      4PICKSWAP
      NTHCOMPDROP
      INNERCOMP
      NULL$SWAP
      ZERO_DO
      SWAP
      Z10_
      JINDEX@
      FPTR2 ^RP#
      FPTR2 ^RMULText
      FPTR2 ^Z>S
      SWAP&$
      LOOP
    ;
    ROT
    &$SWAP
    LOOP
    DROPSWAPDROP
    FPTR2 ^S>Z
  ;
;