3D Ripple Runner By Jolly Roger

[pistol350]

Roger is still around mates!

Code Select Expand


'Ripple Runner
'Generates a terrain and a bitmap then applies the bitmap as a texture to the terrain.
'The height of the camera is maintained just above the terrain while moving over it.
'Requires IBasic 1.97 or greater.
'Jolly Roger May 2003
AUTODEFINE "off"
IF GETDXVERSION < 7
   MESSAGEBOX 0,"This program requires" + chr$(13) + "DirectX 7.0 or greater","Error"
   END
ENDIF
DECLARE latheline2()
DECLARE anglegreaterthanminangle(point1:INT,point2:INT,point3:INT)
DECLARE "kernel32",GetTickCount(),int
DEF win:window
DEF scene,camera,light,light2,lastframetime,timesincelastframe,shape:int
DEF smooth,numberoflinepoints,numberofsections,linepointx[10000],linepointy[10000],linecolournumber[10000]:INT
DEF red[8],green[8],blue[8],latheaxisx,d,run,error:INT
DEF rippleheight,ripplespacing:INT
DEF colourtransparency[8],camerapos[3],r,mult,terrainy,degrees:FLOAT
DEF grasstexturefile:FILE
DEF ox,oy,oz,dx,dy,dz,ux,uy,uz,ou,ov,su,sv,wrap[13]:FLOAT
ox=0:oy=0:oz=0:dx=0:dy=1:dz=0:ux=0:uy=1:uz=0:ou=0:ov=0:su=.1:sv=.1
degrees=6.283/360
'open a window
WINDOW win,0,0,640,480,@CAPTION|@NOAUTODRAW,0,"Ripple Runner",mainwindow

'Check if texture bitmap exists.If not then draw it to the screen
'and save it as bitmap.
error=OPENFILE(grasstexturefile,GETSTARTPATH+"grass-texture.bmp","R")
IF error=0
   CLOSEFILE grasstexturefile
ELSE
   'Set up declares needed to save part of screen as bitmap
   GOSUB InitSaveBitmap
   drawgrasstexture
   'Save part of the window as a bitmap using SaveBitmap (bitmapfilename,window,left,top,width,height,colourdepth)
   'N.B. Colour depth should be 24 or 32 for use as a texture
   SaveBitmap (GETSTARTPATH+"grass-texture.bmp",win,0,0,256,256,24)
ENDIF

IF CREATE3DSCREEN(win,640,480,16) <> 0
   MESSAGEBOX win, "Could not create Direct3D screen","Error"
   CLOSEWINDOW win
   END
ENDIF

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)
D3DCOMMAND camera,@SETPOSITION,scene,0,0,-200
D3DCOMMAND camera,@SETORIENTATION,scene,0,0,1,0,1,0

'Create and orient a light source
light = D3DLIGHT(scene,@LIGHTDIRECTIONAL,1,1,1)
D3DCOMMAND light,@SETORIENTATION,scene,0,-1,1, 0,1,1

'create and position a second light source (to overcome D3D Gouraud shading error?)
light2 = D3DLIGHT(scene,@LIGHTDIRECTIONAL,.8,.8,.8)
D3DCOMMAND light2,@SETORIENTATION,scene,0,1,0, 0,0,1

'Create line for lathing
green[0]=255:red[0]=255:blue[0]=255
numberofsections=20:smooth=1
numberoflinepoints=50:rippleheight=5:ripplespacing=10
FOR d=0 TO numberoflinepoints-3
  linepointx[d+1]=5*d
  linepointy[d+1]=rippleheight*COS(d*6.283/ripplespacing)*(1-d/100)
NEXT d
linepointx[numberoflinepoints-2]=linepointx[numberoflinepoints-3]:linepointy[numberoflinepoints-2]=-rippleheight-1
linepointx[numberoflinepoints-1]=0:linepointy[numberoflinepoints-1]=-rippleheight-1
'Optimise line
IF numberoflinepoints>=5 THEN optimiseline2
'Create object
shape=latheline2()
'Add texture
wrap =ox,oy,oz, dx,dy,dz, ux,uy,uz, ou,ov, su,sv
D3DCOMMAND shape,@CREATEWRAP,shape,@WRAPFLAT,wrap
D3DCOMMAND shape,@LOADTEXTURE,GETSTARTPATH+"grass-texture.bmp"

lastframetime=GetTickCount()-1
run=1

'process messages until somebody closes us
WAITUNTIL run=0

