parsecards.tcl

# parsecards.tcl version 1.1
# coded by arfer <arfer.minute@gmail.com>
# on dalnet #windrop #eggdrops #tcl #eggdrop.conf #tclscript

# this is not a functional script in its own right, rather it is called/utilised by ...
# ... other scripts as a card parsing engine to derive the best 5 card poker hand ...
# ... from a space delimited string of input cards (maximum 9)
# this code will also return the plain english poker term for the best hand found ...
# ... plus the result of an enumerated ranking system to enable easy comparison ...
# ... between similar hands in a multiuser game

# see parsecards.txt for a more detailed explanation

# ***** ENSURE this script is loaded BEFORE any other script that makes use of it *****

# this script does not require any configuration

# ++++++++++ CHANGELOG ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #

# version 1.0 tested july 2005 with windrop 1.6.17 handlen32 on dalnet using ...
# ... pokerdemo.tcl and pokerslot.tcl with mIRC v6.16 client

# version 1.1 got rid of the unnecessary namespace export statement

# ++++++++++ WARRANTY +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #

# this code comes with absolutely no warranty

# this program is free software; you can redistribute it and/or modify it under the ...
# ... terms of the gnu (general public license) as published by the free software ...
# ... foundation; either version 2 of the license, or (at your option) any later version

# this program is distributed in the hope that it will be useful, but without any ...
# ... warranty; without even the implied warranty of merchantability or fitness for a ...
# ... particular purpose

# see the gnu for more details (http://www.gnu.org/copyleft/gpl.html)

# ++++++++++ CODE +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #

# do not edit below this line

set prcards_vVersion "1.1"

namespace eval nParseCards {

  proc pParseCards {vA} {
    variable cCardSuits
    variable cCardValues
    set cCardSuits [pGenerateCardSuits]
    set cCardValues [pGenerateCardValues]
    set vK(1)  pRoyalFlush
    set vK(2)  pStraightFlushAceHigh
    set vK(3)  pStraightFlushAceLow
    set vK(4)  pFourOfAKind
    set vK(5)  pFullHouse
    set vK(6)  pFlush
    set vK(7)  pStraightAceHigh
    set vK(8)  pStraightAceLow
    set vK(9)  pThreeOfAKind
    set vK(10) pTwoPair
    set vK(11) pOnePair
    set vK(12) pHighCard
    for {set vX 1} {$vX <= [array size vK]} {incr vX} {
      set vL [eval {$vK($vX) $vA}]
      if {$vL != 0} {break}
    }
    set vM [string range $vL 0 13]
    set vN [pSpeakEnglish $vL]
    set vO [pEnumerateRanks $vL]
    return "$vM\|$vN\|$vO"
  }

  proc pGenerateCardSuits {} {
    set vK "AKQJT98765432"
    set vL "hcds"
    set vM 0
    for {set vX 0} {$vX < 4} {incr vX} {
      for {set vY 0} {$vY < 13} {incr vY} {
        set vN "[string index $vK $vY][string index $vL $vX]"
        if {$vM == 0} {set vM $vN} else {set vM "$vM $vN"}
      }
    }
    return $vM
  }

  proc pGenerateCardValues {} {
    set vK "AKQJT98765432"
    set vL "hcds"
    set vM 0
    for {set vX 0} {$vX < 13} {incr vX} {
      for {set vY 0} {$vY < 4} {incr vY} {
        set vN "[string index $vK $vX][string index $vL $vY]"
        if {$vM == 0} {set vM $vN} else {set vM "$vM $vN"}
      }
    }
    return $vM
  }

  proc pRoyalFlush {vA} {
    set vK [pSortBySuit $vA]
    set vL 0
    for {set vX 0} {$vX < 4} {incr vX} {
      set vM [string index "hcds" $vX]
      set vN [lsearch -all -inline [split $vK] "?$vM"]
      if {[llength $vN] >= 5} {
        set vO [join [lrange $vN 0 4]]
        if {[string match "A? K? Q? J? T?" $vO]} {
          set vL "$vO 1"
          break
        }
      }
    }
    return $vL
  }

  proc pStraightFlushAceHigh {vA} {
    set vK [pSortBySuit $vA]
    set vL 0
    for {set vX 0} {$vX < 4} {incr vX} {
      set vM [string index "hcds" $vX]
      set vN [lsearch -all -inline [split $vK] "?$vM"]
      if {[llength $vN] >= 5} {
        set vO [regsub -all "\ |\h|\c|\d|\s" [join $vN] ""]
        if {[regexp {^KQJT9|QJT98|JT987|T9876|98765|87654|76543|65432$} $vO vP]} {
          set vL "[string index $vP 0]$vM [string index $vP 1]$vM [string index $vP 2]$vM [string index $vP 3]$vM [string index $vP 4]$vM 2"
          break
        }
      }
    }
    return $vL
  }

