elsie-four.fth 3.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109
  1. \ Elsie-Four (LC4), Copyright 2018 etb, License: GPLv3+
  2. CREATE K 36 ALLOT \ Key buffer
  3. CREATE S 36 ALLOT \ State buffer
  4. CREATE M 0 , \ Marker
  5. : ->INT ( c -- n)
  6. DUP [CHAR] # = IF DROP 0 ELSE
  7. DUP [CHAR] _ = IF DROP 1 ELSE
  8. DUP [CHAR] 2 >= OVER [CHAR] 9 <= AND IF [ CHAR 2 2 - ]L - ELSE
  9. DUP [CHAR] a >= OVER [CHAR] z <= AND IF [ CHAR a 10 - ]L - ELSE
  10. DUP [CHAR] A >= OVER [CHAR] Z <= AND IF [ CHAR A 10 - ]L - ELSE
  11. ." Warning: mapping '" EMIT ." ' to '_'" CR 1
  12. THEN THEN THEN THEN THEN ;
  13. : ->CHAR ( n -- c) >R
  14. S" #_23456789abcdefghijklmnopqrstuvwxyz" R@ <
  15. IF [CHAR] * ELSE R@ + C@ THEN R> DROP ;
  16. CREATE BUF 256 ALLOT CREATE B BUF ,
  17. : B0 BUF B ! ; : .B BUF B @ BUF - TYPE ;
  18. : B, B @ C! [ 1 CHARS ]L B +! ;
  19. CREATE A 0 ,
  20. : C@A+ ( -- c) A @ C@ 1 CHARS A +! ;
  21. : A-C! ( c --) A @ 1 CHARS - TUCK C! A ! ;
  22. : RIGHT-ROTATE ( row --) 6 * S + A !
  23. C@A+ C@A+ C@A+ C@A+ C@A+ C@A+ >R
  24. A-C! A-C! A-C! A-C! A-C! R> A-C! ;
  25. : C@A6+ ( -- c) A @ C@ 6 CHARS A +! ;
  26. : A6-C! ( c --) A @ 6 CHARS - TUCK C! A ! ;
  27. : DOWN-ROTATE ( col --) S + A !
  28. C@A6+ C@A6+ C@A6+ C@A6+ C@A6+ C@A6+ >R
  29. A6-C! A6-C! A6-C! A6-C! A6-C! R> A6-C! ;
  30. : S[] ( n -- c) S + C@ ;
  31. : SFIND ( c -- n) >R
  32. 0 BEGIN DUP S[] R@ <> WHILE CHAR+ REPEAT R> DROP ;
  33. : +S ( n n' -- n'') \ Add indices within the state matrix
  34. 6 /MOD ROT 6 /MOD ROT
  35. + 6 MOD 6 * >R + 6 MOD R> + ;
  36. : -S ( n n' -- n'') \ Subtract indices within the state matrix
  37. 6 /MOD ROT 6 /MOD ROT
  38. - 6 MOD 6 * >R SWAP - 6 MOD R> + ;
  39. \ Rather than maintain row and column indices for various markers,
  40. \ just keep track of the character, and search, via SFIND, for the
  41. \ index in S when needed.
  42. : UPDATE ( C P --)
  43. SFIND 6 / RIGHT-ROTATE \ rotate row of P
  44. DUP SFIND 6 MOD DOWN-ROTATE \ rotate column of C
  45. M @ SFIND +S S[] M ! ; \ adjust marker
  46. : CIPHER ( c --) ->INT
  47. DUP SFIND M @ ( P P' M)
  48. +S ( P C') S[] TUCK ( C P C)
  49. ->CHAR B, UPDATE ;
  50. : PLAIN ( c --) ->INT
  51. DUP SFIND M @ ( C C' M)
  52. -S ( C P') S[] DUP ( C P P)
  53. ->CHAR B, UPDATE ;
  54. : (ENCRYPT) ( c-addr u) BOUNDS ?DO I C@ CIPHER LOOP ;
  55. : (DECRYPT) ( c-addr u) BOUNDS ?DO I C@ PLAIN LOOP ;
  56. : RESET K S 36 CMOVE 0 S[] M ! ; \ Reset the state matrix and marker
  57. : ENCRYPT ( nonce u1 header u2 plaintext u3 sig u4)
  58. RESET
  59. 2>R 2>R 2SWAP \ save plaintext/sig for later, setup nonce
  60. (ENCRYPT) B0 \ encrypt the nonce and ignore
  61. (ENCRYPT) B0 \ encrypt header, if any, and ignore
  62. 2R> 2R> 2SWAP \ restore sig/plaintext
  63. (ENCRYPT) \ encrypt the plaintext
  64. (ENCRYPT) \ append the encrypted sig
  65. CR ." Ciphertext: " .B CR ;
  66. : DECRYPT ( nonce u1 header u2 ciphertext u3)
  67. RESET
  68. 2SWAP 2ROT \ save ciphertext for later, setup nonce
  69. (ENCRYPT) B0 \ encrypt the nonce and ignore
  70. (ENCRYPT) B0 \ encrypt header, if any, and ignore
  71. (DECRYPT) \ decrypt the ciphertext
  72. CR ." Plaintext: " .B CR ;
  73. : S. S A ! 6 0 DO 6 0 DO C@A+ ->CHAR EMIT LOOP SPACE LOOP ;
  74. : M. SPACE M @ SFIND 6 /MOD . SPACE . SPACE ;
  75. : TRACE ( c-addr u) CR RESET
  76. ." State" 38 SPACES ." i j pt ct" CR
  77. S. M. CR BOUNDS ?DO
  78. I C@ CIPHER
  79. S. M. I C@ EMIT 2 SPACES B @ 1 CHARS - C@ EMIT CR
  80. LOOP ;
  81. \ Convenience syntax
  82. : SEND
  83. BL PARSE \ nonce
  84. BL PARSE \ header
  85. BL PARSE \ plaintext
  86. BL PARSE \ sig
  87. ENCRYPT ;
  88. : RECEIVE
  89. BL PARSE \ nonce
  90. BL PARSE \ header
  91. BL PARSE \ ciphertext
  92. DECRYPT ;
  93. : PRIV-KEY ( " ccc" --)
  94. BL WORD COUNT
  95. 36 <> IF DROP ." ERROR: Key must have length 36" CR QUIT THEN
  96. A ! 36 0 DO C@A+ ->INT K I + C! LOOP ; IMMEDIATE
  97. PRIV-KEY XV7YDQ#OPAJ_39RZUT8B45WCSGEHMIKNF26L
  98. RESET