'delete all the frames
D3DDELETE light
D3DDELETE light2
D3DDELETE camera
D3DDELETE scene
D3DDELETE shape
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>2
        lastframetime=GetTickCount()
        mult=timesincelastframe/8
      'Move the camera using the arrow keys
        'Up arrow
       IF(GETKEYSTATE(0x26))
        D3DCOMMAND camera,@ADDTRANSLATION,0,0,mult*.1
       ENDIF
        'Down arrow
       IF(GETKEYSTATE(0x28))
        D3DCOMMAND camera,@ADDTRANSLATION,0,0,-mult*.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
 
        'Get position of camera
        D3DCOMMAND camera,@GETPOSITION,scene,camerapos
        'Find distance of camera from centre of terrain
        r=SQRT(camerapos[0]*camerapos[0]+camerapos[2]*camerapos[2])
        'Calculate height of terrain at this distance from centre
        terrainy=rippleheight*COS((r/5)*6.283/ripplespacing)*(1-(r/5)/100)
        'Set camera height so just above terrain
        D3DCOMMAND camera,@SETPOSITION,scene,camerapos[0],terrainy+3,camerapos[2]

      'render the scene to the DirectX surface
      D3DRENDER scene,camera
      'add any 2D elements after the scene is rendered.
      MOVE win,5,10
      PRINT win,"Move around with the arrow keys.Q to exit"
      'show the DirectX surface   
      DXFLIP win,0,0
      ENDIF
  ENDSELECT
RETURN

