I have been experimenting with memblocks and wanted to see if it was possible to make a 3d modeller in DBPro.
In this example, it makes a cube entirely with of memblocks. If you know how, you can make other objects with the data statements at the bottom. You can then select vertices, move them around, and color them. You cannot add vertices (yet). It's a bit buggy, but it works.
Mouse: Left click to (de)select vertices. Middle to move camera.
Up/Down: Move selected vertices
Control/Shift/Enter: Combined with left/right to change selected vertex colors.
Enjoy
[Edit]
Ignore the source button, use this code:
Remstart
DBPro modeller example.
Shows how a 3D modeller can be made using
memblocks with native DBPro commands Enjoy!
By Andrew11
Special thanks to kevil and Mikko
Remend
sync on
Sync rate 60
Set ambient light 50
Autocam off
rem the coordinates
read verts
Dim tcoor#(verts,3)
Dim verti(verts)
rem find shared verts
For coord = 0 To verts-1
read tempx#: read tempy#: read tempz#
For verta = 0 To sharedverts
If tcoor#(verta,1) = tempx# and tcoor#(verta,2) = tempy# and tcoor#(verta,3) = tempz#
verti(coord)=verta
Goto skpvert
Endif
Next verta
inc sharedverts
verti(coord)=sharedverts
tcoor#(sharedverts,1)= tempx#
tcoor#(sharedverts,2) = tempy#
tcoor#(sharedverts,3) = tempz#
skpvert:
Next coord
Rem put good coordinates in a seperate array
dim coor#(sharedverts,3)
For coord = 0 To sharedverts
coor#(coord,1) = tcoor#(coord,1)
coor#(coord,2) = tcoor#(coord,2)
coor#(coord,3) = tcoor#(coord,3)
Next coord
Undim tcoor#(0)
Rem make spheres to show verticies
For obj = 0 TO sharedverts
Make object sphere obj+2,2
Color object obj+2,0
Next obj
rem the color/colour
Dim vertcolor(sharedverts)
rem the normals
`Not used (for now)
rem vert selection
Dim vertselect(sharedverts)
Rem the memblock
Rem header
make memblock 1,(verts*36)+12:` Make memblock the right size
write memblock dword 1,0,338:` FVF format, normally 338
write memblock dword 1,4,36:` FVF size (36 bytes)
write memblock dword 1,8,verts
Rem temporary mesh and object
make mesh from memblock 1,1
make object 1,1,0
camz = -150
Rem loop
Disable escapekey
While escapekey() = 0
for vert = 0 To verts-1
rem write the memblock
rem coordinates
write memblock float 1,12+(36*vert),coor#(verti(vert),1): `X
write memblock float 1,16+(36*vert),coor#(verti(vert),2): `Y
write memblock float 1,20+(36*vert),coor#(verti(vert),3): `Z
rem normals
write memblock float 1,24+(36*vert),0.0
write memblock float 1,28+(36*vert),0.0
write memblock float 1,32+(36*vert),-1.0
rem vertex colors
write memblock dword 1,36+(36*vert),-vertcolor(verti(vert))
rem UV texture coords
`write memblock float 1,40+(36*vert),0.00
`write memblock float 1,44+(36*vert),0.00
Next vert
rem change the mesh with the memblock
change mesh from memblock 1,1
rem change the object with this mesh
delete object 1
make object 1,1,0
move = upkey()-downkey()
For shared = 0 TO sharedverts
Position object shared+2,coor#(shared,1),coor#(shared,2),coor#(shared,3)
If vertselect(shared) = 1
color object shared+2, RGB(255,0,0)
coor#(shared,1)=coor#(shared,1)+(coor#(shared,1)/(abs(coor#(shared,1))+.001))*move
coor#(shared,2)=coor#(shared,2)+(coor#(shared,2)/(abs(coor#(shared,2))+.001))*move
coor#(shared,3)=coor#(shared,3)+(coor#(shared,3)/(abs(coor#(shared,3))+.001))*move
vertcolor(shared) = RGB(255-currr,255-currg,255-currb)
Text object screen x(shared+2),object screen y(shared+2), STR$(shared+2)
Else
color object shared+2, RGB(0,0,0)
Endif
Next shared
If spacekey() Then For shared = 0 TO sharedverts :vertselect(shared) = 0: Next shared
If mouseclick()=1
vselect = obj2mous(2,sharedverts+2)-2
vertselect(vselect)= 1 - (vertselect(vselect))
Wait 100
Endif
Text 1,1,"Click to select/deselect vertex "+STR$(obj2mous(2,sharedverts+2))
Rem
If mouseclick() = 4 Then Wait 100: cammode = 2
While cammode = 2
If mouseclick() = 1 Then Wait 100: cammode = 1
camy=camy+ mousemovey()
camx=camx- mousemovex()
zoom=zoom- mousemovez()/10
Position camera 0,zoom*cos(camx),zoom*cos(camy),zoom*sin(camx)
Point camera 0,0,0,0
Sync
Endwhile
Rem
If controlkey() Then currr = currr - leftkey()+rightkey()
If returnkey() Then currg = currg - leftkey()+rightkey()
If shiftkey() Then currb = currb - leftkey()+rightkey()
Text 1,10,"Current Color/colour: Red: "+STR$(currr)+", Green: "+STR$(currg)+", Blue: "+STR$(currb)
Position camera 0,zoom*cos(camx),zoom*cos(camy),zoom*sin(camx)
Point camera 0,0,0,0
sync
Endwhile
Delete memblock 1
Delete mesh 1
unDim tcoor#(verts,3)
unDim verti(verts)
unDim vertcolor(sharedverts)
unDim vertselect(sharedverts)
For obj = 1 To 10000
If object exist(obj)= 0 then exit
Delete object obj
Next obj
Flush video memory
End
rem object cube has 36 Verts, 12 Polys
Data 36: `Number of verts
Data -5,5,-5
Data 5,5,-5
Data 5,-5,-5
Data 5,-5,-5
Data -5,-5,-5
Data -5,5,-5
Data -5,5,5
Data -5,-5,5
Data 5,-5,5
Data 5,-5,5
Data 5,5,5
Data -5,5,5
Data -5,5,5
Data 5,5,5
Data 5,5,-5
Data 5,5,-5
Data -5,5,-5
Data -5,5,5
Data -5,-5,5
Data -5,-5,-5
Data 5,-5,-5
Data 5,-5,-5
Data 5,-5,5
Data -5,-5,5
Data 5,5,-5
Data 5,5,5
Data 5,-5,5
Data 5,-5,5
Data 5,-5,-5
Data 5,5,-5
Data -5,5,-5
Data -5,-5,-5
Data -5,-5,5
Data -5,-5,5
Data -5,5,5
Data -5,5,-5
function obj2mous(first,last)
Rem by mikko - thanks
mx=mousex()
my=mousey()
neardist#=10000
for f=first to last
ox=OBJECT SCREEN X(f)
oy=OBJECT SCREEN y(f)
dist#=sqrt((mx-ox)^2+(my-oy)^2)
if dist#<neardist# then nearest=f:neardist#=dist#
next f
endfunction nearest
"All programmers are playwrites and all computers are lousy actors" -Anon
Click Here!!!