[BB/B3D/BP?] BlackJack
Übersicht
BlitzBasic Codearchiv
|
StepTigerBetreff: [BB/B3D/BP?] BlackJack |
 Mi, Dez 27, 2006 21:58Antworten mit Zitat 
|
|---|---|---|
|
Ich hab neulich was bei Galileo über Card-Counting beim BlackJack gesehen.
Da dachte ich mir, schreib ich mir doch auch mal ein BlackJack Programm. Kurze Einweisung: Space - Nächster Zug 1 - Spieler 1 macht zu 2 - Spieler 2 macht zu Wer von euch gern mit Single-Level System mitzählt, der soll bestenfalls die Konstante oben verändern. Code: [AUSKLAPPEN] ;-----------------------------------------------;
; BlackJack - Made by StepTiger ; ;-----------------------------------------------; Graphics 800,600,32,2 SetBuffer BackBuffer() SeedRnd MilliSecs() ;-----------------------------------------------; ;Versteckte Variable die niemand sehen darf! ; ;HEY! WEGSCHAUN! ; ;NA? WILLST DU MIR NICHT ZUHÖREN ODER WAS? ; ;SCHAU WEG! DAS IST UNFAIR! ; ;WEG! ; ;-----------------------------------------------; Const CountIt=1 ;-----------------------------------------------; ;NICHT NACH OBEN SCHAUN! ; ;WEGSCHAUN! ; ;WEG! ; ;AUCH NICHT HIER HOCH! ; ;-----------------------------------------------; Type Karte Field name$ Field wert$ Field weg[3] End Type CreateCards() Global p1_wert=0,p2_wert=0 Global p1_cards$,p2_cards$ Global p1_take=1,p2_take=1 Global p1_punkte=0,p2_punkte=0 Global count=0 While Not KeyHit(1) Cls SortCards() If KeyHit(57) GiveCards() EndIf SortCards() If KeyHit(2) And p1_take=1 p1_take=0 Text GraphicsWidth()/2,GraphicsHeight()/3,"Spieler 1 macht zu.",1,1 FlushKeys WaitKey EndIf If KeyHit(3) And p2_take=1 p2_take=0 Text GraphicsWidth()/2,GraphicsHeight()/3,"Spieler 2 macht zu.",1,1 FlushKeys WaitKey EndIf If CountIt=1 Text GraphicsWidth()/2,GraphicsHeight()-15,"Der aktuelle Count ist: "+count,1 EndIf p1ding$="Player 1 "+p1_wert p2ding$=p2_wert+" Player 2" Text 0,0,p1ding$ Text GraphicsWidth()-StringWidth(p2ding$),0,p2ding$ Text 0,13,"Punkte "+p1_punkte Text GraphicsWidth()-StringWidth(p2_punkte+" Punkte"),13,p2_punkte+" Punkte" Text GraphicsWidth()/2,0,"Noch "+CountCards(True)+" Karten im Deck",1 Text GraphicsWidth()/2,13,"Davon "+CountCards()+" verschiedene",1 Text 0,GraphicsHeight()/2,p1_cards$ Text GraphicsWidth()-StringWidth(p2_cards$),GraphicsHeight()/2,p2_cards$ If (p1_wert=21 And p2_wert<>21) Or (p2_wert>21 And p1_wert<=21) Or (p1_take=0 And p2_take=0 And p1_wert>p2_wert) Text GraphicsWidth()/2,GraphicsHeight()/2,"Spieler 1 gewinnt!",1 p1_punkte=p1_punkte+1 p1_wert=0 p2_wert=0 p1_cards$="" p2_cards$="" p1_take=1 p2_take=1 Flip Cls FlushKeys WaitKey ElseIf (p2_wert=21 And p1_wert<>21) Or (p1_wert>21 And p2_wert<=21) Or (p1_take=0 And p2_take=0 And p1_wert<p2_wert) Text GraphicsWidth()/2,GraphicsHeight()/2,"Spieler 2 gewinnt!",1 p2_punkte=p2_punkte+1 p1_wert=0 p2_wert=0 p1_cards$="" p2_cards$="" p1_take=1 p2_take=1 Flip Cls FlushKeys WaitKey ElseIf p1_wert>21 Or p2_wert>21 Or (p1_wert=p2_wert And p1_take=0 And p2_take=0) Text GraphicsWidth()/2,GraphicsHeight()/2,"Unentschieden!",1 p1_wert=0 p2_wert=0 p1_cards$="" p2_cards$="" p1_take=1 p2_take=1 Flip Cls FlushKeys WaitKey EndIf If CountCards(True)<p1_take+p2_take DeleteCards() CreateCards() count=0 EndIf Flip Wend End Function GiveCards() If p1_take=1 p1=1 farbe=4 While farbe=4 While karte.karte=Null karte.karte=RandomCard.karte() p1=p1+1 If p1>40 Then RuntimeError "Fehler im Modul "+Chr(34)+"GiveCards()"+Chr(34)+" bei Spieler 1"+Chr(13)+Chr(10)+"Konnte nach 40 Versuchen keine Karte finden!" Wend farbe=DeleteFarbe(karte) Wend If Int(karte\wert)>9 count=count-1 ElseIf Int(karte\wert)<7 count=count+1 EndIf p1_cards$=p1_cards$+FarbString$(farbe)+" "+karte\name$+", " p1_wert=Int(p1_wert)+Int(karte\wert) karte=Null EndIf If p2_take=1 p2=1 farbe=4 While farbe=4 While karte.karte=Null karte.karte=RandomCard.karte() p2=p2+1 If p2>40 Then RuntimeError "Fehler im Modul "+Chr(34)+"GiveCards()"+Chr(34)+" bei Spieler 2"+Chr(13)+Chr(10)+"Konnte nach 40 Versuchen keine Karte finden!" Wend farbe=DeleteFarbe(karte) Wend If Int(karte\wert)>9 count=count-1 ElseIf Int(karte\wert)<7 count=count+1 EndIf p2_cards$=p2_cards$+FarbString$(farbe)+" "+karte\name$+", " p2_wert=Int(p2_wert)+Int(karte\wert) karte=Null EndIf End Function Function FarbString$(farbe) Select farbe Case 0 r$="Herz" Case 1 r$="Karo" Case 2 r$="Pik" Case 3 r$="Kreuz" End Select Return r$ End Function Function DeleteFarbe(d.karte) Local didit[3] did=0 maxuses=400 uses=0 While did=0 uses=uses+1 If uses>maxuses Then RuntimeError "Fehler im Modul "+Chr(34)+"DeleteFarbe()"+Chr(34)+Chr(13)+Chr(10)+"Konnte nach "+maxuses+" Versuchen keine Farbe löschen!" n=Rand(0,3) didit[n]=1 check=0 For x=0 To 3 If didit[x]=1 Then check=check+1 Next If check=4 Then Return 4 If d\weg[n]=0 did=1 d\weg[n]=1 EndIf Wend Return n End Function Function RandomCard.karte() While check=0 r=Rnd(CountCards()) d.karte=SelectCard(r) If d<>Null For x=0 To 3 If d\weg[x]=0 Then check=check+1 Next EndIf Wend Return d End Function Function SelectCard.Karte(num) num2=0 r.karte=First karte While num2<num r.karte=After r num2=num2+1 If num2>CountCards() Then RuntimeError "Fehler im SelectCard Modul"+Chr(13)+Chr(10)+"gesucht: "+num+" gefunden:"+num2 Wend Return r End Function Function SortCards() For r.karte=Each karte c=0 For x=0 To 3 If r\weg[x]=0 Then c=c+1 Next If c=0 Then Delete r Next End Function Function CountCards(all=0) c=0 For r.karte=Each karte If all=1 For x=0 To 3 If r\weg[x]=0 Then c=c+1 Next Else c=c+1 EndIf Next Return c End Function Function DeleteCards() For r.karte=Each karte Delete r Next End Function Function CreateCards() For x=2 To 10 r.karte=New karte r\name$=x r\wert=x Next For x=0 To 2 Select x Case 0 name$="Bube" Case 1 name$="Dame" Case 2 name$="König" End Select r.karte=New karte r\wert=10 r\name$=name$ Next r.karte=New karte r\name$="Ass" r\wert=11 End Function |
||
|
Noch gestern standen wir am Abgrund, doch heute sind wir schon einen Schritt weiter.
Computer: AMD Sempron 3000+; ATI Radeon 9800 Pro; 512 MB DDR RAM 400Mhz; Asus E7N8X-E Deluxe; Samsung 200GB HD 5.4ns acces t Gewinner: BP Code Compo #2 Π=3.141592653589793238...<--- und das aus dem kopf 
Seit der Earthlings-Diskussion überzeugter Fleisch(fr)esser. |
||
snörkl |
Do, Dez 28, 2006 14:15 Antworten mit Zitat
|
|
|---|---|---|
| ist ganz nett aber ohne grafik irgendwie langweilig^^ | ||
|
|
StepTiger |
Do, Dez 28, 2006 23:14 Antworten mit Zitat
|
|---|---|---|
|
OpenSource... xD
Grafiken habe ich leider keine gesucht... Hat der Biber nicht mal an sowas gearbeitet? 
|
||
|
Noch gestern standen wir am Abgrund, doch heute sind wir schon einen Schritt weiter.
Computer: AMD Sempron 3000+; ATI Radeon 9800 Pro; 512 MB DDR RAM 400Mhz; Asus E7N8X-E Deluxe; Samsung 200GB HD 5.4ns acces t Gewinner: BP Code Compo #2 Π=3.141592653589793238...<--- und das aus dem kopf
Seit der Earthlings-Diskussion überzeugter Fleisch(fr)esser. |
||
Übersicht
BlitzBasic Codearchiv
Powered by phpBB © 2001 - 2006, phpBB Group