  proc pStraightFlushAceLow {vA} {
    set vK [pSortBySuit $vA]
    set vL 0
    for {set vX 0} {$vX < 4} {incr vX} {
      set vM [string index "hcds" $vX]
      set vN [lsearch -all -inline [split $vK] "?$vM"]
      if {[llength $vN] >= 5} {
        set vO [join [lrange $vN 0 end]]
        if {[string match "*5? 4? 3? 2?*" $vO] && [string match "*A*" $vO]} {
          set vL "5$vM 4$vM 3$vM 2$vM A$vM 2"
          break
        }
      }
    }
    return $vL
  }

  proc pFourOfAKind {vA} {
    set vK [pSortByValue $vA]
    set vL 0
    for {set vX 0} {$vX < 13} {incr vX} {
      set vM [string index "AKQJT98765432" $vX]
      if {[string match "*$vM? $vM? $vM? $vM?*" $vK]} {
        set vL "[join [lsearch -all -inline [split $vK] "$vM?"]] [join [lindex [lsearch -all -inline -not [split $vK] "$vM?"] 0]] 3"
        break
      }
    }
    return $vL
  }

  proc pFullHouse {vA} {
    set vK [pSortByValue $vA]
    set vL 0
    set vM 0
    for {set vX 0} {$vX < 13} {incr vX} {
      set vN [string index "AKQJT98765432" $vX]
      if {[string match "*$vN? $vN? $vN?*" $vK]} {
        set vM [lsearch -all -inline [split $vK] "$vN?"]
        set vO [lsearch -all -inline -not [split $vK] "$vN?"]
        break
      }
    }
    if {$vM != 0} {
      for {set vY 0} {$vY < 13} {incr vY} {
        set vP [string index "AKQJT98765432" $vY]
        if {[string match "*$vP? $vP?*" [join $vO]]} {
          set vQ [lrange [lsearch -all -inline $vO "$vP?"] 0 1]
          set vL "[join $vM] [join $vQ] 4"
          break
        }
      }
    }
    return $vL
  }

  proc pFlush {vA} {
    set vK [pSortBySuit $vA]
    set vL 0
    for {set vX 0} {$vX < 4} {incr vX} {
      set vM [string index "hcds" $vX]
      if {[string match "*?$vM ?$vM ?$vM ?$vM ?$vM*" $vK]} {
        set vL "[join [lrange [lsearch -all -inline [split $vK] "?$vM"] 0 4]] 5"
        break
      }
    }
    return $vL
  }

  proc pStraightAceHigh {vA} {
    set vK [pSortByValue $vA]
    set vL 0
    set vM "AKQJT98765432"
    for {set vX 0} {$vX <= 8} {incr vX} {
      set vN(1) [string index $vM $vX]
      set vN(2) [string index $vM [expr {$vX + 1}]]
      set vN(3) [string index $vM [expr {$vX + 2}]]
      set vN(4) [string index $vM [expr {$vX + 3}]]
      set vN(5) [string index $vM [expr {$vX + 4}]]
      if {[string match "*$vN(1)*$vN(2)*$vN(3)*$vN(4)*$vN(5)?*" $vK]} {
        set vO(1) [string range $vK [string first $vN(1) $vK] [expr {[string first $vN(1) $vK] + 1}]]
        set vO(2) [string range $vK [string first $vN(2) $vK] [expr {[string first $vN(2) $vK] + 1}]]
        set vO(3) [string range $vK [string first $vN(3) $vK] [expr {[string first $vN(3) $vK] + 1}]]
        set vO(4) [string range $vK [string first $vN(4) $vK] [expr {[string first $vN(4) $vK] + 1}]]
        set vO(5) [string range $vK [string first $vN(5) $vK] [expr {[string first $vN(5) $vK] + 1}]]
        set vL "$vO(1) $vO(2) $vO(3) $vO(4) $vO(5) 6"
        break
      }
    }
    return $vL
  }

  proc pStraightAceLow {vA} {
    set vK [pSortByValue $vA]
    set vL 0
      if {[string match "*A*5*4*3*2*" $vK]} {
        set vM(1) [string range $vK [string first "A" $vK] [expr {[string first "A" $vK] + 1}]]
        set vM(2) [string range $vK [string first "5" $vK] [expr {[string first "5" $vK] + 1}]]
        set vM(3) [string range $vK [string first "4" $vK] [expr {[string first "4" $vK] + 1}]]
        set vM(4) [string range $vK [string first "3" $vK] [expr {[string first "3" $vK] + 1}]]
        set vM(5) [string range $vK [string first "2" $vK] [expr {[string first "2" $vK] + 1}]]
        set vL "$vM(2) $vM(3) $vM(4) $vM(5) $vM(1) 6"
      }
    return $vL
  }

  proc pThreeOfAKind {vA} {
    set vK [pSortByValue $vA]
    set vL 0
    for {set vX 0} {$vX < 13} {incr vX} {
      set vM [string index "AKQJT98765432" $vX]
      if {[string match "*$vM? $vM? $vM?*" $vK]} {
        set vL "[join [lsearch -all -inline [split $vK] "$vM?"]] [join [lrange [lsearch -all -inline -not [split $vK] "$vM?"] 0 1]] 7"
        break
      }
    }
    return $vL
  }

