I remain speechless :-X
just run this code and be amazed
AUTODEFINE "OFF"
'Declare timer
DECLARE "kernel32",GetTickCount(),INT
'Declare cylinder function
DECLARE cylinder(numberofsections:INT,topfacepresent:INT,bottomfacepresent:INT,smooth:INT)
DEF win:WINDOW
DEF imagefile:BFILE
DEF error,run:INT
DEF mult,wrap[13],brightnessmult,sunspeed:FLOAT
DEF scene,camera,light,light2,light3,ground,sun,sunpivot,sunlight,moon,moonlight:INT
DEF iscameratranslation,lastframetime,timesincelastframe,n,sunwasup:INT
DEF post[12],postshadow[12],postx[12],postz[12],shadowlength:INT
DEF lastcamerax,lastcameraz,camerax,cameraz,translation,sunangle:FLOAT
sunwasup=1:sunangle=0
CONST sunspeed=.002
'Open a window
WINDOW win,0,0,640,480,@NOAUTODRAW,0,"Woodhenge",mainwindow
STARTTIMER win,100
run=1
error=OPENFILE(imagefile,GETSTARTPATH+"grass-texture.bmp","R")
IF error
'Bitmap does not exist.Create it
PRINT win,"Generating texture"
GOSUB generategrasstextureimage
ELSE
CLOSEFILE imagefile
ENDIF
'Create a 3D screen
error=CREATE3DSCREEN(win,640,480,32)
IF error<>0
MESSAGEBOX win, "Could not create Direct3D screen","Error"
CLOSEWINDOW win
END
ENDIF
'Hide cursor
SETCURSOR win,@CSCUSTOM,0
D3DSETQUALITY win,@LIGHTON | @FILLSOLID | @SHADEGOURAUD
FRONTPEN win,RGB(255,255,255)
BACKPEN win,0
DRAWMODE win,@TRANSPARENT
'The parent scene frame
scene = D3DSCENE(win)
D3DCOMMAND scene,@SETSCENEBACKCOLOR,.2,.2,1
'Create and position the camera
camera = D3DCAMERA(scene)
camerax=0:cameraz=-1000
D3DCOMMAND camera,@SETPOSITION,scene,0,80,-1000
D3DCOMMAND camera,@SETORIENTATION,scene,0,0,1,0,1,0
'Create and orient a light source
light = D3DLIGHT(scene,@LIGHTDIRECTIONAL,.8,.8,.8)
D3DCOMMAND light,@SETORIENTATION,scene,-1,-1,1, -1,1,1
'Create and orient a light source
light2 = D3DLIGHT(scene,@LIGHTDIRECTIONAL,.6,.6,.6)
D3DCOMMAND light2,@SETORIENTATION,scene,1,-1,1, 1,1,1
'Create and orient a light source
light3 = D3DLIGHT(scene,@LIGHTDIRECTIONAL,1,1,1)
D3DCOMMAND light3,@SETORIENTATION,scene,0,-1,-1, 0,1,1
'Create textured ground
DEF vertex1,vertex2,vertex3,vertex4,facedata[10],normal:INT
wrap=0,0,0, 0,1,0, 1,0,0, 0,0, .003,.003
ground=D3DSHAPE(scene,@SHAPECUSTOM)
vertex1=D3DCOMMAND (ground,@ADDVERTEX,-1000,0,1000)
vertex2=D3DCOMMAND (ground,@ADDVERTEX,1000,0,1000)
vertex3=D3DCOMMAND (ground,@ADDVERTEX,1000,0,-1000)
vertex4=D3DCOMMAND (ground,@ADDVERTEX,-1000,0,-1000)
normal=D3DCOMMAND (ground,@ADDNORMAL,0,1,0)
facedata=4,vertex1,normal,vertex2,normal,vertex3,normal,vertex4,normal,0
D3DCOMMAND ground,@ADDFACES,facedata
D3DCOMMAND ground,@CUSTOMINIT
D3DCOMMAND ground,@SETSHAPECOLOR,0,1,0
D3DCOMMAND ground,@CREATEWRAP,ground,@WRAPFLAT,wrap
D3DCOMMAND ground,@LOADTEXTURE,GETSTARTPATH+"grass-texture.bmp"
'Create posts and shadows
FOR n=0 TO 11
'Create posts
post[n]=cylinder(12,0,0,1)
D3DCOMMAND post[n],@SETSHAPECOLOR,.6,.4,0
D3DCOMMAND post[n],@SCALE,6,60,6
postx[n]=200*SIN(n*6.283/12):postz[n]=200*COS(n*6.283/12)
D3DCOMMAND post[n],@SETPOSITION,scene,postx[n],60,postz[n]
'Create shadows
postshadow[n]=D3DSHAPE(scene,@SHAPECUSTOM)
vertex1=D3DCOMMAND (postshadow[n],@ADDVERTEX,0,0.1,-6)
vertex2=D3DCOMMAND (postshadow[n],@ADDVERTEX,0,0.1,6)
vertex3=D3DCOMMAND (postshadow[n],@ADDVERTEX,100,0.1,6)
vertex4=D3DCOMMAND (postshadow[n],@ADDVERTEX,100,0.1,-6)
normal=D3DCOMMAND (postshadow[n],@ADDNORMAL,0,1,0)
facedata=4,vertex1,normal,vertex2,normal,vertex3,normal,vertex4,normal,0
D3DCOMMAND postshadow[n],@ADDFACES,facedata
D3DCOMMAND postshadow[n],@CUSTOMINIT
D3DCOMMAND postshadow[n],@SETPOSITION,scene,postx[n],0,postz[n]
'Set shadow colour to semitransparent black
D3DCOMMAND postshadow[n],@SETSHAPECOLOR,0,0,0,.4
NEXT n
'Create sun
DEF material[10]:FLOAT
'Create sun pivot.As this is rotated the sun will circle
sunpivot=D3DSHAPE(scene,@SHAPECUSTOM)
sun=D3DSHAPE(sunpivot,@SHAPESPHERE,50,10)
D3DCOMMAND sun,@SETPOSITION,sunpivot,-3000,0,0
'Make sun emit yellow light and be unaffected by scene lights
D3DCOMMAND sun,@SETSHAPECOLOR,0,0,0
material=1, 0,0,0 ,1,1,0 ,0,0,0
D3DCOMMAND sun,@CREATEMATERIAL,material
'Attach light to sun
sunlight = D3DLIGHT(sun,@LIGHTDIRECTIONAL,.5,.5,.5)
D3DCOMMAND sunlight,@SETORIENTATION,scene,1,0,0, 0,1,0
'Create moon
moon=D3DSHAPE(sunpivot,@SHAPESPHERE,50,10)
D3DCOMMAND moon,@SETPOSITION,sunpivot,3000,0,0
'Make moon emit white light and be unaffected by scene lights
D3DCOMMAND moon,@SETSHAPECOLOR,0,0,0
material=1, 0,0,0 ,1,1,1 ,0,0,0
D3DCOMMAND moon,@CREATEMATERIAL,material
'Attach light to moon
moonlight = D3DLIGHT(moon,@LIGHTDIRECTIONAL,.3,.3,.3)
D3DCOMMAND moonlight,@SETORIENTATION,scene,-1,0,0, 0,1,0
'Set sunpivot at angle so sun and moon rise and set
D3DCOMMAND sunpivot,@ADDROTATION,1,0,0,-.3
lastframetime=GetTickCount()-1
'Process messages until somebody closes us
WAITUNTIL run=0
'Delete all the frames
FOR n=0 TO 11
D3DDELETE post[n]
D3DDELETE postshadow[n]
NEXT n
D3DDELETE sun
D3DDELETE sunpivot
D3DDELETE sunlight
D3DDELETE moon
D3DDELETE moonlight
D3DDELETE light
D3DDELETE light2
D3DDELETE light3
D3DDELETE camera
D3DDELETE ground
D3DDELETE scene
CLOSEWINDOW win
END
SUB mainwindow
SELECT @class
CASE @IDCHAR
IF (@CODE = ASC("Q")) | (@CODE = ASC("q")) THEN run = 0
CASE @IDCREATE
CENTERWINDOW win
CASE @IDCLOSEWINDOW
run=0
CASE @IDDXUPDATE
'Find time since last frame to make things run at a constant speed
timesincelastframe=GetTickCount()-lastframetime
IF timesincelastframe>1
lastframetime=GetTickCount()
mult=timesincelastframe/8
iscameratranslation=0
'Move sun
D3DCOMMAND sunpivot,@ADDROTATION,0,1,0,mult*sunspeed
sunangle=sunangle+mult*sunspeed
IF sunangle>6.283 THEN sunangle=sunangle-6.283
IF ((sunangle<20*6.283/360) | (sunangle>340*6.283/360) | ((sunangle>160*6.283/360) & (sunangle<200*6.283/360)))
IF sunangle<20*6.283/360 THEN brightnessmult=.5+sunangle*1.432
IF sunangle>340*6.283/360 THEN brightnessmult=.5-(6.283-sunangle)*1.432
IF ((sunangle>160*6.283/360) & (sunangle<200*6.283/360)) THEN brightnessmult=1-(sunangle-2.793)*1.432
'brightnessmult=0 for sunangle=340 and sunangle=200
'brightnessmult=0.5 for sunangle=0 and sunangle=180
'brightnessmult=1 for sunangle>20 and sunangle<160
'Set light intensities
D3DCOMMAND light,@SETLIGHTCOLOR,.2+.7*brightnessmult,.2+.7*brightnessmult,.2+.7*brightnessmult
D3DCOMMAND light2,@SETLIGHTCOLOR,.1+.5*brightnessmult,.1+.5*brightnessmult,.1+.5*brightnessmult
D3DCOMMAND light3,@SETLIGHTCOLOR,.3+.7*brightnessmult,.3+.7*brightnessmult,.3+.7*brightnessmult
'Set sky colour
D3DCOMMAND scene,@SETSCENEBACKCOLOR,.05+.15*brightnessmult,.05+.15*brightnessmult,.25+.75*brightnessmult
'Set post shadow transparency
FOR n=0 TO 11
D3DCOMMAND postshadow[n],@SETSHAPECOLOR,0,0,0,.8*ABS(brightnessmult-.5)
NEXT n
IF ((sunangle<20*6.283/360) | ((sunangle>160*6.283/360) & (sunangle<180*6.283/360)))
'Sun rising or setting
'Set sunlight intensity
D3DCOMMAND sunlight,@SETLIGHTCOLOR,.5*2*(brightnessmult-.5),.5*2*(brightnessmult-.5),.5*2*(brightnessmult-.5)
'Set moonlight intensity
D3DCOMMAND moonlight,@SETLIGHTCOLOR,.3-.3*2*(brightnessmult-.5),.3-.3*2*(brightnessmult-.5),.3-.3*2*(brightnessmult-.5)
ENDIF
ENDIF
'Move post shadows and change length
IF sunangle>3.142 & sunwasup
sunwasup=0
'Change shadow direction so moon shadow
FOR n=0 TO 11
D3DCOMMAND postshadow[n],@ADDROTATION,0,1,0,3.142
NEXT n
ENDIF
IF sunangle<3.142 & sunwasup=0
sunwasup=1
'Change shadow direction so sun shadow
FOR n=0 TO 11
D3DCOMMAND postshadow[n],@ADDROTATION,0,1,0,3.142
NEXT n
ENDIF
shadowlength=100/(2-ABS(COS(sunangle)))
FOR n=0 TO 11
D3DCOMMAND postshadow[n],@ADDROTATION,0,1,0,mult*sunspeed
D3DCOMMAND (postshadow[n],@SETVERTEX,2,shadowlength,0.1,6)
D3DCOMMAND (postshadow[n],@SETVERTEX,3,shadowlength,0.1,-6)
NEXT n
'The camera can move in the scene using the arrow keys
'Up arrow
IF(GETKEYSTATE(0x26))
D3DCOMMAND camera,@ADDTRANSLATION,0,0,.7*mult
translation=.7*mult
iscameratranslation=1
ENDIF
'Down arrow
IF(GETKEYSTATE(0x28))
translation=-.7*mult
D3DCOMMAND camera,@ADDTRANSLATION,0,0,-.7*mult
iscameratranslation=1
ENDIF
'Left arrow
IF(GETKEYSTATE(0x25))
D3DCOMMAND camera,@ADDROTATION,0,1,0,(-.5 * (3.1415/180))*mult
ENDIF
'Right arrow
IF(GETKEYSTATE(0x27))
D3DCOMMAND camera,@ADDROTATION,0,1,0,(.5 * (3.1415/180))*mult
ENDIF
IF iscameratranslation
'Check for collision with posts
GOSUB collisiondetection
ENDIF
lastcamerax=camerax:lastcameraz=cameraz
'Render the scene to the DirectX surface
D3DRENDER scene,camera
'Add any 2D elements after the scene is rendered.
MOVE win,5,5
PRINT win,"Move around the scene with the arrow keys.Press Q to exit"
'Show the DirectX surface
DXFLIP win,0,0
ENDIF
ENDSELECT
RETURN
SUB cylinder(numberofsections,topfacepresent,bottomfacepresent,smooth)
'Function creates a cylinder with the given number of sections.Minimum number of sections is three.
'topfacepresent,bottomfacepresent and smooth should be 0 or 1.
'If smooth is set to one then cylinder sides will appear smooth if @SHADEGOURAUD used.
'If smooth set to zero then sides will appear flat even if @SHADEGOURAUD is used.
'Jolly Roger March 2003
DEF shape,numberofvertices:INT
DEF x,z:FLOAT
IF numberofsections>2
shape=D3DSHAPE(scene,@SHAPECUSTOM)
numberofvertices=numberofsections*2
DEF vertex[numberofvertices],normal[numberofsections],facedata[((2*numberofsections)+5)]:INT
'Create vertices and side face normals
FOR section=0 TO numberofsections-1
x=SIN(6.28*section/numberofsections)
z=COS(6.28*section/numberofsections)
IF smooth=0
normal[section]=D3DCOMMAND(shape,@ADDNORMAL,SIN(6.28*(section+.5)/numberofsections),0,COS(6.28*(section+.5)/numberofsections))
ELSE
normal[section]=D3DCOMMAND(shape,@ADDNORMAL,x,0,z)
ENDIF
vertex[section]=D3DCOMMAND (shape,@ADDVERTEX,x,1,z)
vertex[section+numberofsections]=D3DCOMMAND (shape,@ADDVERTEX,x,-1,z)
NEXT section
'Create faces
IF topfacepresent=1
'Top face
facedata[0]=numberofsections
topnormal=D3DCOMMAND(shape,@ADDNORMAL,0,1,0)
FOR section=0 TO numberofsections-1
facedata[section*2+1]=vertex[section],topnormal
NEXT section
facedata[2*numberofsections+1]=0
D3DCOMMAND (shape,@ADDFACES,facedata)
ENDIF
IF bottomfacepresent=1
'Bottom face
facedata[0]=numberofsections
bottomnormal=D3DCOMMAND(shape,@ADDNORMAL,0,-1,0)
FOR section=0 TO numberofsections-1
facedata[section*2+1]=vertex[2*numberofsections-section-1],bottomnormal
NEXT section
facedata[2*numberofsections+1]=0
D3DCOMMAND (shape,@ADDFACES,facedata)
ENDIF
'Side faces
facedata[0]=4
FOR section=0 TO numberofsections-1
facedata[1]=vertex[section],normal[section],vertex[section+numberofsections],normal[section]
IF section<>numberofsections-1
facedata[5]=vertex[section+1+numberofsections],normal[section+1],vertex[section+1],normal[section+1]
ELSE
facedata[5]=vertex[numberofsections],normal[0],vertex[0],normal[0]
ENDIF
IF smooth=0
facedata[6]=normal[section]
facedata[8]=normal[section]
ENDIF
facedata[9]=0
D3DCOMMAND (shape,@ADDFACES,facedata)
NEXT section
D3DCOMMAND shape,@CUSTOMINIT
ENDIF
RETURN shape
SUB collisiondetection
DEF dx,dz:INT
DEF camerapos[3]:FLOAT
'Get current camera position
D3DCOMMAND camera,@GETPOSITION,scene,camerapos
camerax=camerapos[0]:cameraz=camerapos[2]
FOR n=0 TO 11
dx=camerax-postx[n]:dz=cameraz-postz[n]
IF dx*dx+dz*dz<49
'Collided with post(within 7 units of centre of post)
'Reset camera to position in previous frame
D3DCOMMAND camera,@SETPOSITION,scene,lastcamerax,80,lastcameraz
camerax=lastcamerax:cameraz=lastcameraz
n=11
ENDIF
NEXT n
RETURN
SUB generategrasstextureimage
'Creates a 256x256 texture for the grass
DEF byte:CHAR
DEF twobytes:WORD
DEF integer,filelength,width,height:INT
TYPE threebytes
DEF blue:CHAR
DEF green:CHAR
DEF red:CHAR
ENDTYPE
DEF colourdata:threebytes
width=256:height=256
error=OPENFILE(imagefile,GETSTARTPATH+"grass-texture.bmp","W")
IF error=0
'File opened successfully
filelength=54+4*CEIL(3*width/4)*height
'Write header
byte=ASC("B"):WRITE imagefile,byte
byte=ASC("M"):WRITE imagefile,byte
WRITE imagefile,filelength
integer=0:WRITE imagefile,integer
integer=54:WRITE imagefile,integer
integer=40:WRITE imagefile,integer
WRITE imagefile,width
WRITE imagefile,height
twobytes=1:WRITE imagefile,twobytes
twobytes=24:WRITE imagefile,twobytes
integer=0:FOR n=1 TO 6:WRITE imagefile,integer:NEXT n
'Write colour data
FOR y=height-1 TO 0 STEP -1
FOR x=0 TO width-1
colourdata.red=0:colourdata.green=100+RND(155):colourdata.blue=0
WRITE imagefile,colourdata
NEXT x
IF (width*3)%4<>0
'Pad out so number of bytes in row is a multiple of four
byte=0
FOR n=1 TO 4-(width*3)%4
WRITE imagefile,byte
NEXT n
ENDIF
NEXT y
CLOSEFILE imagefile
ENDIF
RETURN