Tipp 0509 Poker-Engine
Autor/Einsender:
Datum:
  Dinko Hasanbasic
17.08.2006
Entwicklungsumgebung:   VB 6
Wer kennt es nicht, man möchte ein schönes Spiel programmieren, doch wie sollen nun die Regeln entsprechend richtig umgesetzt werden. So sitzt man dann unter Umständen stundenlang an einem Problem, dessen Lösung eigentlich nur 5 Minuten braucht. Hier setzt dieser Tipp an, der alle gängigen Poker-Regeln in einem separaten Modul enthält. Auch eine "Zeichne 5 Karten"-Funktion ist enthalten.
Um den Überprüfungsvorgang zu optimieren und den Code kurz zu halten werden die Karten vor dem eigentlichen Prüfvorgang geordnet. So lassen sich die Karten recht einfach der Reihe nach überprüfen.
Code im Codebereich des Moduls
 
Option Explicit

Private Declare Function cdtInit Lib "cards.dll" (ByRef _
      CardWidth As Long, ByRef CardHeight As Long) As Long

Public Declare Function cdtDraw Lib "cards.dll" (ByVal hDC _
      As Long, ByVal xOrg As Long, ByVal yOrg As Long, _
      ByVal nCard As Long, ByVal nDraw As Long, ByVal _
      nColor As OLE_COLOR) As Long

Private Declare Function cdtTerm Lib "cards.dll" () As Long

Public Const LB_KARTEN As Byte = 1
Public Const UB_KARTEN As Byte = 5

Public tmpK(LB_KARTEN To UB_KARTEN) As Karte

Public Enum enFarbe
  fbKreuz
  fbKaro
  fbHerz
  fbPik
End Enum

Public Enum enPokerblatt
  pbRoyal_Flush
  pbStraight_Flush
  pbVier_gleiche
  pbFull_House
  pbFlush
  pbStraight
  pbDrei_gleiche
  pbZwei_Paare
  pbPaar
  pbFehler
End Enum

Public Type Karte
  Wert As Byte
  Farbe As enFarbe
  ID As Byte
End Type

Public CardW As Long
Public CardH As Long

Public Sub Init()
  cdtInit CardW, CardH
End Sub

Public Sub DeInit()
  cdtTerm
End Sub

Public Sub Ordnen(K() As Karte)
  Dim I As Byte
  Dim Min As Byte, tmp As Karte
  Dim L As Byte

  L = LB_KARTEN

  Do While L < UB_KARTEN
    Min = L
    For I = (L + 1) To UB_KARTEN
      If K(I).Wert < K(Min).Wert Then Min = I
    Next I

    tmp = K(L)
    K(L) = K(Min)
    K(Min) = tmp

    L = L + 1
  Loop
End Sub

Private Function FindeGleiche(K() As Karte, _
      Optional ByVal Wieviel As Byte = 2, _
      Optional Ignore As Byte = 0) As Boolean

  Dim Akt As Byte
  Dim N As Byte
  Dim bn As Boolean

  Akt = 1
  N = 1

  Do While Akt <= (UB_KARTEN - 1)
    bn = CBool(K(Akt).Wert = K(Akt + 1).Wert) And _
          CBool(K(Akt).Wert <> Ignore)

    If bn Then
      N = N + 1
      If N = Wieviel Then
        Ignore = K(Akt).Wert
        FindeGleiche = True
        Exit Function
      End If
    Else
      N = 1
    End If
    Akt = Akt + 1
  Loop

  If N < Wieviel Then FindeGleiche = False
End Function

Public Function Karte_Position(K As Karte) As Byte
  Select Case K.Wert
    Case 15
      Karte_Position = K.Farbe
    Case Is > 10
      Karte_Position = 4 * (K.Wert - 2) + K.Farbe
    Case Else
      Karte_Position = 4 * (K.Wert - 1) + K.Farbe
  End Select
End Function

Public Function Karte_Bewerten(ByVal ID As Byte) As Karte
  Dim tmp As Byte

  With Karte_Bewerten
    Select Case ID
      Case 0 To 3
        .Wert = 15
        .Farbe = ID
      Case 4 To 39
        tmp = ID Mod 4
        .Farbe = tmp
        .Wert = ((ID - tmp) / 4) + 1
      Case 40 To 51
        tmp = ID Mod 4
        .Farbe = tmp
        .Wert = ((ID - tmp) / 4) + 2
    End Select
    Karte_Bewerten.ID = ID
  End With
End Function

