' 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