namespace eval enigma {
variable letters {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
variable nextMachine 0
variable machines
#The rotors, notches and reflectors.
#Taken from
#http://www.codesandciphers.org.uk/enigma/rotorspec.htm
array set rotors {
I {E K M F L G D Q V Z N T O W Y H X U S P A I B R C J}
II {A J D K S I R U X B L H W T M C Q G Z N P Y F V O E}
III {B D F H J L C P R T X V Z N Y E I W G A K M U S Q O}
IV {E S O V P Z J A Y Q U I R H X L N F T G K D C M W B}
V {V Z B R G I T Y U P S D N H L X A W M J Q O F E C K}
VI {J P G V O U M F Y Q B E N H Z R D K A S X L I C T W}
VII {N Z J H G R C X M Y S W B O U F A I V L P E K Q D T}
VIII {F K Q H T L X O C B J S P D Z R A M E W N I U Y G V}
Beta {L E Y J V C N I X W P B Q M D R T A K Z G F U H O S}
Gamma {F S O K A N U E R H M B T I Y C W L Q P Z X V G J D}
}
array set reflectors {
B {AY BR CU DH EQ FS GL IP JX KN MO TZ VW}
C {AF BV CP DJ EI GO HY KR LZ MX NW TQ SU}
BD {AE BN CK DQ FU GY HW IJ LO MP RX SZ TV}
CD {AR BD CO EJ FN GT HK IV LM PW QZ SX UY}
}
array set notches {
I {Q}
II {E}
III {V}
IV {J}
V {Z}
VI {Z M}
VII {Z M}
VIII {Z M}
Beta {}
Gamma {}
}
#create the easy access rotors
foreach rotor [array names rotors] {
foreach output $rotors($rotor) input $letters {
lappend rotors($rotor.$input) $output
lappend rotors($rotor.inv.$output) $input
}
}
#create the easy access reflectors
foreach reflector [array names reflectors] {
foreach swap $reflectors($reflector) {
set reflectors($reflector.[string index $swap 0]) [string index $swap 1]
set reflectors($reflector.[string index $swap 1]) [string index $swap 0]
}
}
}
proc enigma::shift {position input} {
variable letters
return [lindex $letters [expr ([lsearch $letters $position] +[lsearch $letters $input])%26]]
}
proc enigma::coreshift {position ring} {
variable letters
return [lindex $letters [expr ([lsearch $letters $position] -[lsearch $letters $ring])%26]]
}
proc enigma::shiftback {position input} {
variable letters
return [lindex $letters [expr ([lsearch $letters $input] -[lsearch $letters $position])%26]]
}
proc enigma::rotor {rotor position input {inverse 0}} {
variable rotors
upvar trans trans
#effect one rotor, in one direction:
if { $inverse } {
append trans [shift $position $input]:$rotors($rotor.inv.[shift $position $input])
return [shiftback $position $rotors($rotor.inv.[shift $position $input])]
} else {
append trans [shift $position $input]:$rotors($rotor.[shift $position $input])
return [shiftback $position $rotors($rotor.[shift $position $input])]
}
}
proc enigma::create {myRotors rings steckers {reflector B} } {
variable nextMachine
variable machines
variable letters
set m $nextMachine
incr nextMachine
set machines($m.rotors) $myRotors
set machines($m.reflector) $reflector
for {set i 0} {$i < [llength $myRotors]} {incr i} {
set machines($m.ring.$i) [lindex $rings $i]
}
foreach swap $steckers {
set machines($m.board.[string index $swap 0]) [string index $swap 1]
set machines($m.board.[string index $swap 1]) [string index $swap 0]
}
foreach l $letters {
if {![info exists machines($m.board.$l)]} {
set machines($m.board.$l) $l
}
}
return $m
}
proc enigma::destroy { machine } {
variable machines
foreach key [array names machines -glob $machine.*] {
unset machines($key)
}
}
proc enigma::get {machine pty} {
variable machines
return $machines($machine.$pty)
}
proc enigma::setrotors {machine positions} {
variable machines
set i 0
foreach letter $positions {
set machines($machine.position.$i) $letter
incr i
}
set machines($machine.position) $positions
}
proc enigma::encode {machine letter} {
#pass current through current configuration of machine, state remains
#unaltered.
variable machines
variable reflectors
set letter $machines($machine.board.$letter)
set trans ""
for {set i [expr [llength $machines($machine.rotors)]-1]} {$i >= 0} {incr i -1} {
set pos $machines($machine.position.$i)
set corepos [shiftback $machines($machine.ring.$i) $pos]
#puts "ring $machines($machine.ring.$i) $corepos"
append trans $letter
set letter [rotor [lindex $machines($machine.rotors) $i] \
$corepos \
$letter]
#set letter [shiftback $machines($machine.ring.$i) $letter]
#puts "[lindex $machines($machine.rotors) $i] $letter"
append trans "$letter "
}
set letter $reflectors($machines($machine.reflector).$letter)
append trans " > $letter "
for {set i 0} {$i < [llength $machines($machine.rotors)]} {incr i} {
set pos $machines($machine.position.$i)
set corepos [shiftback $machines($machine.ring.$i) $pos]
append trans $letter
set letter [rotor [lindex $machines($machine.rotors) $i] \
$corepos \
$letter \
1]
append trans "$letter "
}
set letter $machines($machine.board.$letter)
#puts $trans
return $letter
}
proc enigma::step {machine} {
variable machines
variable notches
#determine which ones should rotate:
#right most always moves.
lappend pushes [expr [llength $machines($machine.rotors)] -1]
for {set i [expr [llength $machines($machine.rotors)] -1]} {$i > -1} {incr i -1} {
if { [lsearch $notches([lindex $machines($machine.rotors) $i]) $machines($machine.position.$i)] >-1 } {
if { [lsearch $pushes $i] == -1 } { lappend pushes $i }
if { [lsearch $pushes [expr $i-1]] == -1 } { lappend pushes [expr $i-1] }
}
}
foreach push $pushes {
if { $push > -1 } {
set machines($machine.position.$push) [shift $machines($machine.position.$push) B]
}
}
set i 0
foreach r $machines($machine.rotors) {
lappend state $machines($machine.position.$i)
incr i
}
#puts "state: $state $pushes"
set machines($machine.position) $state
return $state
}
proc enigma::crypt {machine text} {
set enc ""
variable letters
foreach letter [split $text {}] {
set letter [string toupper $letter]
if { [lsearch -exact $letters $letter] > -1 } {
step $machine
append enc [encode $machine $letter]
} else {
append enc $letter
}
}
return $enc
}
package require Tk
wm title . "Pascal's Enigma Simulator"
proc validateEnigma {} {
updateOutput
return 1
}
proc updateOutput {} {
set m [enigma::create $::rotors $::rings $::steckers $::reflector]
enigma::setrotors $m $::positions
.output delete 0.0 end
.output insert 0.0 [enigma::crypt $m [.input get 0.0 end]]
set ::posat [enigma::get $m position]
enigma::destroy $m
if { [.input edit modified] } { .input edit modified 0 }
}
label .lrotors -text "Rotore"
entry .rotors -width 12 -textvariable ::rotors -validate focusout -validatecommand validateEnigma
grid .lrotors .rotors -sticky nw
label .lring -text "Ringstellung"
entry .rings -width 8 -textvariable ::rings -validate focusout -validatecommand validateEnigma
grid .lring .rings -sticky nw
label .lsteckers -text "Steckerverbindungen"
entry .steckers -width 30 -textvariable ::steckers -validate focusout -validatecommand validateEnigma
grid .lsteckers .steckers -sticky nw
label .lreflector -text "Reflector"
entry .reflector -width 3 -textvariable ::reflector -validate focusout -validatecommand validateEnigma
grid .lreflector .reflector -sticky nw
label .lpos -text "Rotors start position"
entry .pos -width 8 -textvariable ::positions -validate focusout -validatecommand validateEnigma
grid .lpos .pos -sticky nw
label .lposat -text "Rotor position"
entry .posat -width 8 -textvariable ::posat -state readonly
grid .lposat .posat -sticky nw
label .linput -text "Input"
grid .linput -sticky nw
text .input -width 60 -height 6
grid .input - -sticky nw
label .loutput -text "Output"
grid .loutput -sticky nw
text .output -width 60 -height 6
grid .output - -sticky nw
set ::rotors {II I V}
set ::rings {P R S}
set ::steckers {IL IK ET CL GH BP VU AS}
set ::reflector B
set ::positions {M K U}
set ::posat $::positions
bind .input <<Modified>> updateOutput if { 0 } {To encrypt a message, you do this:
#Use rotors IV I and V, with 'ringstellung' H Z I and
#steckerverbindungen DN GR IS KC QX TM PV HY FW BJ.
set m [enigma::create {IV I V} {H Z I} {DN GR IS KC QX TM PV HY FW BJ}]
#set the initial letters for encryption (indicator)
enigma::setrotors $m {T C L}
set message_key [list [enigma::crypt $m P] [enigma::crypt $m R] [enigma::crypt $m S]]
enigma::setrotors $m $message_key
set encrypted [enigma::crypt $m "Crypto Fun with Tcl!"]
enigma::setrotors $m $message_key
puts "$encrypted\n[enigma::crypt $m $encrypted]"So.With rotors II I V, at T C L and steckers IL IK ET CL GH BP VU AS, I'd like to say:- PRS UCJ FMD - PQBFH UNX HVW CGZMYJ YQ. YTTJC DZR LEI XSYTH DR R VQGBKX BFWTSOR BIRI SKFA.06May2003 PS
} ;# end if 0.
