# The solitaire encryption algorithm, designed by Bruce Schneier.
#        Copyright Counterpane Internet Security, Inc., 2001
# Check out <http://www.counterpane.com/solitaire.html> for details.
#
# Tcl version by Frans Houweling <fhou@libero.it>, no warranties of any kind.
#
# Usage:
#                   package require solitaire
# (optionally provide your own character set, e.g. only letters and space:
#                   ::solitaire::init "A-Z" { } "a-z" )
#                   namespace import ::solitaire::*
#                   puts [encrypt "DO NOT USE PC" "With my secret passphrase"]
#                         (result: coQoMUXyVXtsF
#                   puts [decrypt "coQoMUXyVXtsF" "With my secret passphrase"]
#                         (result: DO NOT USE PC)
#
# Sorry about the speed.
#

package provide solitaire 1.0


namespace eval solitaire {
    variable DECKSIZE 54
    variable deck
    variable abc
    namespace export encrypt decrypt
}

# Internal use.
# Takes characters or ranges of characters and puts them in a list.
#
proc solitaire::alphabet {args} {
    set syms [list]
    foreach arg $args {
	if [regexp "^(.)-(.)$" $arg dum lo hi] {
	    scan $lo "%c" bot
	    scan $hi "%c" top
	    for {set i $bot} {$i <= $top} {incr i} {
		lappend syms [format "%c" $i]
	    }
	} else {
	    while {[string length $arg]} {
		lappend syms [string index $arg 0]
		set arg [string range $arg 1 end]
	    }
	}
    }
    return $syms
}

# Internal use.
# Just creates a list of the numbers 1..54 (52 + 2 jokers)
#
proc solitaire::initDeck {deckLength} {
    variable deck
    set deck [list]
    for {set i 1} {$i <= $deckLength} {incr i} {
	lappend deck $i
    }
    return
}

# Internal use.
# Returns 53
#
proc solitaire::jokerA {} {
    variable deck
    return [expr [llength $deck] - 1]
}

# Internal use.
# Returns 54
#
proc solitaire::jokerB {} {
    variable deck
    return [llength $deck]
}

# Internal use.
# "Find the A joker. Move it one card down (That is, swap it with the
#  card beneath it.) If the joker is the bottom card of the deck, move
#  it just below the top card."
#
proc solitaire::moveJoker {joker} {
    variable deck
    set pos [lsearch -exact $deck $joker]
    if {$pos == [expr [llength $deck] - 1]} {
	set nwDeck [lrange $deck 0 0]
	lappend nwDeck $joker
	foreach card [lrange $deck 1 [expr [llength $deck] - 2]] {
	    lappend nwDeck $card
	}
    } else {
	set nwDeck [lrange $deck 0 [expr $pos - 1]]
	lappend nwDeck [lindex $deck [expr $pos + 1]]
	lappend nwDeck $joker
	foreach card [lrange $deck [expr $pos + 2] end] {
	    lappend nwDeck $card
	}
    }
    set deck $nwDeck
    return
}

# Internal use.
# "Perform a triple cut. That is, swap the cards above the first joker
#  with the cards below the second joker [...] 'First' and 'second'
#  jokers refer to whatever joker is nearest to, and furthest from, the
#  top of the deck."
#
proc solitaire::tripleCut {} {
    variable deck
    set posA [lsearch -exact $deck [::solitaire::jokerA]]
    set posB [lsearch -exact $deck [::solitaire::jokerB]]
    if {$posA > $posB} {
	set tmp $posA
	set posA $posB
	set posB $tmp
    }
    set nwDeck [lrange $deck [expr $posB + 1] end]
    foreach card [lrange $deck $posA $posB] {
	lappend nwDeck $card
    }
    foreach card [lrange $deck 0 [expr $posA - 1]] {
	lappend nwDeck $card
    }
    set deck $nwDeck
    return
}

# Internal use.
# "Perform a count cut. Look at the bottom card. Convert it into a
#  number from 1 to 53 [...] Either joker is a 53. Count down from the
#  top card that number. [...] Cut after the card that you counted down
#  to, leaving the bottom card on the bottom. [...] A deck with a joker
#  as the bottom card will remain unchanged by this step."
#
proc solitaire::countCut {{val -1}} {
    variable deck
    if {$val == -1} {
	set cutPos [expr [lindex $deck end] - 1]
    } else {
	set cutPos $val
    }
    if {$cutPos == [::solitaire::jokerB]} {
	set cutPos [::solitaire::jokerA]
    }
    set nwDeck [lrange $deck [expr $cutPos + 1] [expr [llength $deck] - 2]]
    foreach card [lrange $deck 0 $cutPos] {
	lappend nwDeck $card
    }
    lappend nwDeck [lindex $deck end]
    set deck $nwDeck
    return
}


