extra/enigma/enigma.factor

   1 ! Copyright (C) 2011 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays ascii kernel locals math random
   5 sequences sequences.extras vectors ;
   6
   7 IN: enigma
   8
   9 : <alphabet> ( -- seq )
  10     26 <iota> >array ;
  11
  12 : <cog> ( -- cog )
  13     <alphabet> randomize ;
  14
  15 : <reflector> ( -- reflector )
  16     <alphabet> dup length <iota> >vector [ dup empty? ] [
  17         [
  18             [ delete-random ] [ delete-random ] bi
  19             pick exchange
  20         ] keep
  21     ] until drop ;
  22
  23 TUPLE: enigma cogs prev-cogs reflector ;
  24
  25 : <enigma> ( num-cogs -- enigma )
  26     [ <cog> ] replicate dup clone <reflector> enigma boa ;
  27
  28 : reset-cogs ( enigma -- enigma )
  29     dup prev-cogs>> >>cogs ;
  30
  31 : special? ( n -- ? )
  32     [ 25 > ] [ 0 < ] bi or ;
  33
  34 :: encode ( text enigma -- cipher-text )
  35     0 :> ln!
  36     enigma cogs>> :> cogs
  37     enigma reflector>> :> reflector
  38     text >lower [
  39         CHAR: a mod dup special? [
  40             ln 1 + ln!
  41             cogs [ nth ] each reflector nth
  42             cogs reverse [ index ] each CHAR: a +
  43             cogs length <iota> [ 6 * 1 + ln mod zero? ] filter
  44             cogs [ unclip prefix ] change-nths
  45         ] unless
  46     ] map ;