Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
YAKK Yet Another Kniffel Klon -->bitte mal beta testen
| Uploader: |  Muttonhead |
| Datum/Zeit: | 31.08.2008 13:42:43 |
'Beta Tester für YAKK gesucht !!!!
'mal ein wenig mitrechnen, ob die Auswertung funzt
'Ich kanns erstmal nicht mehr sehen.... ;)
'tatsächlich mein erstes (so hoffe ich) abgeschlossene Projekt
'in FreeBasic
'
#Include once "fbgfx.bi"
'*******************************************************************************************************
'declare functions and subs
'game
declare sub InitPlayer
declare sub InitGame
declare sub InitNewTrial
declare function RollADie (pipnum as integer) as integer
declare sub RollDice
declare sub PreEvaluation
declare sub PostEvaluation
declare sub stats
'gfx
declare sub PreShowScore
declare sub PostShowScore
declare sub ShowDice
declare sub DieGFX (x as integer,y as integer,pipnum as integer)
declare sub Button (gx as integer,gy as integer,gw as integer,gh as integer,_
gtxt as string,mode as integer)
'*******************************************************************************************************
'dim variables
'Screen,Colors
dim shared as integer ScreenWidth,ScreenHeight,ScreenDepth
dim shared as uinteger fgcolor,bgcolor,black,white,lgray,gray,dgray,lblue,blue,dblue,green,red,yellow
ScreenWidth=640
ScreenHeight=480
ScreenDepth=16
black =&H0
white =&Hffffff
lgray =&HF0F0F0
gray =&HDCDCDC
dgray =&h808080
lblue =&HDCF0FF
blue =&HB4D2FA
dblue =&H000080
green =&H00A000
red =&HFF00000
yellow=&HFFDD00
fgcolor=black
bgcolor=gray
'counting
dim as integer i,k,l
'gfx positions
const as integer plx1=130,plx2=230,plx3=330,pl4x=430,ply=240
const as integer buttonx=220,buttony=445,buttonw=200,buttonh=25
const as integer dx1=180,dx2=dx1+55,dx3=dx2+55,dx4=dx3+55,dx5=dx4+55,dy=390
const as integer scbx=180,scby=25,scbw=90,scbh=20
'ingame vars
dim shared as integer mode,maxplayer,player,maxround,round,board(4,17),scbpos
'mode 1 SpielerAnzahl
'mode 2 1.Wurf
'mode 3 Auswahl,2.Wurf, ins ScoreBoard
'mode 4 Auswahl,3.Wurf, ins ScoreBoard
'mode 5 Wert im ScoreBoard Wählen
dim shared as integer dice(5,1),dstats(6),dienum,rollable
'dice()
'(x,0) enthält Augenzahl jedes der 5 Würfel 1-5 (0 unbenutzt)
'(x,1) Flag ob mit diesem Würfel nochmal gewürfelt werden soll
' 0=halten
' 1=nochmal in den Knobelbecher
'rollable 0 = WürfelBecher leer
'event handle
DIM AS FB.EVENT PTR event
event = ALLOCATE(20)
dim as integer mousex,mousey
'*******************************************************************************************************
'OpenScreen
windowtitle "YAKK - Yet Another Kniffel Klon Version 0.001(beta) (2008) muttonhead@hotmail.de"
screenres ScreenWidth,ScreenHeight,ScreenDepth,,&H04
width ScreenWidth/8,ScreenHeight/16 '<----- wiedermal nen Gruss an Volta fürs Font Tutorial
color fgcolor,bgcolor
cls
'*******************************************************************************************************
'main loop
InitPlayer
DO
IF (SCREENEVENT(event)) Then
SELECT CASE event->type
CASE FB.EVENT_MOUSE_MOVE
mousex=event-> x
mousey=event-> y
CASE FB.EVENT_MOUSE_Button_RELEASE and event->Button = FB.Button_LEFT
select case mode
case 6
if mousex>=buttonx and mousex<buttonx+buttonw and mousey>=buttony and mousey<buttony+buttonh then InitPlayer
case 5
scbpos=0
if mousex>=scbx and mousex<scbx+4*scbw and mousey>=scby and mousey<scby+6*scbh then
scbpos=int((mousey-scby)/scbh+1)
end if
if mousex>=scbx and mousex<scbx+4*scbw and mousey>=scby+9*scbh and mousey<scby+16*scbh then
scbpos=int((mousey-scby)/scbh)
end if
if scbpos>0 and board(player,scbpos)=-1 then
board(player,scbpos)=board(0,scbpos)
PostEvaluation
PostShowScore
if player=maxplayer and round=maxround then
beep
line (0,scby+8*scbh)-(ScreenWidth,scby+9*scbh),green,bf
draw string (scbx-85,scby+8*scbh+2),"Wer auch immer gewonnen hat, Herzlichen Glueckwunsch!!!",yellow
Button buttonx,buttony,buttonw,buttonh,"Neues Spiel ???" ,6
mode=6
else
player+=1
if player<=maxplayer then
InitNewTrial
mode=2
end if
if player>maxplayer then
player=1
round+=1
InitNewTrial
mode=2
end if
end if
end if
case 3,4
dienum=-1
if mousex>=dx1 and mousex<dx1+50 and mousey>=dy and mousey<dy+50 then dienum=1
if mousex>=dx2 and mousex<dx2+50 and mousey>=dy and mousey<dy+50 then dienum=2
if mousex>=dx3 and mousex<dx3+50 and mousey>=dy and mousey<dy+50 then dienum=3
if mousex>=dx4 and mousex<dx4+50 and mousey>=dy and mousey<dy+50 then dienum=4
if mousex>=dx5 and mousex<dx5+50 and mousey>=dy and mousey<dy+50 then dienum=5
if dienum>-1 then
if dice(dienum,1)=0 then dice(dienum,1)=1 else dice(dienum,1)=0
rollable=dice(1,1)+dice(2,1)+dice(3,1)+dice(4,1)+dice(5,1)
end if
if rollable=0 then
Button buttonx,buttony,buttonw,buttonh,"! ins ScoreBord damit !",0
else
Button buttonx,buttony,buttonw,buttonh,str(mode-1)+". Wurf Spieler "+str(player) ,0
end if
ShowDice
if mousex>=buttonx and mousex<buttonx+buttonw and mousey>=buttony and mousey<buttony+buttonh then
if rollable=0 then
Button buttonx,buttony,buttonw,buttonh,"",10
mode=5
else
RollDice
ShowDice
if mode<4 then
Button buttonx,buttony,buttonw,buttonh,"! ins ScoreBord damit !",0
else
Button buttonx,buttony,buttonw,buttonh,"",10
end if
mode+=1
end if
end if
if mode=5 then
PreEvaluation
PreShowScore
end if
case 2
if mousex>=buttonx and mousex<buttonx+buttonw and mousey>=buttony and mousey<buttony+buttonh then
RollDice
ShowDice
Button buttonx,buttony,buttonw,buttonh,"! ins ScoreBord damit !",0
mode=3
end if
case 1
if mousex>=plx1 and mousex<plx1+50 and mousey>=ply and mousey<ply+50 then maxplayer=1
if mousex>=plx2 and mousex<plx2+50 and mousey>=ply and mousey<ply+50 then maxplayer=2
if mousex>=plx3 and mousex<plx3+50 and mousey>=ply and mousey<ply+50 then maxplayer=3
if mousex>=pl4x and mousex<pl4x+50 and mousey>=ply and mousey<ply+50 then maxplayer=4
if maxplayer>0 then
InitGame
mode=2
end if
end select
CASE FB.EVENT_WINDOW_CLOSE
END
END SELECT
END IF
SLEEP 1
LOOP
end
'SUBs
'*******************************************************************************************************
'*******************************************************************************************************
'*******************************************************************************************************
'GameSubs
sub InitPlayer:
randomize timer
mode=1
maxplayer=0
cls
locate (10,20)
print, "Anzahl der Spieler?"
DieGFX(plx1,ply,1)
DieGFX(plx2,ply,2)
DieGFX(plx3,ply,3)
DieGFX(pl4x,ply,4)
end sub
sub InitGame
dim as integer i,k,buttonmode
for i=1 to 4
for k=0 to 17
if k<>7 and k<>8 and k<>16 and k<>17 then
board(i,k)=-1
end if
next k
next i
player=1
round=1
maxround=13
cls
Button scbx-scbw,scby+0,scbw,scbh,"1er",0
Button scbx-scbw,scby+20,scbw,scbh,"2er",0
Button scbx-scbw,scby+40,scbw,scbh,"3er",0
Button scbx-scbw,scby+60,scbw,scbh,"4er",0
Button scbx-scbw,scby+80,scbw,scbh,"5er",0
Button scbx-scbw,scby+100,scbw,scbh,"6er",0
Button scbx-scbw,scby+120,scbw,scbh,"oben",3
Button scbx-scbw,scby+140,scbw,scbh,"Bonus",3
Button scbx-scbw,scby+180,scbw,scbh,"3er Pasch",0
Button scbx-scbw,scby+200,scbw,scbh,"4er Pasch",0
Button scbx-scbw,scby+220,scbw,scbh,"Full House",0
Button scbx-scbw,scby+240,scbw,scbh,"kl. Strasse",0
Button scbx-scbw,scby+260,scbw,scbh,"gr. Strasse",0
Button scbx-scbw,scby+280,scbw,scbh,"YAKK ;)",0
Button scbx-scbw,scby+300,scbw,scbh,"Chance",0
Button scbx-scbw,scby+320,scbw,scbh,"unten",3
Button scbx-scbw,scby+340,scbw,scbh,"Gesamt",4
for i=0 to 3
Button scbx+scbw*i,scby-20,scbw,scbh,"Spieler "+str(i+1),3
buttonmode=0
for k=1 to 8
if k>=7 then buttonmode=3
Button scbx+scbw*i,scby+(k-1)*scbh,scbw,scbh,"",buttonmode
next k
buttonmode=0
for k=9 to 17
if k=16 then buttonmode=3
if k=17 then buttonmode=4
Button scbx+scbw*i,scby+k*scbh,scbw,scbh,"",buttonmode
next k
next i
InitNewTrial
end sub
sub InitNewTrial
dim as integer i
for i=1 to 5
dice(i,0)=0
dice(i,1)=1
next i
Button buttonx,buttony,buttonw,buttonh,"1. Wurf Spieler "+str(player) ,0
ShowDice
end sub
function RollADie (pipnum as integer) as integer
function=int(rnd * (pipnum))+1
end function
sub RollDice
dim as integer i
for i=1 to 5
if dice(i,1)=1 then
dice(i,0)=RollADie(6)
dice(i,1)=0
end if
next i
end sub
' Auswertungen!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
sub PreEvaluation
dim as integer i,founda,foundb,stra,strb,strc
stats
for i=1 to 17
board(0,i)=0
next i
'1er
board(0,1)=dstats(1)*1
'2er
board(0,2)=dstats(2)*2
'3er
board(0,3)=dstats(3)*3
'4er
board(0,4)=dstats(4)*4
'5er
board(0,5)=dstats(5)*5
'6er
board(0,6)=dstats(6)*6
'3er Pasch
founda=0
for i=1 to 6
if dstats(i)>=3 then founda=1
next i
if founda=1 then
board(0,9)=board(0,1)+board(0,2)+board(0,3)+board(0,4)+board(0,5)+board(0,6)
end if
'4er Pasch
founda=0
for i=1 to 6
if dstats(i)>=4 then founda=1
next i
if founda=1 then
board(0,10)=board(0,1)+board(0,2)+board(0,3)+board(0,4)+board(0,5)+board(0,6)
end if
'Full House
founda=0
foundb=0
for i=1 to 6
if dstats(i)=3 then founda=1
if dstats(i)=2 then foundb=1
next i
if founda=1 and foundb=1 then board(0,11)=25
'kl.strasse
stra=0
strb=0
strc=0
if dstats(1)>=1 and dstats(2)>=1 and dstats(3)>=1 and dstats(4)>=1 then stra=1
if dstats(2)>=1 and dstats(3)>=1 and dstats(4)>=1 and dstats(5)>=1 then strb=1
if dstats(3)>=1 and dstats(4)>=1 and dstats(5)>=1 and dstats(6)>=1 then strc=1
if stra=1 or strb=1 or strc=1 then board(0,12)=30
'gr strasse
stra=0
strb=0
if dstats(1)=1 and dstats(2)=1 and dstats(3)=1 and dstats(4)=1 and dstats(5)=1 then stra=1
if dstats(2)=1 and dstats(3)=1 and dstats(4)=1 and dstats(5)=1 and dstats(6)=1 then strb=1
if stra=1 or strb=1 then board(0,13)=40
'YAKK (Kniffel) ;)
founda=0
for i=1 to 6
if dstats(i)=5 then founda=1
next i
if founda=1 then board(0,14)=50
'chance
board(0,15)=board(0,1)+board(0,2)+board(0,3)+board(0,4)+board(0,5)+board(0,6)
end sub
sub PostEvaluation
dim as integer i
'oben
board(player,7)=0
for i=1 to 6
if board(player,i)>-1 then
board(player,7)+=board(player,i)
endif
next i
'bonus
if board(player,7)>=63 then board(player,8)=35 else board(player,8)=0
'unten
board(player,16)=0
for i=9 to 15
if board(player,i)>-1 then
board(player,16)+=board(player,i)
endif
next i
'gesamt
board(player,17)=board(player,7)+board(player,8)+board(player,16)
end sub
sub stats
dim as integer i
For i=1 to 6
dstats(i)=0
next i
for i=1 to 5
dstats(dice(i,0))+=1
next i
end sub
'*******************************************************************************************************
'gfx subs
sub PreShowScore
dim as integer i,k,buttonmode
buttonmode=5
for k=1 to 6
if board(player,k)=-1 then Button scbx+scbw*(player-1),scby+(k-1)*scbh,scbw,scbh,str(board(0,k)),buttonmode
next k
for k=9 to 15
if board(player,k)=-1 then Button scbx+scbw*(player-1),scby+k*scbh,scbw,scbh,str(board(0,k)),buttonmode
next k
end sub
sub PostShowScore
dim as integer i,k,buttonmode
buttonmode=0
for k=1 to 8
if k>=7 then buttonmode=3
if board(player,k)>-1 then
Button scbx+scbw*(player-1),scby+(k-1)*scbh,scbw,scbh,str(board(player,k)),buttonmode
else
Button scbx+scbw*(player-1),scby+(k-1)*scbh,scbw,scbh,"",buttonmode
end if
next k
buttonmode=0
for k=9 to 17
if k=16 then buttonmode=3
if k=17 then buttonmode=4
if board(player,k)>-1 then
Button scbx+scbw*(player-1),scby+k*scbh,scbw,scbh,str(board(player,k)),buttonmode
else
Button scbx+scbw*(player-1),scby+k*scbh,scbw,scbh,"",buttonmode
end if
next k
end sub
sub ShowDice
if dice(1,1)=0 then DieGFX(dx1,dy,dice(1,0)) else DieGFX(dx1,dy,0)
if dice(2,1)=0 then DieGFX(dx2,dy,dice(2,0)) else DieGFX(dx2,dy,0)
if dice(3,1)=0 then DieGFX(dx3,dy,dice(3,0)) else DieGFX(dx3,dy,0)
if dice(4,1)=0 then DieGFX(dx4,dy,dice(4,0)) else DieGFX(dx4,dy,0)
if dice(5,1)=0 then DieGFX(dx5,dy,dice(5,0)) else DieGFX(dx5,dy,0)
end sub
sub DieGFX (x as integer,y as integer,pipnum as integer)
dim as integer dicewidth,diceheight
dim as integer bodya,bodyb,innerframe,border
dicewidth=50
diceheight=50
border=dgray
if pipnum>0 then
bodya=lgray
bodyb=gray
innerframe=lgray
else
bodya=lblue
bodyb=blue
innerframe=blue
end if
line (x+2,y+2)-(x+dicewidth-3,y+diceheight/2),bodya,bf
line (x+2,y+diceheight/2)-(x+dicewidth-3,y+diceheight-3),bodyb,bf
line (x+2,y+1)-(x+dicewidth-3,y+1),innerframe
line (x+1,y+2)-(x+1,y+diceheight-3),innerframe
line (x+2,y+diceheight-2)-(x+dicewidth-3,y+diceheight-2),innerframe
line (x+dicewidth-2,y+2)-(x+dicewidth-2,y+diceheight-3),innerframe
line (x+1,y)-(x+dicewidth-2,y),border
line -(x+dicewidth-2,y+1),border
line -(x+dicewidth-1,y+1),border
line -(x+dicewidth-1,y+diceheight-2),border
line -(x+dicewidth-2,y+diceheight-2),border
line -(x+dicewidth-2,y+diceheight-1),border
line -(x+1,y+diceheight-1),border
line -(x+1,y+diceheight-2),border
line -(x,y+diceheight-2),border
line -(x,y+1),border
line -(x+1,y+1),border
select case pipnum
case 0
circle(x+25,y+15),15,black,,,.3
line(x+10,y+15)-(x+18,y+40),black
line(x+40,y+15)-(x+32,y+40),black
line(x+18,y+40)-(x+25,y+42),black
line(x+25,y+42)-(x+32,y+40),black
paint(x+25,y+15),dgray,black
paint(x+25,y+25),gray,black
line(x+15,y+20)-(x+19,y+39),lgray
line(x+16,y+20)-(x+20,y+40),white
line(x+17,y+20)-(x+21,y+40),lgray
line(x+18,y+20)-(x+22,y+40),lgray
case 1
circle(x+25,y+25),5,black,,,,f
case 2
circle(x+12,y+38),5,black,,,,f
circle(x+38,y+12),5,black,,,,f
case 3
circle(x+12,y+38),5,black,,,,f
circle(x+25,y+25),5,black,,,,f
circle(x+38,y+12),5,black,,,,f
case 4
circle(x+12,y+12),5,black,,,,f
circle(x+38,y+12),5,black,,,,f
circle(x+38,y+38),5,black,,,,f
circle(x+12,y+38),5,black,,,,f
case 5
circle(x+12,y+12),5,black,,,,f
circle(x+38,y+12),5,black,,,,f
circle(x+38,y+38),5,black,,,,f
circle(x+12,y+38),5,black,,,,f
circle(x+25,y+25),5,black,,,,f
case 6
circle(x+12,y+12),5,black,,,,f
circle(x+38,y+12),5,black,,,,f
circle(x+38,y+25),5,black,,,,f
circle(x+38,y+38),5,black,,,,f
circle(x+12,y+38),5,black,,,,f
circle(x+12,y+25),5,black,,,,f
end select
end sub
sub Button (gx as integer,gy as integer,gw as integer,gh as integer,_
gtxt as string,mode as integer)
dim as integer bodya,bodyb,innerframe,border,gtx,gty,txtcolor
if mode=10 then
line(gx,gy)-(gx+gw,gy+gh),bgcolor,bf
exit sub
end if
border=dgray
select case mode
case 0
bodya=lgray
bodyb=gray
innerframe=gray
txtcolor=black
case 1
bodya=lblue
bodyb=blue
innerframe=blue
txtcolor=black
case 2
bodya=lgray
bodyb=lgray
innerframe=lgray
txtcolor=dgray
case 3
bodya=lblue
bodyb=blue
innerframe=blue
txtcolor=black
case 4
bodya=lblue
bodyb=blue
innerframe=blue
txtcolor=green
case 5
bodya=lgray
bodyb=gray
innerframe=lgray
txtcolor=red
case 6
bodya=green
bodyb=green
innerframe=yellow
txtcolor=yellow
end select
line (gx+2,gy+2)-(gx+gw-3,gy+gh/2),bodya,bf
line (gx+2,gy+gh/2)-(gx+gw-3,gy+gh-3),bodyb,bf
line (gx+2,gy+1)-(gx+gw-3,gy+1),innerframe
line (gx+1,gy+2)-(gx+1,gy+gh-3),innerframe
line (gx+2,gy+gh-2)-(gx+gw-3,gy+gh-2),innerframe
line (gx+gw-2,gy+2)-(gx+gw-2,gy+gh-3),innerframe
line (gx+1,gy)-(gx+gw-2,gy),border
line -(gx+gw-2,gy+1),border
line -(gx+gw-1,gy+1),border
line -(gx+gw-1,gy+gh-2),border
line -(gx+gw-2,gy+gh-2),border
line -(gx+gw-2,gy+gh-1),border
line -(gx+1,gy+gh-1),border
line -(gx+1,gy+gh-2),border
line -(gx,gy+gh-2),border
line -(gx,gy+1),border
line -(gx+1,gy+1),border
gtx=gx+(gw-len(gtxt)*8)/2
gty=gy+(gh-16)/2
draw string (gtx,gty),gtxt,txtcolor
end sub