#include once "wincode.bi"scene 640,480dontquittowindowsgreyvoidcargo "serg.bmp",1rig as integer pressedspacestartrace ultranav 1,640*slots,480*slots,WINNER readout "YOU'RE WINNER !",mousex,mousey if brake or click>0 then if pressedspace=LOSER then honk pressedspace=WINNER else pressedspace=LOSER endif if esc then timesup winendrace
'Copyright (c) 2012 Thunder'Permission is hereby granted, free of charge, to any person obtaining a copy'of this software and associated documentation files (the "Software"), to deal'in the Software without restriction, including without limitation the rights'to use, copy, modify, merge, publish, distribute, sublicense, and/or sell'copies of the Software, and to permit persons to whom the Software is'furnished to do so, subject to the following conditions:'The above copyright notice and this permission notice shall be included in'all copies or substantial portions of the Software.'THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR'IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,'FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE'AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER'LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,'OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN'THE SOFTWARE.#lang "deprecated"#define __YOURE_WINNER__#define startrace do#define endrace loop#define exitrace exit do#define rig dim#define timesup end#define WINNER 1#define LOSER 0#define quittowindows enableescapekey#define dontquittowindows disableescapekeychdir exepathdim shared as uinteger _mask=rgb(255,0,255)'You can change this, it's 500000dim shared as integer render3d=500000redim shared as single world(render3d,3)redim shared as integer worldcolors(render3d,3)dim shared as integer r3d1=0dim shared as double PI=4*atn(1)dim shared as integer drawdistancedrawdistance=3000dim shared as integer fogr,fogg,fogb,onfogdim shared as single camxdim shared as single camydim shared as single camzdim shared as single camrotdim shared as single frimdim shared as integer screenfpsdim shared as string*2 closeTriggerString=chr$(255)+"k"dim shared as ubyte escapeKeyEnabled=1dim shared as uinteger bufColor=rgb(0,0,0)dim shared as uinteger ptr puiPixel,bufPointer,sgfxPointerdim shared as any ptr imageexist(1 to 65535)dim shared as integer imagewidth(1 to 65535),imageheight(1 to 65535)dim shared as integer mousex=320,mousey=240,click,screenwidth,screenheight,realscreenwidth,realscreenheightdeclare sub loadsound(byval sound as string,byval num as integer)declare sub loopsound(byval num as integer)declare sub playsound(byval num as integer)declare sub stopsound(byval num as integer)declare sub deletesound(byval num as integer)declare function soundexist(byval num as integer) as integerdeclare function _transb(byval so as uinteger,byval de as uinteger,byval pa as any ptr) as uintegerdeclare function angle(byval x as double,byval y as double) as doubledeclare sub box(byval x1 as integer,byval y1 as integer,byval x2 as integer,byval y2 as integer,byval c as uinteger=&hFFFFFF)declare sub prefix(byval textData as string,byval textX as integer,byval textY as integer)declare sub greyvoid(byval c as uinteger=0)declare function controlkey() as ubytedeclare sub deleteimage(byval imagenumber as integer)declare sub deletestaticobjectsdeclare sub disableescapekeydeclare sub dot(byval x as integer,byval y as integer,byval c as uinteger=&hFFFFFF)declare function downkey() as ubytedeclare sub enableescapekeydeclare function esc as ubytedeclare sub fogcolor(byval c as uinteger)declare sub fogoffdeclare sub fogondeclare sub fogdistance(byval dist as integer=drawdistance)declare sub getimage(byval num as integer,byval x1 as integer,byval y1 as integer,byval x2 as integer,byval y2 as integer)declare sub hidemousedeclare sub honkdeclare function imagecollision(byval i1 as integer,byval x1 as integer,byval y1 as integer,byval i2 as integer,byval x2 as integer,byval y2 as integer) as ubytedeclare function leftkey() as ubytedeclare function lerp(byval a as single,byval b as single,byval f as single) as singledeclare sub showcargo(byval filename as string)declare sub cargo(byval filename as string,byval imagenumber as integer)declare sub loadstaticobjects(byval filename as string)declare sub makelandscape(byval i as integer,byval x as integer=0,byval y as integer=0,byval z as integer=0,byval w as integer=0,byval h as integer=0)declare sub makepoint(byval x as single=0,byval y as single=0,byval z as single=0,byval c as uinteger)declare sub movecamera(byval a as single=0)declare sub ultranav(byval imagenumber as integer,byval x as integer,byval y as integer,byval f as integer=0)declare function returnkey() as ubytedeclare function rgbb(byval c as uinteger) as ubytedeclare function rgbg(byval c as uinteger) as ubytedeclare function rgbr(byval c as uinteger) as ubytedeclare function rightkey() as ubytedeclare sub savebitmap(byval filename as string)declare sub saveimage(byval filename as string,byval imagenumber as integer)declare sub savestaticobjects(byval filename as string)declare sub scene(byval sWidth as integer=0,byval sHeight as integer=0,byval sDepth as integer=0)declare sub setwindowtitle(byval tit as string)declare sub showmousedeclare function slots() as doubledeclare function brake() as ubytedeclare function split(byval st as string,byval char as string,byval ind as integer) as stringdeclare sub windeclare sub readout(byval textData as string,byval textX as integer,byval textY as integer)declare function textheight(byval textData as string) as integerdeclare function textwidth(byval textData as string) as integerdeclare sub triangle(byval x1 as integer,byval y1 as integer,byval x2 as integer,byval y2 as integer,byval x3 as integer,byval y3 as integer,byval col as uinteger)declare function upkey() as ubytedeclare function wrapvalue(byval a as single) as single#ifdef __FB_WIN32__ declare function mciSendStringA alias "mciSendStringA" (byval as zstring ptr,byval as zstring ptr,byval as uinteger,byval as integer ptr) as uinteger public sub loadsound(byval sound as string,byval num as integer) static as string quote quote=chr$(34) mciSendStringA("open " & quote & sound & quote & " type mpegvideo alias snd" & num & " wait",0,0,0) end sub public sub loopsound(byval num as integer) 'PlaySoundA(sound,0,8 OR 2 OR 1) mciSendStringA("play snd" & num & " from 0 REPEAT",0,0,0) end sub public sub playsound(byval num as integer) 'PlaySoundA(sound,0,2 OR 1) mciSendStringA("play snd" & num & " from 0",0,0,0) end sub public sub stopsound(byval num as integer) 'PlaySoundA(0,0,0) mciSendStringA("stop snd" & num,0,0,0) end sub public sub deletesound(byval num as integer) mciSendStringA("close snd" & num & " wait",0,0,0) end sub public function soundexist(byval num as integer) as integer if mciSendStringA("play snd" & num & " test",0,0,0)=0 then return 1 else return 0 end if end function#else public sub loadsound(byval sound as string,byval num as integer) return end sub public sub loopsound(byval num as integer) return end sub public sub playsound(byval num as integer) return end sub public sub stopsound(byval num as integer) return end sub public sub deletesound(byval num as integer) return end sub public function soundexist(byval num as integer) as integer return 0 end function#endiffunction _transb(byval so as uinteger,byval de as uinteger,byval pa as any ptr) as uinteger if so=_mask then return de else return so end ifend functionpublic function angle(byval x as double,byval y as double) as double if x>0 then if y>0 then if x>y then 'wedge 2 return 2-(y/x) else 'wedge 1 return x/y end if elseif y<0 then if x+y<0 then 'wedge 4 return (x/y)+4 else 'wedge 3 return 2-(y/x) end if else return 2 end if elseif x<0 then if y>0 then if x+y>0 then 'wedge 8 return (x/y)+8 else 'wedge 7 return 6-(y/x) end if elseif y<0 then if x>y then 'wedge 5 return (x/y)+4 else 'wedge 6 return 6-(y/x) end if else return 6 end if else if y<0 then return 4 else return 0 end if end ifend functionpublic sub box(byval x1 as integer,byval y1 as integer,byval x2 as integer,byval y2 as integer,byval c as uinteger=&hFFFFFF) line bufPointer,(x1,y1)-(x2,y2),c,BFend subpublic sub prefix(byval textData as string,byval textX as integer,byval textY as integer) draw string bufPointer,(textX-(len(textData)*4),textY),textDataend subpublic sub greyvoid(byval c as uinteger=0) if c>0 then bufColor=c else bufColor=rgb(127,127,127) end ifend subpublic function controlkey() as ubyte return multikey(&h1D)end functionpublic sub deleteimage(byval imagenumber as integer) imagedestroy imageexist(imagenumber) imageexist(imagenumber)=0end subpublic sub deletestaticobjects dim as integer i for i=0 to r3d1-1 world(i,0)=0 world(i,1)=0 world(i,2)=0 worldcolors(i,0)=0 worldcolors(i,1)=0 worldcolors(i,2)=0 next i r3d1=0end subpublic sub disableescapekey escapeKeyEnabled=0end subpublic sub dot(byval x as integer,byval y as integer,byval c as uinteger=&hFFFFFF) puiPixel=screenwidth*y+x+bufPointer *puiPixel=cend subpublic function downkey() as ubyte return multikey(&h50)end functionpublic sub enableescapekey escapeKeyEnabled=1end subpublic function esc as ubyte return multikey(&h01)end functionpublic sub fogcolor(byval c as uinteger) fogr=rgbr(c) fogg=rgbg(c) fogb=rgbb(c)end subpublic sub fogoff onfog=0end subpublic sub fogon onfog=1end subpublic sub fogdistance(byval dist as integer=drawdistance) drawdistance=distend subpublic sub getimage(byval num as integer,byval x1 as integer,byval y1 as integer,byval x2 as integer,byval y2 as integer) static as integer t,iw,ih if x1>x2 then t=x1 x1=x2 x2=t end if if y1>y2 then t=y1 y1=y2 y2=t end if if imageexist(num)>0 then imagedestroy imageexist(num) iw=x2+1-x1 ih=y2+1-y1 imageexist(num)=ImageCreate(iw,ih) imagewidth(num)=iw imageheight(num)=ih get bufPointer,(x1,y1)-(x2,y2),imageexist(num)end subpublic sub hidemouse setmouse ,,0end subpublic sub honk #ifdef __FB_LINUX__ shell("echo "+chr$(7)) #else print chr$(7) #endifend subpublic function imagecollision(byval i1 as integer,byval x1 as integer,byval y1 as integer,byval i2 as integer,byval x2 as integer,byval y2 as integer) as ubyte if x1+imagewidth(i1)>x2 and y1+imageheight(i1)>y2 and x2+imagewidth(i2)>x1 and y2+imageheight(i2)>y1 then return 1 else return 0 end ifend functionpublic function leftkey() as ubyte return multikey(&h4B)end functionpublic function lerp(byval a as single,byval b as single,byval f as single) as single return f*(b-a)+aend functionpublic sub showcargo(byval filename as string) static as integer filenum, bmpwidth, bmpheight static as any ptr img filenum = FreeFile() if Open( filename For Binary Access Read As #filenum ) <> 0 Then return Get #filenum, 19, bmpwidth Get #filenum, 23, bmpheight Close #filenum img = ImageCreate( bmpwidth, Abs(bmpheight) ) if img = 0 then return if BLoad( filename, img ) <> 0 Then ImageDestroy( img ):return put bufPointer,(0,0),img,pset imagedestroy imgend subpublic sub cargo(byval filename as string,byval imagenumber as integer) static as integer filenum, bmpwidth, bmpheight static as any ptr img filenum = FreeFile() if Open( filename For Binary Access Read As #filenum ) <> 0 Then return Get #filenum, 19, bmpwidth Get #filenum, 23, bmpheight Close #filenum img = ImageCreate( bmpwidth, Abs(bmpheight) ) if img = 0 then return if BLoad( filename, img ) <> 0 Then ImageDestroy( img ):return imagewidth(imagenumber)=bmpwidth imageheight(imagenumber)=bmpheight if imageexist(imagenumber)>0 then imagedestroy imageexist(imagenumber) imageexist(imagenumber)=imgend subpublic sub loadstaticobjects(byval filename as string) static as integer filenum static as string txt,ts filenum = FreeFile() if Open(filename For Binary As #filenum) <> 0 Then return Do Until EOF(filenum) Line Input #filenum,txt ts=split(txt,",",1) if len(ts)>0 then world(r3d1,0)=val(split(txt,",",0)) world(r3d1,1)=val(ts) world(r3d1,2)=val(split(txt,",",2)) worldcolors(r3d1,0)=valint(split(txt,",",3)) worldcolors(r3d1,1)=valint(split(txt,",",4)) worldcolors(r3d1,2)=valint(split(txt,",",5)) r3d1+=1 end if Loop Close #filenumend subpublic sub makelandscape(byval i as integer,byval x as integer=0,byval y as integer=0,byval z as integer=0,byval w as integer=0,byval h as integer=0) static as integer px,py,iw,ih,iwm,ihm,wm,hm,colly static as uinteger c,tc static as uinteger ptr ie if w=0 and h=0 then w=imagewidth(i) h=imageheight(i) end if x-=w/2 z+=h/2 ie=imageexist(i) tc=rgb(255,0,255) iw=imagewidth(i) ih=imageheight(i) iwm=iw-1 ihm=ih-1 wm=w-1 hm=h-1 for py=0 to hm colly=((py+1)/h)*ihm for px=0 to wm c=point(((px+1)/w)*iwm,colly,ie) if c<>tc then makepoint(px+x,y,z-py,c) next px next pyend subpublic sub makepoint(byval x as single=0,byval y as single=0,byval z as single=0,byval c as uinteger) world(r3d1,0)=x world(r3d1,1)=y world(r3d1,2)=z worldcolors(r3d1,0)=rgbr(c) worldcolors(r3d1,1)=rgbg(c) worldcolors(r3d1,2)=rgbb(c) r3d1+=1end subpublic sub movecamera(byval a as single=0) dim as single camr=camrot*PI/180 camx+=a*sin(camr) camz+=a*cos(camr)end subpublic sub ultranav(byval imagenumber as integer,byval x as integer,byval y as integer,byval f as integer=0) if f=1 then put bufPointer,(x,y),imageexist(imagenumber),custom,@_transb else put bufPointer,(x,y),imageexist(imagenumber),pset endifend subpublic function returnkey() as ubyte return multikey(&h1C)end functionpublic function rgbb(byval c as uinteger) as ubyte return c and 255end functionpublic function rgbg(byval c as uinteger) as ubyte return c shr 8 and 255end functionpublic function rgbr(byval c as uinteger) as ubyte return c shr 16 and 255end functionpublic function rightkey() as ubyte return multikey(&h4D)end functionpublic sub savebitmap(byval filename as string) bsave filename,bufPointerend subpublic sub saveimage(byval filename as string,byval imagenumber as integer) bsave filename,imageexist(imagenumber)end subpublic sub savestaticobjects(byval filename as string) static as integer filenum,i kill filename filenum = FreeFile() if Open(filename For Output As #filenum) <> 0 Then return for i=0 to r3d1-1 print #filenum,world(i,0) & "," & world(i,1) & "," & world(i,2) & "," & worldcolors(i,0) & "," & worldcolors(i,1) & "," & worldcolors(i,2) next i Close #filenumend subpublic sub scene(byval sWidth as integer=0,byval sHeight as integer=0,byval sDepth as integer=0) screenwidth=sWidth screenheight=sHeight if sDepth>0 then screenres screenwidth,screenheight,sDepth realscreenwidth=screenwidth realscreenheight=screenheight else #ifdef __FB_DOS__ realscreenwidth=320 realscreenheight=200 sDepth=16 #else screeninfo realscreenwidth,realscreenheight,sDepth #endif if sWidth=0 and sHeight=0 then screenwidth=realscreenwidth screenheight=realscreenheight screenres realscreenwidth,realscreenheight,sDepth,,1 or 4 or 80 else screenres screenwidth,screenheight,sDepth end if end if windowtitle Command(0) realscreenwidth=screenwidth realscreenheight=screenheight if bufPointer>0 then imagedestroy bufPointer bufPointer=ImageCreate(screenwidth,screenheight,bufColor) sgfxPointer=screenptr() width realscreenwidth/8,realscreenheight/14end subpublic sub setwindowtitle(byval tit as string) windowtitle titend subpublic sub showmouse setmouse ,,1end subpublic function slots as double dim as double rndomnumbler rndomnumbler=rnd() if rndomnumbler>=1 then rndomnumbler=0 return rndomnumblerend functionpublic function brake as ubyte return multikey(&h39)end functionpublic function split(byval st as string,byval char as string,byval ind as integer) as string static as string s,r static as integer curind,x,l s="" r="" curind=0 x=0 l=len(st) do x+=1 s=mid$(st,x,1) if s=char then curind+=1 if curind>ind then exit do else if curind=ind then r=r+s end if if x>=l then exit do loop return rend functionpublic sub win static as integer px,py,w,h,iw,ih,iwm,ihm,wm,hm,colly static as uinteger ptr ie,pp iw=screenwidth ih=screenheight iwm=iw-1 ihm=ih-1 w=realscreenwidth h=realscreenheight wm=w-1 hm=h-1 ie=bufPointer if iw<w or ih<h then pp=sgfxPointer screenlock for py=0 to hm colly=py/hm*ihm for px=0 to wm *pp=point(px/wm*iwm,colly,ie) pp+=1 next px next py screenunlock else put (0,0),ie,pset end if if multikey(&h38) and multikey(&h3E) or inkey$()=closeTriggerString then end if escapeKeyEnabled=1 then if multikey(&h01) then end line ie,(0,0)-(iwm,ihm),bufColor,BF if r3d1>0 then dim as single camr=camrot*PI/180 dim as single points(drawdistance+1,r3d1,3) dim as integer i for i=0 to r3d1-1 dim as single x1=world(i,0)-camx dim as single z1=world(i,2)-camz dim as single z2=x1*sin(camr)+z1*cos(camr) if z2>0 and z2<=drawdistance then dim as integer z3=int(z2) points(z3,i,0)=x1*cos(camr)-z1*sin(camr) points(z3,i,1)=world(i,1)-camy points(z3,i,2)=z2 end if next i dim as integer z dim as integer hsw=0.5*screenwidth dim as integer hsh=0.5*screenheight dim as integer ssw=0.71*screenwidth if onfog=1 then dim as single pr,pg,pb for z=drawdistance to 0 step -1 for i=0 to r3d1-1 dim as single z1=points(z,i,2) if z1>0 then dim as single z2=0-z1 dim as integer s=ssw/z1 dim as single h=s*-0.5 dim as integer x1=points(z,i,0)/z1*hsw+h+hsw dim as integer y1=points(z,i,1)/z2*hsw+h+hsh dim as integer x2=x1+s dim as integer y2=y1+s if x2>0 and y2>0 and x1<screenwidth and y1<screenheight then 'Possible fog formulas: 'r=(fogr-points(z,i,3))/drawdistance*z1+points(z,i,3) 'r=(z1*fogr-(z1*points(z,i,3)))/drawdistance+points(z,i,3) 'r=z1/drawdistance*(points(z,i,3)-fogr)+fogr 'dim as single f=1/exp(drawdistance/z1) dim as single f=z1/(drawdistance+1) line bufPointer,(x1,y1)-(x2,y2),rgb(lerp(worldcolors(i,0),fogr,f),lerp(worldcolors(i,1),fogg,f),lerp(worldcolors(i,2),fogb,f)),BF end if end if next i next z else for z=drawdistance to 0 step -1 for i=0 to r3d1-1 dim as single z1=points(z,i,2) if z1>0 then dim as single z2=0-z1 dim as integer s=ssw/z1 dim as single h=s*-0.5 dim as integer x1=points(z,i,0)/z1*hsw+h+hsw dim as integer y1=points(z,i,1)/z2*hsw+h+hsh dim as integer x2=x1+s dim as integer y2=y1+s if x2>0 and y2>0 and x1<screenwidth and y1<screenheight then line bufPointer,(x1,y1)-(x2,y2),rgb(worldcolors(i,0),worldcolors(i,1),worldcolors(i,2)),BF end if next i next z end if end if sleep 1 static as double oldtime,time1 oldtime=time1 time1=timer() frim=(time1-oldtime) if frim<0 then frim=0 if frim>0.5 then frim=0.5 getmouse(mousex,mousey,,click) mousex=int(screenwidth/realscreenwidth*mousex) mousey=int(screenheight/realscreenheight*mousey)end subpublic sub readout(byval textData as string,byval textX as integer,byval textY as integer) draw string bufPointer,(textX,textY),textDataend subpublic function textheight(byval textData as string) as integer return 14end functionpublic function textwidth(byval textData as string) as integer return len(textData)*8end functionpublic sub triangle(byval x1 as integer,byval y1 as integer,byval x2 as integer,byval y2 as integer,byval x3 as integer,byval y3 as integer,byval col as uinteger) static as integer dx1,dy1, dx2,dy2, dx3,dy3, delta1,delta2,delta3, Lx,Rx, y, Lxo,Rxo IF y2 < y1 THEN SWAP y1, y2 SWAP x1, x2 END IF IF y3 < y1 THEN SWAP y3, y1 SWAP x3, x1 END IF IF y3 < y2 THEN SWAP y3, y2 SWAP x3, x2 END IF dx1 = x2 - x1 dy1 = y2 - y1 IF dy1 <> 0 THEN delta1 = (dx1 shl 16) / dy1 ELSE delta1 = 0 END IF dx2 = x3 - x2 dy2 = y3 - y2 IF dy2 <> 0 THEN delta2 = (dx2 shl 16) / dy2 ELSE delta2 = 0 END IF dx3 = x1 - x3 dy3 = y1 - y3 IF dy3 <> 0 THEN delta3 = (dx3 shl 16) / dy3 ELSE delta3 = 0 END IF 'Flat bottom 'Top part of triangle Lx = x1 shl 16 Rx = Lx FOR y = y1 TO y2 - 1 Lxo = Lx shr 16 Rxo = Rx shr 16 line bufPointer,(Lxo,y)-(Rxo,y),col Lx += delta1 Rx += delta3 NEXT y 'Flat top 'Lower part of triangle Lx = x2 shl 16 FOR y = y2 TO y3 Lxo = Lx shr 16 Rxo = Rx shr 16 line bufPointer,(Lxo,y)-(Rxo,y),col Lx += delta2 Rx += delta3 NEXT yend subpublic function upkey() as ubyte return multikey(&h48)end functionpublic function wrapvalue(byval a as single) as single static as single a360 a360=a/360 if a>=360 then a=(a360-int(a360))*360 elseif a<0 then a=(a360-int(a360))*360 end if return aend function
Do you use FreeBASIC?
Do you use FreeGDK?
Do you ever wish FreeGDK could be more so you could make games like ?
Now you can!
Introducing WINNERcode, a work-in-progress adaptation of FreeGDK (and FreeBASIC) syntax to a more dialect.
Here is an example program:
To compile the program, you must download FreeBASIC and type "fbc anyname.bas".
big rigs is great and i want to suck his cock
do it and i might maybe possibly probably play it
i will be unavailable and will get to it when i can
first tell me what the game is about, and then i will maybe possibly download it