LB Booster
Programming >> BASIC code examples >> Direct3D demos
http://lbb.conforums.com/index.cgi?board=code&action=display&num=1471452625
Direct3D demos
Post by Richard Russell on Aug 17th, 2016, 4:50pm

It's a long time since I posted my Direct3D demos, illustrating the use of the CallMethod function (and that was at the LB forum, in the good old days when I was allowed to post there!) so here again is the 'rotating globe' demo. You will need to put world.bmp and sphere.dat in the same directory as the .bas:

Code:
' Direct3D Rotating Globe, version 1.0, 09-Nov-2013
' (C) R.T.Russell 2013, http://www.rtrussell.co.uk/

nomainwin
WindowWidth=640
WindowHeight=512
BMPfile$="world.bmp"
DATfile$="sphere.dat"

open "D3D8.DLL" for DLL as #d3d8
open "OLEAUT32.DLL" for DLL as #oleaut32
open "Blue Planet" for graphics_nsb as #w

#w "trapclose [quit]"
hw=hwnd(#w)
calldll #user32, "GetDC", hw as ulong, hdc as long

calldll #d3d8, "Direct3DCreate8", 120 as long, IDirect3D8 as long

struct D3DDISPLAYMODE,_
  Width as long, Height as long,_
  RefreshRate as long, Format as long
struct parm, Adapter1 as long, pMode as struct

parm.pMode.struct=D3DDISPLAYMODE.struct
r=CallMethod(IDirect3D8, 8, parm.struct) ' ::GetAdapterDisplayMode
D3DDISPLAYMODE.struct=parm.pMode.struct

struct D3DPARMS,_
  BackBufferWidth as long, BackBufferHeight as long,_
  BackBufferFormat as long, BackBufferCount as long,_
  MultiSampleType as long, SwapEffect as long,_
  DeviceWindow as long, Windowed as long,_
  EnableAutoDepthStencil as long,_
  AutoDepthStencilFormat as long,_
  Flags as long, FullScreenRefreshRateInHz as long,_
  FullScreenPresentationInterval as long
D3DPARMS.BackBufferFormat.struct=D3DDISPLAYMODE.Format.struct
D3DPARMS.SwapEffect.struct=1
D3DPARMS.Windowed.struct=1
D3DPARMS.EnableAutoDepthStencil.struct=1
D3DPARMS.AutoDepthStencilFormat.struct=80

struct parm,_
  Adapter as long, DeviceType as long, FocusWindow as ulong,_
  BehaviorFlags as long, PresentationParameters as struct,_
  ReturnedDeviceInterface as struct
struct temp, v as long
parm.DeviceType.struct=1
parm.FocusWindow.struct=hw
parm.BehaviorFlags.struct=32
parm.PresentationParameters.struct=D3DPARMS.struct
parm.ReturnedDeviceInterface.struct=temp.struct
r=CallMethod(IDirect3D8, 15, parm.struct) ' ::CreateDevice
temp.struct=parm.ReturnedDeviceInterface.struct
IDirect3DDevice8=temp.v.struct

' IDirect3DDevice8::SetRenderState
struct parm, State as long, Value as long
parm.State.struct=22 ' D3DRS_CULLMODE
parm.Value.struct=2
r=CallMethod(IDirect3DDevice8, 50, parm.struct)
parm.State.struct=137 ' D3DRS_LIGHTING
parm.Value.struct=0
r=CallMethod(IDirect3DDevice8, 50, parm.struct)
parm.State.struct=7 ' D3DRS_ZENABLE
parm.Value.struct=1
r=CallMethod(IDirect3DDevice8, 50, parm.struct)

triangles=512
vertices=3*triangles
vertexshader=hexdec("102")
vertexsize=20

struct temp, v as long
struct parm,_
  Length as long, Usage as long, FVF as long,_
  Pool as long, VertexBuffer as struct
parm.Length.struct=vertices*vertexsize
parm.FVF.struct=vertexshader
parm.VertexBuffer.struct=temp.struct
r=CallMethod(IDirect3DDevice8, 23, parm.struct) ' ::CreateVertexBuffer
temp.struct=parm.VertexBuffer.struct
IDirect3DVertexBuffer8=temp.v.struct

struct temp, v as long
struct parm,_
  OffsetToLock as long, SizeToLock as long,_
  ppbData as struct, Flags as long
parm.SizeToLock.struct=vertices*vertexsize
parm.ppbData.struct=temp.struct
r=CallMethod(IDirect3DVertexBuffer8, 11, parm.struct) ' ::Lock
temp.struct=parm.ppbData.struct
VertexData=temp.v.struct

open DATfile$ for input as #dat
for p=VertexData to VertexData+vertices*vertexsize-4 step 4
  input #dat, n
  calldll #oleaut32, "VarR4FromR8", n as double, p as long, r as void
next
close #dat
r=CallMethod(IDirect3DVertexBuffer8, 12, "") ' ::Unlock

struct parm, StreamNumber as long, StreamData as long, Stride as long
parm.StreamData.struct=IDirect3DVertexBuffer8
parm.Stride.struct=vertexsize
r=CallMethod(IDirect3DDevice8, 83, parm.struct) ' ::SetStreamSource

struct parm, Handle as long
parm.Handle.struct=vertexshader
r=CallMethod(IDirect3DDevice8, 76, parm.struct) ' ::SetVertexShader

IDirect3DTexture8=LoadTexture8(IDirect3DDevice8, hdc, BMPfile$, 1024, 1024)
struct parm, Stage as long, Texture as long
parm.Texture.struct=IDirect3DTexture8
r=CallMethod(IDirect3DDevice8, 61, parm.struct) ' ::SetTexture

struct matrix,_
  f11 as long, f12 as long, f13 as long, f14 as long,_
  f21 as long, f22 as long, f23 as long, f24 as long,_
  f31 as long, f32 as long, f33 as long, f34 as long,_
  f41 as long, f42 as long, f43 as long, f44 as long
matrix.f11.struct=float(1)
matrix.f22.struct=float(1)
matrix.f33.struct=float(1)
matrix.f43.struct=float(9) ' Viewing distance
matrix.f44.struct=float(1)
struct parm, State as long, Matrix as struct
parm.State.struct=2 ' view transform
parm.Matrix.struct=matrix.struct
r=CallMethod(IDirect3DDevice8, 37, parm.struct) ' ::SetTransform

fv=0.4  ' Vertical field of view
ar=WindowWidth / WindowHeight ' Aspect ratio
zn=1    ' Near clipping plane
zf=1000 ' Far clipping plane
h=1/tan(fv/2)
matrix.f11.struct=float(h/ar)
matrix.f22.struct=float(h)
matrix.f33.struct=float(zf/(zf-zn))
matrix.f44.struct=float(0)
matrix.f34.struct=float(1)
matrix.f43.struct=float(0-zn*zf/(zf-zn))
parm.State.struct=3 ' projection transform
parm.Matrix.struct=matrix.struct
r=CallMethod(IDirect3DDevice8, 37, parm.struct) ' ::SetTransform

[renderloop]
struct parm,_
  Count as long, pRects as long, Flags as long,_
  BackColor as long, Z as long, Stencil as long
parm.Flags.struct=3
parm.BackColor.struct=hexdec("404040")
parm.Z.struct=float(1)
r=CallMethod(IDirect3DDevice8, 36, parm.struct) ' ::Clear
r=CallMethod(IDirect3DDevice8, 34, "") ' ::BeginScene

yaw=time$("ms")/2000
roll=-0.4*cos(yaw)
pitch=0.4*sin(yaw)

sy=sin(yaw) : cy=cos(yaw)
sp=sin(pitch) : cp=cos(pitch)
sr=sin(roll) : cr=cos(roll)
matrix.f11.struct=float(sy*sp*sr+cy*cr)
matrix.f12.struct=float(cp*sr)
matrix.f13.struct=float(cy*sp*sr-sy*cr)
matrix.f14.struct=0
matrix.f21.struct=float(sy*sp*cr-cy*sr)
matrix.f22.struct=float(cp*cr)
matrix.f23.struct=float(cy*sp*cr+sy*sr)
matrix.f24.struct=0
matrix.f31.struct=float(cp*sy)
matrix.f32.struct=float(0-sp)
matrix.f33.struct=float(cp*cy)
matrix.f34.struct=0
matrix.f41.struct=float(Xpos)
matrix.f42.struct=float(Ypos)
matrix.f43.struct=float(Zpos)
matrix.f44.struct=float(1)
struct parm, State as long, Matrix as struct
parm.State.struct=256 ' world transform
parm.Matrix.struct=matrix.struct
r=CallMethod(IDirect3DDevice8, 37, parm.struct) ' ::SetTransform

struct parm,_
  PrimitiveType as long,_
  StartVertex as long, PrimitiveCount as long
parm.PrimitiveType.struct=4 ' D3DPT_TRIANGLELIST
parm.PrimitiveCount.struct=triangles
r=CallMethod(IDirect3DDevice8, 70, parm.struct) ' ::DrawPrimitive
r=CallMethod(IDirect3DDevice8, 35, "") ' ::EndScene

struct parm,_
  SourceRect as struct, DestRect as struct,_
  DestWindowOverride as long, DirtyRegion as struct
r=CallMethod(IDirect3DDevice8, 15, parm.struct) ' ::Present

' Fix 'Float underflow exception'
bugfix$=chr$(219)+chr$(227)+chr$(194)+chr$(16)
calldll #user32, "CallWindowProcA", bugfix$ as ptr,_
  0 as long, 0 as long, 0 as long, 0 as long, r as long

scan
calldll #kernel32, "Sleep", 10 as long, r as long
goto [renderloop]

[quit]
r=CallMethod(IDirect3DVertexBuffer8, 2, "") ' ::Release
r=CallMethod(IDirect3DDevice8, 2, "") ' ::Release
r=CallMethod(IDirect3D8, 2, "") ' ::Release
close #w
close #oleaut32
close #d3d8
end

function LoadTexture8(device, hdc, bmpfile$, dx, dy)
loadbmp "texture", bmpfile$
hbm=hbmp("texture")
calldll #user32, "CopyImage", hbm as ulong, 0 as long,_
  dx as long, dy as long, 0 as long, hcopy as long
unloadbmp "texture"

struct temp, v as long
struct parm, Width as long, Height as long, Levels as long,_
  Usage as long, Format as long, Pool as long, Tex as struct
parm.Width.struct=dx
parm.Height.struct=dy
parm.Format.struct=21 ' D3DFMT_A8R8G8B8
parm.Pool.struct=1 ' D3DPOOL_MANAGED
parm.Tex.struct=temp.struct
r=CallMethod(device, 20, parm.struct) ' ::CreateTexture
temp.struct=parm.Tex.struct
LoadTexture8=temp.v.struct

struct rect, Pitch as long, Bits as long
struct parm, Level as long, LockedRect as struct,_
  Null as long, Flags as long
parm.LockedRect.struct=rect.struct
r=CallMethod(LoadTexture8, 16, parm.struct)
rect.struct=parm.LockedRect.struct

struct bmih, Size as long, Width as long, Height as long,_
  Planes as word, BitCount as word, Compression as long,_
  SizeImage as long, XPelsPerMeter as long, YPelsPerMeter as long,_
  ClrUsed as long, ClrImportant as long
bmih.Size.struct=len(bmih.struct)
bmih.Width.struct=dx
bmih.Height.struct=dy
bmih.Planes.struct=1
bmih.BitCount.struct=32
p=rect.Bits.struct
calldll #gdi32, "GetDIBits", hdc as long, hcopy as long, 0 as long,_
  dy as long, p as long, bmih as struct, 0 as long, r as long

calldll #gdi32, "DeleteObject", hcopy as long, r as long
struct parm, Level as long
r=CallMethod(LoadTexture8, 17, parm.struct) ' ::UnlockRect
end function

function float(n)
struct temp, v as long
calldll #oleaut32, "VarR4FromR8", n as double, temp as struct, r as void
float=temp.v.struct
end function

function CallMethod(object, method, parm$)
code$=chr$(139)+"D$"+chr$(4)+chr$(139)+"T$"+chr$(8)+chr$(139)+"L$" _
+ chr$(16)+"VW"+chr$(139)+"t$"+chr$(20)+chr$(43)+chr$(225)+chr$(139) _
+ chr$(252)+chr$(243)+chr$(164)+chr$(80)+chr$(139)+chr$(0)+chr$(255) _
+ chr$(20)+chr$(144)+chr$(95)+chr$(94)+chr$(194)+chr$(16)+chr$(0)

p$=parm$
n=len(p$)
calldll #user32, "CallWindowProcA", code$ as ptr, object as long,_
  method as long, p$ as ptr, n as long, CallMethod as long
end function

Richard.
Re: Direct3D demos
Post by RobM on Aug 17th, 2016, 5:55pm

Very nice Richard!

Any chance of demos for basic 3d elements like lines, triangles and quads?
Re: Direct3D demos
Post by Richard Russell on Aug 17th, 2016, 8:52pm

on Aug 17th, 2016, 5:55pm, RobM wrote:
Any chance of demos for basic 3d elements like lines, triangles and quads?

I've only ever used triangles (the other Direct3D primitives are points and lines): the globe in the demo is 2048 triangles. A quadrilateral would be two triangles.

There was a precursor to the rotating globe consisting of a spinning cube which you can still find on the LB Community Forum from back in 2013.

(It's nostalgic to read that thread. Some of the same people who responded positively to my posts at the time now think I'm the spawn of the devil).

There's a BBC BASIC demo of a tumbling pyramid but I'm not enthusiastic about translating it to LB.

Richard.