3D solstice by Jolly Roger

[pistol350]

 I remain speechless
just run this code and be amazed

Code Select Expand


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