Public Sub Karte_Tauschen(K() As Karte, nKarte As Byte, _
        Neu As Karte)
  K(nKarte) = Neu
End Sub

Public Sub Karten_Zeichnen(xPos As Long, yPos As Long, _
      Abstand As Integer, Karten() As Karte, hDC As Long)

  Dim Akt As Byte

  For Akt = 0 To (UB_KARTEN - 1)
    cdtDraw hDC, (xPos + Akt * Abstand + Akt * CardW), yPos, _
      Karte_Position(Karten(Akt + 1)), 0, vbWhite
  Next Akt
End Sub

Public Function Hat_Paar(K() As Karte) As Boolean
  Hat_Paar = FindeGleiche(K(), 2)
End Function

Public Function Hat_2Paare(K() As Karte) As Boolean
  Dim Ign As Byte

  Ign = 0
  Hat_2Paare = FindeGleiche(K(), 2, Ign)
  Hat_2Paare = FindeGleiche(K(), 2, Ign)
End Function

Public Function Hat_3gleiche(K() As Karte) As Boolean
  Hat_3gleiche = FindeGleiche(K(), 3)
End Function

Public Function Hat_Straight(K() As Karte) As Boolean
  Dim Akt As Byte

  For Akt = LB_KARTEN To (UB_KARTEN - 1)
    If K(Akt).Wert = 10 Then
      Hat_Straight = CBool(K(Akt).Wert = K(Akt + 1).Wert - 2)
    Else
      Hat_Straight = CBool(K(Akt).Wert = K(Akt + 1).Wert - 1)
    End If
    If Not Hat_Straight Then Exit Function
  Next Akt
End Function

Public Function Hat_Flush(K() As Karte) As Boolean
  Dim Akt As Byte

  For Akt = LB_KARTEN To (UB_KARTEN - 1)
    Hat_Flush = CBool(K(Akt).Farbe = K(Akt + 1).Farbe)
    If Not Hat_Flush Then Exit Function
  Next Akt
End Function

Public Function Hat_FullHouse(K() As Karte) As Boolean
  Dim Ign As Byte

  Ign = 0
  Hat_FullHouse = False

  If FindeGleiche(K(), 3, Ign) Then
    Hat_FullHouse = FindeGleiche(K(), 2, Ign)
  End If
End Function

Public Function Hat_4gleiche(K() As Karte) As Boolean
  Hat_4gleiche = FindeGleiche(K(), 4)
End Function

Public Function Hat_StraightFlush(K() As Karte) As Boolean
  Hat_StraightFlush = Hat_Straight(K()) And Hat_Flush(K())
End Function

Public Function Hat_RoyalFlush(K() As Karte) As Boolean
  Hat_RoyalFlush = Hat_StraightFlush(K()) And _
    CBool(K(UB_KARTEN).Wert = 15) '15 = Ass
End Function

Public Function Karten_Pruefen(K() As Karte) As enPokerblatt
  If Hat_RoyalFlush(K()) Then
    Karten_Pruefen = pbRoyal_Flush

  ElseIf Hat_StraightFlush(K()) Then
    Karten_Pruefen = pbStraight_Flush

  ElseIf Hat_4gleiche(K()) Then
    Karten_Pruefen = pbVier_gleiche

  ElseIf Hat_FullHouse(K()) Then
    Karten_Pruefen = pbFull_House

  ElseIf Hat_Flush(K()) Then
    Karten_Pruefen = pbFlush

  ElseIf Hat_Straight(K()) Then
    Karten_Pruefen = pbStraight

  ElseIf Hat_3gleiche(K()) Then
    Karten_Pruefen = pbDrei_gleiche

  ElseIf Hat_2Paare(K()) Then
    Karten_Pruefen = pbZwei_Paare

  ElseIf Hat_Paar(K()) Then
    Karten_Pruefen = pbPaar

  Else
    Karten_Pruefen = pbFehler
  End If
End Function
 
Hinweis
Um diesen Tipp ausführen zu können, muss sich die Datei Cards.dll im WINDOWS\SYSTEM-Verzeichnis befinden. Sollten wider Erwarten Probleme auftauchen schauen Sie sich dazu bitte die Hinweise zu dem Tipp Cards.dll für Kartenspiele nutzen an.
Weitere Links zum Thema
Cards.dll für Kartenspiele nutzen
Tutorial - Kartenspiele Teil 1
Tutorial - Kartenspiele Teil 2

Windows-Version
95
98
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (8,9 kB) Downloads bisher: [ 620 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 3. Juli 2011