SUB latheline2()
  DEF numberofpoints,numberoffaces,colournumber,face,section:INT
  numberofpoints=(numberoflinepoints-2)*numberofsections+2
  numberoffaces=(numberoflinepoints-1)*numberofsections
  DEF pointnumber,shape,vertex[numberofpoints],x,y,z,normalnumber,facedata[10]:INT
  DEF normaly,normalx2D,linesegmentangle[numberoflinepoints]:FLOAT
  DEF dx,dy:INT
  DEF angle:FLOAT
  IF smooth=0
    DEF normal[numberoffaces]:INT
  ELSE
    DEF normal[numberofpoints]:INT
  ENDIF
  shape=D3DSHAPE(scene,@SHAPECUSTOM)
  'First find angle of each line segment
  FOR linepoint=1 TO numberoflinepoints-1
    dx=linepointx[linepoint+1]-linepointx[linepoint]:dy=linepointy[linepoint]-linepointy[linepoint+1]
    IF dx=0
      IF dy>0
        angle=1.571
      ELSE
        angle=4.712
      ENDIF
    ELSE
      angle=ATAN(dy/dx)
    ENDIF
    IF dx<0 THEN angle=3.142+angle
    IF dx>0 & dy<0 THEN angle=6.283+angle
    linesegmentangle[linepoint]=angle
  NEXT linepoint
  'Create points
  vertex[0]=D3DCOMMAND (shape,@ADDVERTEX,0,linepointy[1],0)
  FOR linepoint=2 TO numberoflinepoints-1
    FOR section=0 TO numberofsections-1
      pointnumber=1+(linepoint-2)*numberofsections+section
      x=(linepointx[linepoint])*SIN(6.283*section/numberofsections)
      z=(linepointx[linepoint])*COS(6.283*section/numberofsections)
      y=linepointy[linepoint]
      vertex[pointnumber]=D3DCOMMAND (shape,@ADDVERTEX,x,y,z)
    NEXT section
  NEXT linepoint
  vertex[numberofpoints-1]=D3DCOMMAND (shape,@ADDVERTEX,0,linepointy[numberoflinepoints],0)
  'Create normals
  'One per point if smooth.One per face if flat.
  IF smooth=1
    normal[0]=D3DCOMMAND (shape,@ADDNORMAL,0,1,0)
    normal[numberofpoints-1]=D3DCOMMAND (shape,@ADDNORMAL,0,-1,0)
  ENDIF
  FOR linepoint=1 TO numberoflinepoints-1
    IF smooth=0
      normaly=COS(linesegmentangle[linepoint])
      normalx2D=SIN(linesegmentangle[linepoint])
    ELSE
      IF linepoint<numberoflinepoints-1
        normaly=COS((linesegmentangle[linepoint]+linesegmentangle[linepoint+1])/2)
        normalx2D=SIN((linesegmentangle[linepoint]+linesegmentangle[linepoint+1])/2)
      ENDIF
    ENDIF
    FOR section=0 TO numberofsections-1
      IF smooth=0
        normalnumber=(linepoint-1)*numberofsections+section
        normal[normalnumber]=D3DCOMMAND (shape,@ADDNORMAL,normalx2D*SIN(6.283*(section+.5)/numberofsections),normaly,normalx2D*COS(6.283*(section+.5)/numberofsections))
      ELSE
        IF linepoint<numberoflinepoints-1
          normalnumber=1+(linepoint-1)*numberofsections+section
          normal[normalnumber]=D3DCOMMAND (shape,@ADDNORMAL,normalx2D*SIN(6.283*section/numberofsections),normaly,normalx2D*COS(6.283*section/numberofsections))
        ENDIF
      ENDIF
    NEXT section
  NEXT linepoint
  'Create top faces
  FOR face=0 TO numberofsections-1
    facedata[0]=3:facedata[7]=0:facedata[1]=vertex[0]:facedata[3]=vertex[face+1]
      IF face<>numberofsections-1
        facedata[5]=vertex[face+2]
      ELSE
        facedata[5]=vertex[1]
      ENDIF     
    IF smooth=0
      facedata[2]=normal[face]:facedata[4]=normal[face]:facedata[6]=normal[face]
    ELSE
      'Smooth=1
      facedata[2]=normal[0]:facedata[4]=normal[face+1]
      IF face<>numberofsections-1
        facedata[6]=normal[face+2]
      ELSE
        facedata[6]=normal[1]
      ENDIF
    ENDIF
    D3DCOMMAND shape,@ADDFACES,facedata
    colournumber=linecolournumber[1]   
    D3DCOMMAND shape,@SETFACECOLOR,face,red[colournumber]/255,green[colournumber]/255,blue[colournumber]/255,1-colourtransparency[colournumber]
  NEXT face
  IF numberoflinepoints>3
    'Create rest of faces
    FOR linepoint=2 TO numberoflinepoints-2
      FOR section=0 TO numberofsections-1
        facedata[0]=4:facedata[9]=0:facedata[1]=vertex[1+(linepoint-2)*numberofsections+section]
        facedata[3]=vertex[1+(linepoint-1)*numberofsections+section]
        IF section<>numberofsections-1
          facedata[5]=vertex[1+(linepoint-1)*numberofsections+section+1]
          facedata[7]=vertex[1+(linepoint-2)*numberofsections+section+1]
        ELSE
          facedata[5]=vertex[1+(linepoint-1)*numberofsections]
          facedata[7]=vertex[1+(linepoint-2)*numberofsections]
        ENDIF
        IF smooth=0
          facedata[2]=normal[(linepoint-1)*numberofsections+section]
          facedata[4]=facedata[2]:facedata[6]=facedata[2]:facedata[8]=facedata[2]
        ELSE
          facedata[2]=normal[1+(linepoint-2)*numberofsections+section]
          facedata[4]=normal[1+(linepoint-1)*numberofsections+section]
          IF section<>numberofsections-1
            facedata[6]=normal[1+(linepoint-1)*numberofsections+section+1]
            facedata[8]=normal[1+(linepoint-2)*numberofsections+section+1]
          ELSE
            facedata[6]=normal[1+(linepoint-1)*numberofsections]
            facedata[8]=normal[1+(linepoint-2)*numberofsections]
          ENDIF
        ENDIF
        D3DCOMMAND shape,@ADDFACES,facedata
        colournumber=linecolournumber[linepoint]
        face=(linepoint-1)*numberofsections+section
        D3DCOMMAND shape,@SETFACECOLOR,face,red[colournumber]/255,green[colournumber]/255,blue[colournumber]/255,1-colourtransparency[colournumber]
      NEXT section
    NEXT linepoint
  ENDIF
  'Create bottom faces
  FOR face=numberoffaces-numberofsections TO numberoffaces-1
    facedata[0]=3:facedata[7]=0:facedata[1]=vertex[numberofpoints-1-numberoffaces+face]:facedata[3]=vertex[numberofpoints-1]
    IF face<>numberoffaces-1
      facedata[5]=vertex[numberofpoints-numberoffaces+face]
    ELSE
      facedata[5]=vertex[numberofpoints-1-numberofsections]
    ENDIF
    IF smooth=0
      facedata[2]=normal[face]:facedata[4]=normal[face]:facedata[6]=normal[face]
    ELSE
      facedata[2]=normal[numberofpoints-1-numberoffaces+face]
      facedata[4]=normal[numberofpoints-1]
      IF face<>numberoffaces-1
        facedata[6]=normal[numberofpoints-numberoffaces+face]
      ELSE
        facedata[6]=normal[numberofpoints-1-numberofsections]
      ENDIF
    ENDIF
    D3DCOMMAND shape,@ADDFACES,facedata
    colournumber=linecolournumber[numberoflinepoints-1]
    D3DCOMMAND shape,@SETFACECOLOR,face,red[colournumber]/255,green[colournumber]/255,blue[colournumber]/255,1-colourtransparency[colournumber]
  NEXT face
  'Initialise shape
  D3DCOMMAND shape,@CUSTOMINIT