# Internal use.
# This is the algorithm
#
proc solitaire::keyStream {} {
    variable deck
    # step 1
    ::solitaire::moveJoker [::solitaire::jokerA]
    # step 2
    ::solitaire::moveJoker [::solitaire::jokerB]
    ::solitaire::moveJoker [::solitaire::jokerB]
    # step 3
    ::solitaire::tripleCut
    # step 4
    ::solitaire::countCut
    # step 5
    # "Find the output card. To do this, look at the top card. Convert it
    #  into a number from 1 to 53 in the same manner as step 4. Count down
    #  that many cards. (Count the top card as numer one.) Write the card
    #  after the one you counted to on a piece of paper; don't remove it
    #  from the deck. (If you hit a joker, don't write anything down and
    #  start over again with step 1)."
    set pos [lindex $deck 0]
    if {$pos == [::solitaire::jokerB]} {
	set pos [::solitaire::jokerA]
    }
    set card [lindex $deck [expr $pos]]
    if {$card == [::solitaire::jokerA] || $card == [::solitaire::jokerB]} {
	set card [::solitaire::keyStream]
    }
    return $card
}

# Internal use.
# Converts characters to list of numbers (indexes in your alphabet)
#
proc solitaire::c2n {msg} {
    variable abc
    set nums [list]
    while {[string length $msg]} {
	if {[set pos [lsearch -exact $abc [string index $msg 0]]] == -1} {
	    lappend nums 0
	} else {
	    lappend nums $pos
	}
	set msg [string range $msg 1 end]
    }
    return $nums
}

# Internal use.
# Converts list of indexes into character string
#
proc solitaire::n2c {numList} {
    variable abc
    set msg {}
    foreach num $numList {
	append msg [lindex $abc $num]
    }
    return $msg
}


# Internal use.
# "Add the plaintext number stream to the keystream numbers, modulo 26"
#
proc solitaire::add {mList kList} {
    variable abc
    set oList [list]
    foreach m $mList k $kList {
	lappend oList [expr ($m + $k) % [llength $abc]]
    }
    return $oList
}


# Internal use.
# "Subtract the keystream numbers from the ciphertext numbers, modulo 26"
#
proc solitaire::sub {oList kList} {
    variable abc
    set mList [list]
    foreach o $oList k $kList {
	lappend mList [expr ($o + [llength $abc] - $k) % [llength $abc]]
    }
    return $mList
}

# Internal use.
# "Use a passphrase to order the deck. [...] Perform the Solitaire
# operation, but instead of Step 5, do another count cut based on the
# first character of the passphrase [...] Repeat the five steps of the
# Solitaire algorithm once for each character of the key."
#
proc solitaire::shuffleDeck {passPhrase} {
    variable deck
    while {[string length $passPhrase]} {
	set dummy [::solitaire::keyStream]
	::solitaire::countCut [::solitaire::c2n [string range $passPhrase 0 0]]
	set passPhrase [string range $passPhrase 1 end]
    }
    return
}

#
# Set up the character set. Default is sort of italian.
# If you provide "A-Z" only you have the original 26-letter version.
# Don't use other characters in the message, or you will get A's (or
# whatever is the first character) decrypting).
#
proc solitaire::init {args} {
    variable abc
    if {![llength $args]} {
	set abc [::solitaire::alphabet "0-9" "A-Z" "a-z" " אטילעש!?.,_-'" ]
    } else {
	set abc [eval ::solitaire::alphabet $args]
    }
    return
}

#
# Passphrase is optional, but without it there is no security.
#
proc solitaire::encrypt {msg {passPhrase {}}} {
    variable abc
    variable deck
    variable DECKSIZE
    if {![info exists abc]} {
	::solitaire::init
    }
    ::solitaire::initDeck $DECKSIZE
    if [string length $passPhrase] {
	::solitaire::shuffleDeck $passPhrase
    }
    set mList [::solitaire::c2n $msg]
    set kList [list]
    foreach m $mList {
	lappend kList [::solitaire::keyStream]
    }
    return [::solitaire::n2c [::solitaire::add $mList $kList]]
}


proc solitaire::decrypt {msg {passPhrase {}}} {
    variable abc
    variable deck
    variable DECKSIZE
    if {![info exists abc]} {
	::solitaire::init
    }
    ::solitaire::initDeck $DECKSIZE
    if [string length $passPhrase] {
	::solitaire::shuffleDeck $passPhrase
    }
    set oList [::solitaire::c2n $msg]
    set kList [list]
    foreach o $oList {
	lappend kList [::solitaire::keyStream]
    }
    return [::solitaire::n2c [::solitaire::sub $oList $kList]]
}