  proc pTwoPair {vA} {
    set vK [pSortByValue $vA]
    set vL 0
    set vM 0
    for {set vX 0} {$vX < 13} {incr vX} {
      set vN [string index "AKQJT98765432" $vX]
      if {[string match "*$vN? $vN?*" $vK]} {
        set vM [lsearch -all -inline [split $vK] "$vN?"]
        set vO [lsearch -all -inline -not [split $vK] "$vN?"]
        break
      }
    }
    if {$vM != 0} {
      for {set vY 0} {$vY < 13} {incr vY} {
        set vP [string index "AKQJT98765432" $vY]
        if {[string match "*$vP? $vP?*" [join $vO]]} {
          set vQ [lsearch -all -inline $vO "$vP?"]
          set vR [lsearch -all -inline -not $vO "$vP?"]
          set vL "[join $vM] [join $vQ] [join [lindex $vR 0]] 8"
          break
        }
      }
    }
    return $vL
  }

  proc pOnePair {vA} {
    set vK [pSortByValue $vA]
    set vL 0
    for {set vX 0} {$vX < 13} {incr vX} {
      set vM [string index "AKQJT98765432" $vX]
      if {[string match "*$vM? $vM?*" $vK]} {
        set vL "[join [lsearch -all -inline [split $vK] "$vM?"]] [join [lrange [lsearch -all -inline -not [split $vK] "$vM?"] 0 2]] 9"
        break
      }
    }
    return $vL
  }

  proc pHighCard {vA} {
    set vK [pSortByValue $vA]
    set vL "[join [lrange [split $vK] 0 4]] 10"
    return $vL
  }

  proc pEnumerateRanks {vA} {
    set vK [lrange [split $vA] 0 4]
    set vL [join [lrange [split $vA] 5 end]]
    for {set vX 0} {$vX < 5} {incr vX} {
      for {set vY 0} {$vY < 13} {incr vY} {
        set vM [string index "AKQJT98765432" $vY]
        if {[string match "*$vM*" [join [lindex $vK $vX]]]} {
          set vL "$vL [expr {$vY + 1}]"
          break
        }
      }
    }
    return $vL
  }

  proc pSpeakEnglish {vA} {
    set vK [join [lindex [split $vA] 5]]
    for {set vX 1} {$vX <= 5} {incr vX} {
      set vL($vX) [string index [join [lindex [split $vA] [expr {$vX - 1}]]] 0]
      set vM($vX) [string index [join [lindex [split $vA] [expr {$vX - 1}]]] 1]
    }
    for {set vY 1} {$vY <= 5} {incr vY} {
      set vN($vY) [string map {A Ace K King Q Queen J Jack T Ten 9 Nine 8 Eight 7 Seven 6 Six 5 Five 4 Four 3 Three 2 Two} $vL($vY)]
      set vO($vY) [string map {A Aces K Kings Q Queens J Jacks T Tens 9 Nines 8 Eights 7 Sevens 6 Sixes 5 Fives 4 Fours 3 Threes 2 Twos} $vL($vY)]
      set vP($vY) [string map {h Hearts c Clubs d Diamonds s Spades} $vM($vY)]
    }
    switch $vK {
      1 {set vQ "Royal Flush In $vP(1)"}
      2 {set vQ "Straight Flush, $vN(1) High In $vP(1)"}
      3 {set vQ "Four $vO(1)"}
      4 {set vQ "Full House, $vO(1) Full Of $vO(4)"}
      5 {set vQ "Flush, $vN(1) High In $vP(1)"}
      6 {set vQ "Straight, $vN(1) High"}
      7 {set vQ "Three $vO(1)"}
      8 {set vQ "Two Pairs, $vO(1) And $vO(3)"}
      9 {set vQ "Pair Of $vO(1)"}
      10 {set vQ "$vN(1) High, $vN(2) Kicker"}
    }
    return $vQ
  }

  proc pSortBySuit {vA} {
    variable cCardSuits
    set vK 0
    set vL [split $cCardSuits]
    for {set vX 0} {$vX < 52} {incr vX} {
      set vM [join [lindex $vL $vX]]
      if {[string match "*$vM*" $vA]} {
        if {$vK == 0} {set vK [join [lindex $vL $vX]]} else {set vK "$vK [join [lindex $vL $vX]]"}
      }
    }
    return $vK
  }

  proc pSortByValue {vA} {
    variable cCardValues
    set vK 0
    set vL [split $cCardValues]
    for {set vX 0} {$vX < 52} {incr vX} {
      set vM [join [lindex $vL $vX]]
      if {[string match "*$vM*" $vA]} {
        if {$vK == 0} {set vK [join [lindex $vL $vX]]} else {set vK "$vK [join [lindex $vL $vX]]"}
      }
    }
    return $vK
  }

}

putlog "parsecards.tcl version $prcards_vVersion by arfer loaded"