RETURN shape

SUB drawgrasstexture
  RECT win,0,0,256,256,RGB(0,240,0),RGB(0,240,0)
  FOR dot=0 TO 10000
    PSET win,RND(256),RND(256),RGB(0,200+RND(56),0)
  NEXT dot
RETURN

sub InitSaveBitmap
'Fletchie April 2003
DECLARE "gdi32",BitBlt(HDCDest:int,destx:int,desty:int,destw:int,desth:int,HDCSrc:int,srcx:int,srcy:int,rop:INT),int
DECLARE "gdi32",CreateCompatibleBitmap(HDC:int,width:int,height:int),int
DECLARE "gdi32",CreateCompatibleDC(HDC:int),int
DECLARE "gdi32",SelectObject(HDC:int,Handle:int),int
DECLARE "gdi32",DeleteDC(HDC:int),int
DECLARE "gdi32",DeleteObject(handle:int),int
DECLARE "gdi32",GetObjectA(handle:int,size:int,mem:MEMORY),int
DECLARE "gdi32",GetDIBits(HDC:int,hbitmap:int,start:int,lines:int,bits:MEMORY,info:MEMORY,usage:INT),int

TYPE BITMAP
   DEF bmType:INT
   DEF bmWidth:INT
   DEF bmHeight:INT
   DEF bmWidthCHARs:INT
   DEF bmPlanes:WORD
   DEF bmBitsPixel:WORD
   DEF bmBits:INT
ENDTYPE
       
TYPE BITMAPINFOHEADER
   DEF biSize:INT
   DEF biWidth:INT
   DEF biHeight:INT
   DEF biPlanes:WORD
   DEF biBitCount:WORD
   DEF biCompression:INT
   DEF biSizeImage:INT
   DEF biXPelsPerMeter:INT
   DEF biYPelsPerMeter:INT
   DEF biClrUsed:INT
   DEF biClrImportant:INT
ENDTYPE
   
TYPE BITMAPFILEHEADER
   DEF bfType:WORD
   DEF bfSize:INT
   DEF bfReserved1:WORD
   DEF bfReserved2:WORD
   DEF bfOffBits:INT
ENDTYPE
   
DECLARE SaveBitmap(filename:string,win:window,l:int,t:int,w:int,h:int,bitsneeded:int)
DECLARE CreateInfoStructure(win:WINDOW,hbitmap:int,info:BITMAPINFOHEADER,bitsneeded:int)

RETURN

SUB SaveBitmap(filename:string,win:window,l:int,t:int,w:int,h:int)
'Fletchie April 2003
def hdcWin,hdcComp,hbitmap,hbitmapold:int
def info:BITMAPINFOHEADER
def fileheader:BITMAPFILEHEADER
def lpbits,lpbminfo:MEMORY
def file:BFILE

   if w=0
      getclientsize win,l,t,w,h
   endif
   hdcWin = GetHDC(win)
   hdcComp = CreateCompatibleDC(hdcWin)
   if hdcComp = 0
      ReleaseHDC hdcWin
      return 0
   endif
   hbitmap = CreateCompatibleBitmap(hdcwin,w,h)
   if hbitmap = 0
      ReleaseHDC hdcWin
      DeleteDC(hdcComp)
      return 0
   endif
   hbitmapold = SelectObject(hdcComp,hbitmap)
   BitBlt(hdcComp,0,0,w,h,hdcWin,l,t,0x00CC0020)
   SelectObject(hdcComp,hbitmapold)
   DeleteDC(hdcComp)
   CreateInfoStructure win,hbitmap,info,bitsneeded
   allocmem lpbits,1,info.biSizeImage
   allocmem lpbminfo,1,len(info)
   info.bibitcount=bitsneeded
   info.biXPelsPerMeter=3780
   info.biYPelsPerMeter=3780
   writemem lpbminfo,1,info
   GetDIBits(hdcWin,hbitmap,0,info.biHeight,lpbits,lpbminfo,0)
   if (openfile(file,filename,"W") = 0)
      fileheader.bfType = 0x4d42
      fileheader.bfSize = len(fileheader) + info.biSize + info.biSizeImage
      fileheader.bfOffBits = len(fileheader) + info.biSize
      write file,fileheader
      write file,lpbminfo
      write file,lpbits
      closefile file
   endif
   freemem lpbminfo
   freemem lpbits
   ReleaseHDC win,hdcWin
   DeleteObject(hbitmap)
