Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

pbcc slot machine

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • pbcc slot machine

    http://www.bervini.net/raffaello/



    Code:
    'Bervini Raffaello Switzerland
    'PowerBasic PBCC
    'www.bervini.net/raffaello/     for all the bmp
    #COMPILE EXE
    #DIM ALL
    '------------------------------------------------------------------------------
     GLOBAL hDlg1,hDlg2,hDlg3,id_cil1,id_cil2,id_cil3,iter AS LONG
    '%figure=37
    '%figure=27
     %figure=9
    '%figure=13
    '%figure=14
    '%figure=4
    '%figure=3
    '------------------------------------------------------------------------------
    FUNCTION PBMAIN () AS LONG
     LOCAL larghezza_finestra,altezza_finestra AS LONG,i AS STRING
     IF larghezza_finestra=0 THEN larghezza_finestra=150
     IF altezza_finestra=0 THEN altezza_finestra=98
     GRAPHIC WINDOW "",200+0*larghezza_finestra,200,larghezza_finestra,altezza_finestra*3 TO hDlg1
     GRAPHIC WINDOW "",200+1*larghezza_finestra,200,larghezza_finestra,altezza_finestra*3 TO hDlg2
     GRAPHIC WINDOW "",200+2*larghezza_finestra,200,larghezza_finestra,altezza_finestra*3 TO hDlg3
     CONSOLE SET FOCUS:CONSOLE SET SCREEN 2,80:CONSOLE SET LOC 0,0
     PRINT "Studio slot machine ..."
     PRINT "<Spazio> per giocare, <c> continuo, <esc> per finire"
    '----
     LOCAL j,id_bmp(),id_tmp AS LONG
     DIM id_bmp(0 TO %figure)
     FOR j=1 TO %figure:CALL caricaimmagine("carta"+TRIM$(STR$(j))+".bmp",id_tmp):id_bmp(j)=id_tmp:NEXT
    '----
     CALL creacilindro(id_bmp(),%figure,id_cil1)
     CALL creacilindro(id_bmp(),%figure,id_cil2)
     CALL creacilindro(id_bmp(),%figure,id_cil3)
     CALL slot(altezza_finestra)
     DO:
      i=INKEY$
      SLEEP 100
      IF i=CHR$(27) THEN EXIT LOOP
      SELECT CASE i
       CASE "c":DO:CALL slot(altezza_finestra):SLEEP 1000:LOOP WHILE NOT INSTAT
       CASE " ":CALL slot(altezza_finestra)
      END SELECT
     LOOP
    END FUNCTION
    '------------------------------------------------------------------------------
    SUB color2rgb(colore AS LONG,red AS LONG,green AS LONG,blue AS LONG)
     Red=colore AND &H000000FF
     SHIFT RIGHT colore,8
     Green=colore AND &H000000FF
     SHIFT RIGHT colore,8
     Blue=colore AND &H000000FF
    END SUB
    '------------------------------------------------------------------------------
    SUB muovi(id_mem AS LONG,hDlg AS LONG,py AS LONG)
     LOCAL la_win,al_win,id_tmp,j AS LONG
     STATIC al_bmp,la_bmp AS LONG
     GRAPHIC ATTACH hDlg,0,REDRAW
     GRAPHIC GET CLIENT TO la_win,al_win
     IF la_bmp=0 OR al_bmp=0 THEN GRAPHIC ATTACH id_mem,0,REDRAW:GRAPHIC GET CLIENT TO la_bmp,al_bmp
     GRAPHIC BITMAP NEW la_bmp,al_bmp TO id_tmp:GRAPHIC ATTACH id_tmp,0,REDRAW
     IF py>0 THEN
      GRAPHIC COPY id_mem,0,(0,0)-(la_bmp-1,al_bmp-py) TO (0,py)
      GRAPHIC COPY id_mem,0,(0,al_bmp-py)-(la_bmp,al_bmp) TO (0,0)
      GRAPHIC ATTACH id_mem,0,REDRAW:GRAPHIC COPY id_tmp,0,(0,0)-(la_bmp-0,al_bmp-0) TO (0,0):GRAPHIC ATTACH id_tmp,0,REDRAW
     END IF
     GRAPHIC BITMAP END
    
     GRAPHIC ATTACH hDlg,0,REDRAW
     GRAPHIC COPY id_mem,0,(0,0)-(la_win,al_win) TO (0,0)
     FOR j=3 TO 1 STEP -1
      GRAPHIC LINE (0,al_win/2+j)-(la_win/6,al_win/2+j),RGB(255-j*20,25,25)
      GRAPHIC LINE (5*la_win/6,al_win/2+j)-(la_win,al_win/2+j),RGB(255-j*20,25,25)
     NEXT
    
    'zigrinatura
     FOR j=al_win/3 TO 0 STEP -2
    ' GRAPHIC LINE (0,j-1)-(la_win,j-1),RGB(j*6-al_win/3,j*6-al_win/3,j*6-al_win/3)
      GRAPHIC LINE (0,al_win-j)-(la_win,al_win-j),RGB(j*6-al_win/3,j*6-al_win/3,j*6-al_win/3)
     NEXT
    
    'scurisce
     LOCAL PixelPtr AS LONG PTR,xsize,ysize,red,green,blue AS LONG,bmp AS STRING,soglia AS SINGLE
     GRAPHIC GET BITS TO bmp:xsize=CVL(bmp,1):ysize=CVL(bmp,5)
     PixelPtr=STRPTR(bmp)+8:soglia=0
     FOR j=1 TO xsize*ysize/3:soglia=soglia+.000069:CALL color2rgb(BYCOPY @PixelPtr,red,green,blue):@PixelPtr=RGB(red*soglia,green*soglia,blue*soglia):INCR PixelPtr:NEXT
     FOR j=2*xsize*ysize/3 TO xsize*ysize:INCR PixelPtr:NEXT
     PixelPtr=STRPTR(bmp)+8:soglia=1
     FOR j=1 TO 2*xsize*ysize/3:INCR PixelPtr:NEXT
     FOR j=2*xsize*ysize/3 TO xsize*ysize:soglia=soglia-.00008:CALL color2rgb(BYCOPY @PixelPtr,red,green,blue):@PixelPtr=RGB(red*soglia,green*soglia,blue*soglia):INCR PixelPtr:NEXT
     GRAPHIC SET BITS bmp
    
    'linee orizzontali
     GRAPHIC LINE (0,al_win/3-1)-(la_win,al_win/3-1),RGB(255,205,205)
     GRAPHIC LINE (0,2*al_win/3)-(la_win,2*al_win/3),RGB(255,205,205)
    
    'bordi in alto e basso
     FOR j=0 TO al_win/12:GRAPHIC LINE (0,j)-(la_win,j),RGB(2255/(j+6),1255/(j+6),1255/(j+6)):NEXT
     FOR j=11*al_win/12 TO al_win:GRAPHIC LINE (0,j)-(la_win,j),RGB(2255/(j-11*al_win/12+6),1255/(j-11*al_win/12+6),1255/(j-11*al_win/12+6)):NEXT
     GRAPHIC REDRAW
    END SUB
    '------------------------------------------------------------------------------
    SUB caricaimmagine(nomefile AS STRING,id_bmp AS LONG)
     LOCAL ff,la,al AS LONG
     IF DIR$(nomefile)="" THEN
      GRAPHIC BITMAP NEW 150,98 TO id_bmp
      GRAPHIC ATTACH id_bmp,0,REDRAW
      GRAPHIC CLEAR RGB(RND*255,RND*255,RND*255)
      GRAPHIC COLOR RGB(RND*255,RND*255,RND*255),-2
      GRAPHIC PRINT "qui ci va bmp 150x98"
      GRAPHIC COLOR RGB(RND*255,RND*255,RND*255),-2
      GRAPHIC FONT "arial",16,1
      GRAPHIC PRINT nomefile
      GRAPHIC COPY id_bmp,0
      GRAPHIC WINDOW END
     ELSE
      ff=FREEFILE:OPEN nomefile FOR BINARY AS ff:GET #ff,19,la:GET #ff,23,al:CLOSE ff
      GRAPHIC BITMAP LOAD nomefile,la,al TO id_bmp
      GRAPHIC ATTACH id_bmp,0,REDRAW
      GRAPHIC COPY id_bmp,0
      GRAPHIC WINDOW END
     END IF
    END SUB
    '------------------------------------------------------------------------------
    SUB creacilindro(id() AS LONG,item AS LONG,id_cil AS LONG)
     LOCAL j,la,al,r AS LONG
     IF id_cil<>0 THEN GRAPHIC ATTACH id_cil,0:GRAPHIC WINDOW END
     GRAPHIC ATTACH id(1),0,REDRAW:GRAPHIC GET CLIENT TO la,al
     GRAPHIC BITMAP NEW la,al*item TO id_cil
     GRAPHIC ATTACH id_cil,0,REDRAW
     FOR j=0 TO item-1
      GRAPHIC COPY id(j+1),0 TO (0,al*j)
      GRAPHIC COLOR %GREEN,-2:GRAPHIC SET POS(0,al*j):GRAPHIC PRINT j+1
      GRAPHIC SET PIXEL (1,1+al*j),RGB(j+1,0,0)
     NEXT
     GRAPHIC REDRAW
    'salva l'immagine del rullo
    'GRAPHIC SAVE "cil"+TRIM$(STR$(%figure))+".bmp"
    END SUB
    '------------------------------------------------------------------------------
    SUB slot(af AS LONG)
     LOCAL j,k,k1,k2,k3,ok1,ok2,ok3,y1,y2,y3,finale1,finale2,finale3,colore1,colore2,colore3 AS LONG
     %velocita=12
     INCR iter
     RANDOMIZE TIMER
    'randomizza la posizione iniziale del cilindro
     CALL muovi(id_cil1,hDlg1,RND(1,%figure)*af):CALL muovi(id_cil2,hDlg2,RND(1,%figure)*af):CALL muovi(id_cil3,hDlg3,RND(1,%figure)*af)
    'questo crea errori
    'k1=RND(1,%figure)*af*%figure:k2=RND(1,%figure)*af*%figure:k3=RND(1,%figure)*af*%figure
    'questo non crea errori
     k1=RND(5,%figure)*af:k2=RND(5,%figure)*af:k3=RND(5,%figure)*af
     k=MAX(k1,k2,k3)
     FOR j=1 TO k
      IF k1=>1 THEN y1=1+k1\%velocita:CALL muovi(id_cil1,hDlg1,y1):ok1=ok1+y1:k1=k1-y1 ELSE finale1=1
      IF k2=>1 THEN y2=1+k2\%velocita:CALL muovi(id_cil2,hDlg2,y2):ok2=ok2+y2:k2=k2-y2 ELSE finale2=1
      IF k3=>1 THEN y3=1+k3\%velocita:CALL muovi(id_cil3,hDlg3,y3):ok3=ok3+y3:k3=k3-y3 ELSE finale3=1
    'removed  IF INKEY$>"" THEN EXIT SUB
      SLEEP 10
      IF finale1+finale2+finale3=3 THEN EXIT FOR
     NEXT
     GRAPHIC ATTACH hDlg1,0,REDRAW:GRAPHIC GET PIXEL (1,1+af) TO colore1
     GRAPHIC ATTACH hDlg2,0,REDRAW:GRAPHIC GET PIXEL (1,1+af) TO colore2
     GRAPHIC ATTACH hDlg3,0,REDRAW:GRAPHIC GET PIXEL (1,1+af) TO colore3
     CALL esaminavincite(colore1,colore2,colore3)
    
    'scrive nei bordi
     CALL scrivi(hDlg1,"<space> play",-20)
     CALL scrivi(hDlg2,"<c> continuo",-20)
     CALL scrivi(hDlg3,"<esc> end",-20)
     CALL scrivi(hDlg2,"Giocate"+STR$(iter)+"",5)
     CALL scrivi(hDlg3,USING$("## ",colore1,colore2,colore3)+"   (rullo"+STR$(%figure)+")",5)
    END SUB
    '------------------------------------------------------------------------------
    SUB esaminavincite(c1 AS LONG,c2 AS LONG,c3 AS LONG)
     STATIC vincita AS LONG
     IF c1=c2 AND c2=c3 THEN vincita=vincita+10:CALL scrivi(hDlg1,"Saldo "+STR$(vincita)+"$",5):EXIT SUB
     IF c1=c2 THEN vincita=vincita+2:CALL scrivi(hDlg1,"Saldo "+STR$(vincita)+"$",5):EXIT SUB
     IF c1=c3 THEN vincita=vincita+2:CALL scrivi(hDlg1,"Saldo "+STR$(vincita)+"$",5):EXIT SUB
     IF c2=c3 THEN vincita=vincita+2:CALL scrivi(hDlg1,"Saldo "+STR$(vincita)+"$",5):EXIT SUB
     vincita=vincita-1
     CALL scrivi(hDlg1,"Saldo "+STR$(vincita)+"$",5)
    END SUB
    '------------------------------------------------------------------------------
    SUB scrivi(hDlg AS LONG,testo AS STRING,posizione AS LONG)
     LOCAL la,al,l,a AS LONG
     GRAPHIC ATTACH hDlg,0,REDRAW
     GRAPHIC GET CLIENT TO la,al
     GRAPHIC TEXT SIZE testo TO l,a
     IF posizione<0 THEN posizione=al+posizione
     GRAPHIC SET POS((la-l)/2,posizione)
     GRAPHIC COLOR %WHITE,-2
     GRAPHIC FONT "arial",10,1
     GRAPHIC PRINT testo
     GRAPHIC REDRAW
    END SUB
    '------------------------------------------------------------------------------
    Last edited by Raffaello Bervini; 24 Apr 2008, 01:55 AM.
Working...
X