Threaded Mode | Linear Mode

Gerald H · (This post was last modified: 06-15-2017 01:40 PM by Gene.)

Given a prime positive integer P & a positive integer input the programme produces a perfect permutation of the positive integers < P.

A perfect permutation consists of integers where the difference between neighbours is not repeated.

eg For input

107
45

the programme returns

{ 1 45 99 68 64 98 23 72 30 66 81 7 101 51 48 20 44 54 76 103 34 32 49 65 36 15 33 94 57 104 79 24 10 22 27 38 105 17 16 78 86 18 61 70 47 82 52 93 12 5 11 67 19 106 62 8 39 43 9 84 35 77 41 26 100 6 56 59 87 63 53 31 4 73 75 58 42 71 92 74 13 50 3 28 83 97 85 80 69 2 90 91 29 21 89 46 37 60 25 55 14 95 102 96 40 88 }

Code:

::

  CK2&Dispatch

  # FFFF

  ::

    OVER

    Z2_

    EQUAL

    caseSIZEERR

    OVER

    Z3_

    EQUALcase

    ::

      2DROP

      {

        Z1_

        Z2_

      }

    ;

    Z1_

    FPTR2 ^RSUBext

    ::

      SWAP

      FPTR2 ^ZABS

      FPTR2 ^DupZIsTwo?

      case

      ::

        SWAPDROP

        Z1_

      ;

      DUP

      ::

        FPTR2 ^ISPRIME

        %0<>

        ?SEMI

        # DE1E

        ERROROUT

      ;

      DUP

      Z1_

      FPTR2 ^QSub

      DUP

      FPTR2 ^MZSQFF

      NULL{}

      SWAP

      #2/

      DUPUNROT

      ZERO_DO

      2SWAP

      DROP

      >TCOMP

      LOOP

      SWAPROT

      FPTR2 ^2LAMBIND

      ROT

      BEGIN

      Z1_

      FPTR2 ^QAdd

      ::

        DUP

        FPTR2 ^ZSQRT

        SWAPDROP

        caseFALSE

        3PICK

        FPTR2 ^ZMod

        FPTR2 ^DupQIsZero?

        caseFALSE

        TRUE

        4UNROLL

        2GETLAM

        #1+_ONE_DO

        DUP

        1GETLAM

        4PICK

        INDEX@

        NTHCOMPDROP

        FPTR2 ^ZQUOText

        5PICK

        FPTR2 ^ModPow

        4PICK

        FPTR2 ^QMod

        FPTR2 ^ZIsOne?

        IT

        ::

          4ROLLDROP

          FALSE

          4UNROLL

          ExitAtLOOP

        ;

        LOOP

        4ROLL

      ;

      UNTIL

      ABND

      SWAPDROP

    ;

    Z1_

    UNROTOVER

    Z1_

    FPTR2 ^RSUBext

    3UNROLL

    Z1_

    ROTDUP

    FPTR2 ^Z2BIN

    #1-

    DUPUNROT

    FPTR2 ^2LAMBIND

    #2/

    ONE_DO

    OVER

    2GETLAM

    FPTR2 ^ModMul

    DUP

    2GETLAM

    FPTR2 ^Mod

    2GETLAM

    OVER

    FPTR2 ^RSUBext

    SWAPINDEX@

    #4+

    UNROLL

    3UNROLL

    LOOP

    2DROP

    1GETABND

    {}N

  ;

;