return

sub CreateInfoStructure(win:WINDOW,hbitmap:int,info:BITMAPINFOHEADER,bitsneeded)

def bmp:BITMAP
def mem:memory
def cClrBits:word

   allocmem mem,1,len(bmp)
   GetObjectA(hbitmap,len(bmp),mem)
   readmem mem,1,bmp
   freemem mem
   info.biSize = len(info)
   info.biWidth = bmp.bmWidth
   info.biHeight = bmp.bmHeight
   info.biPlanes = bmp.bmPlanes
   info.biBitCount = bmp.bmBitsPixel

   info.biClrUsed = 0

   cClrBits=bitsneeded
   info.biCompression = 0
   def rs:int
   rs=info.biWidth*int(bitsneeded/8)
   if (rs % 4)<>0
      rs=rs+(4-(rs % 4))
   endif
   info.biSizeImage = rs* info.biHeight

return

SUB optimiseline2
  DEF deletepoint,linepoint,pointinline:INT
  linepoint=3
  DO
    deletepoint=0
    IF linecolournumber[linepoint]=linecolournumber[linepoint-1]
      'Lines on either side of point are same colour
        IF anglegreaterthanminangle(linepoint-1,linepoint,linepoint+1)=1
          'Angle at linepoint is greater than minimum angle
          IF anglegreaterthanminangle(linepoint-2,linepoint-1,linepoint+1)=1
            'Angle at linepoint-1 will be greater than minimum angle if linepoint removed
            IF anglegreaterthanminangle(linepoint-1,linepoint+1,linepoint+2)=1
              'Angle at linepoint+1 will be greater than minimum angle if linepoint removed
              'Point is deletable
              deletepoint=1
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      IF deletepoint=0
        linepoint=linepoint+1
      ELSE
        'Delete point
        FOR pointinline=linepoint TO numberoflinepoints-1
          linepointx[pointinline]=linepointx[pointinline+1]
          linepointy[pointinline]=linepointy[pointinline+1]
          linecolournumber[pointinline]=linecolournumber[pointinline+1]
        NEXT pointinline
        numberoflinepoints=numberoflinepoints-1
      ENDIF
    ENDIF
  UNTIL linepoint=numberoflinepoints-1
RETURN

SUB anglegreaterthanminangle(point1,point2,point3)
  DEF cosangle,angle,minangle:FLOAT
  DEF OK,dx,dy,linelength1squared,linelength2squared,linelength3squared:INT
  'Find angle between line from point1 to point2 and line from point2 to point3
  dx=linepointx[point1]-linepointx[point2]
  dy=linepointy[point1]-linepointy[point2]
  linelength1squared=dx*dx+dy*dy
  dx=linepointx[point2]-linepointx[point3]
  dy=linepointy[point2]-linepointy[point3]
  linelength2squared=dx*dx+dy*dy
  dx=linepointx[point1]-linepointx[point3]
  dy=linepointy[point1]-linepointy[point3]
  linelength3squared=dx*dx+dy*dy
  IF linelength1squared=0 | linelength2squared=0
    angle=180*degrees
  ELSE
    cosangle=(linelength1squared+linelength2squared-linelength3squared)/(2*SQRT(linelength1squared)*SQRT(linelength2squared))
    angle=ACOS(cosangle)
  ENDIF
  minangle=(140+SQRT(linelength3squared))*degrees
  IF minangle>165*degrees THEN minangle=165*degrees
  IF angle>minangle
    OK=1
  ELSE
    OK=0
  ENDIF
RETURN OK


[GWS]

That's good news .. 

By the way, have you thought how many thousands of lines of code we've run in just the first tests of Creative's abilities .. and no errors have surfaced .. 

How's that for an excellent pedigree 

Best wishes,

Graham

[pistol350]

LOL!
Yeah!
Only my love for this language is talking right now 
I just hope that everything will be oK with all the upcoming codes.

By the way, now that i come to think about it,
Joske made a great work in gathering by group all the source code he managed to get through the past years.
and these files can be download directly from Codingmokeys download area :http://www.codingmonkeys.com/

So mates just say Hi to Cameron from me