Poker hand calculation and comparison (Tcl recipe) by Magnus Åhman

ActiveState Code (http://code.activestate.com/recipes/578539/)

#!/bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" ${1+"$@"}

package require Tcl 8.6.0

array set categories [list \
  highCard 0 \
  onePair 1 \
  twoPair 2 \
  threeOfAKind 3 \
  straight 4 \
  flush 5 \
  fullHouse 6 \
  fourOfAKind 7 \
  straightFlush 8 \
]
array set groupings [list \
  {1 1 1 1 1} $categories(highCard) \
  {2 1 1 1} $categories(onePair) \
  {2 2 1} $categories(twoPair) \
  {3 1 1} $categories(threeOfAKind) \
  {3 2} $categories(fullHouse) \
  {4 1} $categories(fourOfAKind) \
]
set nValues 13

oo::class create card {
  constructor {withSuit withValue} {
    my variable suit value
    set suit $withSuit
    set value $withValue
  }
  method suit {} {
    my variable suit
    return $suit
  }
  method value {} {
    my variable value
    return $value
  }
  destructor {
    my variable suit value
    $suit destroy
    $value destroy
  }
}

oo::class create category {
  constructor {withNr} {
    my variable nr
    set nr $withNr
  }
  method cmp {other} {
    my variable nr
    return [numCmp $nr [$other nr]]
  }
  method nr {} {
    my variable nr
    return $nr
  }
}

oo::class create hand {
  constructor {withCards} {
    global categories groupings
    my variable cards category kickers
    set cards $withCards
    set sortedValues [lsort -command {apply {{a b} {$a cmp $b}}} [lmap card $cards {$card value}]]
    set typeOfStraight [my TypeOfStraight $sortedValues]
    set isFlush [my IsFlush]
    if {$typeOfStraight} {
      set category [category new [expr {$isFlush ? $categories(straightFlush) : $categories(straight)}]]
      set kickers [list [lindex $sortedValues [expr {$typeOfStraight == 1 ? "end" : "end-1"}]]]
      return
    }
    if {$isFlush} {
      set category [category new $categories(flush)]
      set kickers [lreverse $sortedValues]
      return
    }
    set nEquals {}
    set kickers {}
    while {[llength $sortedValues]} {
      lassign [longestSeq $sortedValues {apply {{a b} {$a cmp $b}}} 1] i n
      lappend nEquals $n
      lappend kickers [lindex $sortedValues $i]
      set sortedValues [lreplace $sortedValues $i [expr {$i + $n - 1}]]
    }
    set category [category new $groupings($nEquals)]
  }
  method category {} {
    my variable category
    return $category
  }
  method cmp {other} {
    my variable category kickers
    if {[set cmpRes [$category cmp [$other category]]] != 0} {
      return $cmpRes
    }
    foreach kicker $kickers otherKicker [$other kickers] {
      if {[set cmpRes [$kicker cmp $otherKicker]] != 0} {
        return $cmpRes
      }
    }
    return 0
  }
  method kickers {} {
    my variable kickers
    return $kickers
  }
  method IsFlush {} {
    my variable cards
    set firstSuit [[lindex $cards 0] suit]
    foreach card $cards {
      if {[[$card suit] cmp $firstSuit] != 0} {
        return 0
      }
    }
    return 1
  }
  method TypeOfStraight {sortedValues} {
    set sVLen [llength $sortedValues]
    set prevValue [lindex $sortedValues 0]
    for {set i 1} {$i < $sVLen} {incr i} {
      set value [lindex $sortedValues $i]
      if {![$value isSeqTo $prevValue]} {
        return [expr {$i == $sVLen - 1 && [[lindex $sortedValues 0] isLowest] && [[lindex $sortedValues end] isHighest] ? 2 : 0}]
      }
      set prevValue $value
    }
    return 1
  }
  destructor {
    my variable cards category
    foreach card $cards {
      $card destroy
    }
    $category destroy
  }
}

oo::class create suit {
  constructor {withNr} {
    my variable nr
    set nr $withNr
  }
  method cmp {other} {
    my variable nr
    return [numCmp $nr [$other nr]]
  }
  method nr {} {
    my variable nr
    return $nr
  }
}

oo::class create value {
  constructor {withNr} {
    my variable nr
    set nr $withNr
  }
  method cmp {other} {
    my variable nr
    return [numCmp $nr [$other nr]]
  }
  method isHighest {} {
    global nValues
    my variable nr
    return [expr {$nr == $nValues - 1}]
  }
  method isLowest {} {
    my variable nr
    return [expr {$nr == 0}]
  }
  method isSeqTo {other} {
    my variable nr
    return [expr {$nr == [$other nr] + 1}]
  }
  method nr {} {
    my variable nr
    return $nr
  }
}

proc longestSeq {list cmpCmd firstOrLast} {
  set bestI 0
  set bestN 0
  set i 0
  set listLen [llength $list]
  while {$i < $listLen} {
    set n [seqLen $list $i $cmpCmd]
    if {($firstOrLast == 0 && $n > $bestN) || ($firstOrLast == 1 && $n >= $bestN)} {
      set bestI $i
      set bestN $n
    }
    incr i $n
  }
  return [list $bestI $bestN]
}

proc numCmp {a b} {
  return [expr {$a < $b ? -1 : ($a == $b ? 0 : 1)}]
}

proc seqLen {list index cmpCmd} {
  set i $index
  set listLen [llength $list]
  while {$i < $listLen && [{*}$cmpCmd [lindex $list $i] [lindex $list $index]] == 0} {
    incr i
  }
  return [expr {$i - $index}]
}

# ================ Project Euler Problem 54 ================

array set suitStrings {C 0 D 1 H 2 S 3}
array set valueStrings {T 8 J 9 Q 10 K 11 A 12}

proc str2Card {str} {
  lassign [split $str ""] valueStr suitStr
  return [card new [str2Suit $suitStr] [str2Value $valueStr]]
}

proc str2Hands {str} {
  set cards [lmap cardStr [split $str] {str2Card $cardStr}]
  set hands {}
  set i 0
  set cardsLen [llength $cards]
  while {$i < $cardsLen} {
    lappend hands [hand new [lrange $cards $i [expr {$i + 5 - 1}]]]
    incr i 5
  }
  return $hands
}

proc str2Suit {str} {
  global suitStrings
  return [suit new $suitStrings($str)]
}

proc str2Value {str} {
  global valueStrings
  if {[info exists valueStrings($str)]} {
    set n $valueStrings($str)
  } else {
    set n [expr {$str - 2}]
  }
  return [value new $n]
}

set count 0
while {[gets stdin line] >= 0} {
  lassign [str2Hands $line] hand1 hand2
  if {[$hand1 cmp $hand2] > 0} {
    incr count
  }
  $hand1 destroy
  $hand2 destroy
}
puts $count