TheGameCreators - CodeBase - Level Editor (3D)

Return to the CodeBase listing

Category: 3D

Version: 1.0

Information

Uploaded: 11th Jun 2004 02:22

Modified: 1st Jan 1970 01:00

Author: jwurmz

Summary

A level editor I worked on for some time. Right now, it's on hold until further notice. Enjoy!

Full Description

DarkBASIC Professional Source Code

` This code was downloaded from The Game Creators

` It is reproduced here with full permission

` http://www.thegamecreators.com

sync on

sync rate 0

set display mode 800,600,32

make camera 1

set current camera 1

autocam off

randomize timer()

dim todo$(1)

dim junk$(10)

dim junk(10)

dim foundfilesforload$(1024)

dim currentpart(1)=0

dim totalparts(1)=0

dim maxparts(1)=0

dim partnames$(5000)

dim parttype(5000)

dim partscalex(5000)

dim partscaley(5000)

dim partscalez(5000)

dim parttexture$(5000)

dim parttexturescalex(5000)

dim parttexturescaley(5000)

dim parttexturescrollx(5000)

dim parttexturescrolly(5000)

dim allparts(5000)

dim foundtexturesforload$(1024)

dim currenttexture$(1)

dim currenttexture(1)

dim maxtextures(1)

dim viewmode(1)

dim menu$(10,10)

dim menualign(10)

dim dirjunk$(10)

dim actorjunk$(10)

dim actorjunk(10)

dim mousemove_x(1)

dim mousemove_y(1)

dim grid(1)=0

dim quitt(1)=0

dim copy$(10)

dim currentlight(1)

dim lights(8)

dim lightsx(8)

dim lightsy(8)

dim lightsz(8)

dim lightsrx(8)

dim lightsry(8)

dim lightsrz(8)

dim lightsflags(8)

dim lightscolor(7,3)

dim lightsavailable(7)

begin:

dirjunk$(1)=get dir$()

dirjunk$(2)=dirjunk$(1)+"\models"

dirjunk$(3)=dirjunk$(1)+"\textures"

dirjunk$(4)=dirjunk$(1)+"\maps"

startup()

settings("StudioSettings.ini")

if mousey()<25 then filemenu()

if todo$(1)<>"" then dothis(todo$(1))

onscreentext()

checkforinput()

if quitt(1)=1 then exit

loop

rem -------------------------------------------------------------------------

function checkforinput()

cx#=camera angle x(1)

cy#=camera angle y(1)

mousemove_y(1)=mousemovex()

mousemove_x(1)=mousemovey()

if totalparts(1)>0

if scancode()=46 then makecollisionpart()

if scancode()=48 then makestaticbox()

if scancode()=20 then changecurrtexture()

if scancode()=51 then prevpart():unsleep(50)

if scancode()=52 then nextpart():unsleep(50)

if scancode()=61 then savemap():unsleep(500)

if scancode()=47 then changeviewmode()

endif

select scancode()

case 38

shadowon():unsleep(500)

endcase

case 34

grid(1)=grid(1)+1

if grid(1)>2 then grid(1)=0

unsleep(200)

endcase

case 17

move camera .25

endcase

case 31

move camera -.25

endcase

case 45

if totalparts(1)>0

if mouseclick()=1 then movepartx()

if mouseclick()=2 then rotatepartx()

if mouseclick()=3 then scalepartx()

endif

endcase

case 44

if totalparts(1)>0

if mouseclick()=1 then movepartz()

if mouseclick()=2 then rotatepartz()

if mouseclick()=3 then scalepartz()

endif

endcase

case 21

if totalparts(1)>0

if mouseclick()=1 then moveparty()

if mouseclick()=2 then rotateparty()

if mouseclick()=3 then scaleparty()

endif

endcase

case 19

if totalparts(1)>0

if mouseclick()=1 then scaletexture()

if mouseclick()=2 then scrolltexture()

endif

endcase

endselect

if scancode()=211 and totalparts(1)>1 then removepart(allparts(currentpart(1)))

if mouseclick()=4 or scancode()=57

if mousemove_x(1)<>0 then cx#=wrapvalue(cx#+mousemove_x(1))

xrotate camera 1, cx#

if mousemove_y(1)<>0 then cy#=wrapvalue(cy#+mousemove_y(1))

yrotate camera 1, cy#

endif

endfunction

rem -------------------------------------------------------------------------

function changeviewmode()

if viewmode(1)=1

viewmode(1)=2:goto exit020

endif

if viewmode(1)=2

viewmode(1)=3:goto exit020

endif

if viewmode(1)=3

if object exist(allparts(currentpart(1))) then set object allparts(currentpart(1)),1,1,1

viewmode(1)=4:goto exit020

endif

if viewmode(1)=4

if object exist(allparts(currentpart(1))) then set object allparts(currentpart(1)),0,1,1

viewmode(1)=1:goto exit020

endif

exit020:

colorparts()

unsleep(100)

endfunction

rem -------------------------------------------------------------------------

function addpart(parttype)

if totalparts(1)=maxparts(1) then todo$(1)="":exitfunction

if currentpart(1)<=1 then currentpart(1)=1

partname$=junk$(1):partnumber=findavailablepartnumber()

select parttype

case 0

exitfunction

endcase

case 1

type$=".x":partname$=getfileforload(dirjunk$(2),type$):load object partname$,partnumber:partnames$(partnumber)=partname$

endcase

case 2

type$=".3ds":partname$=getfileforload(dirjunk$(2),type$):load object partname$,partnumber:partnames$(partnumber)=partname$

endcase

case 3

make object sphere partnumber,25:partnames$(partnumber)="Sphere"

endcase

case 4

make object box partnumber,25,25,25:partnames$(partnumber)="Box"

endcase

case 5

make object cylinder partnumber,25:partnames$(partnumber)="Cylinder"

endcase

case 6

make object cone partnumber,25:partnames$(partnumber)="Cone"

endcase

case 7

make object plain partnumber,25,25:partnames$(partnumber)="Plane"

endcase

case 8

make object triangle partnumber,0,0,0,25,25,0,25,0,25:partnames$(partnumber)="Triangle"

endcase

case 9

make object sphere partnumber,5:partnames$(partnumber)="Light"

makelights()

endcase

endselect

parttype(partnumber)=1

findallparts():colorparts()

todo$(1)="":

if totalparts(1)=1 then currentpart(1)=1:findallparts():colorparts()

endfunction

function findallparts()

for c=1 to 5000

allparts(c)=0

next c

partnum=1

totalparts(1)=0

for p=1 to 5000

if object exist(p)=1

allparts(partnum)=p

totalparts(1)=totalparts(1)+1

partnum=partnum+1

currentpart(1)=allparts(p)

endif

next p

endfunction

function findavailablepartnumber()

napn=0

for o=1 to maxparts(1)

if object exist(o)=0 then napn=o:goto exit45678

next o

exit45678:

endfunction napn

function removepart(partnumber)

if partnumber<1 or partnumber>5000 then exitfunction

findallparts()

if object exist(partnumber)=1 then delete object partnumber

for l=1 to 7

if lights(l)=partnumber then delete light l

next l

if totalparts(1)>0

for tp=1 to 5000

if object exist(tp)=1 then currentpart(1)=allparts(tp)

next tp

endif

findallparts():colorparts()

unsleep(250)

endfunction

function nextpart()

if totalparts(1)>0

if currentpart(1)<totalparts(1) then currentpart(1)=currentpart(1)+1

for l=1 to 7

if currentpart(1)=lights(l) then currentlight(1)=l

next l

endif

colorparts()

endfunction

function prevpart()

if totalparts(1)>0

if currentpart(1)>1 then currentpart(1)=currentpart(1)-1

for l=1 to 7

if currentpart(1)=lights(l) then currentlight(1)=l

next l

endif

colorparts()

endfunction

function colorparts()

if totalparts(1)>1

select viewmode(1)

case 1

for p=1 to totalparts(1)

if object exist(allparts(p))

set object allparts(p),1,1,1

ghost object on allparts(p)

endif

next p

if object exist(currentpart(1))=1

ghost object off (allparts(currentpart(1)))

endif

endcase

case 2

for p=1 to totalparts(1)

if object exist(allparts(p))=1

set object allparts(p),1,1,1

ghost object off allparts(p)

endif

next p

if currentpart(1)>0

if object exist(allparts(currentpart(1)))=1 then ghost object on (allparts(currentpart(1)))

endif

endcase

case 3

for p=1 to totalparts(1)

if object exist(allparts(p))=1 then set object allparts(p),1,1,1

next p

if currentpart(1)>0

if object exist(allparts(currentpart(1)))=1 then set object allparts(currentpart(1)),0,1,1

endif

endcase

case 4

for p=1 to totalparts(1)

if object exist(allparts(p))=1 then set object allparts(p),0,1,1

next p

if currentpart(1)>0

if object exist(allparts(currentpart(1)))=1 then set object allparts(currentpart(1)),1,1,1

endif

endcase

endselect

endif

endfunction

function dothis(todo$)

select todo$

case "addx"

addpart(1)

endcase

case "add3ds"

addpart(2)

endcase

case "addsphere"

addpart(3)

endcase

case "addbox"

addpart(4)

endcase

case "addcylinder"

addpart(5)

endcase

case "addcone"

addpart(6)

endcase

case "addplane"

addpart(7)

endcase

case "addtriangle"

addpart(8)

endcase

case "addlight"

addpart(9)

endcase

case "applycurrenttexture"

applytexture()

endcase

case "save"

savemap()

endcase

case "open"

type$=".tld"

filename$=getfileforload(dirjunk$(4),type$)

loadmap(filename$)

endcase

case "new"

resetall()

endcase

case "exit"

quit()

endcase

endselect

endfunction

function movepartx()

while mouseclick()=1

onscreentext()

if object exist(currentpart(1))=1 then position object currentpart(1), object position x(currentpart(1))+mousemovex(),object position y(currentpart(1)),object position z(currentpart(1))

if partnames$(currentpart(1))="Light" then repositionlight()

endwhile

endfunction

function moveparty()

while mouseclick()=1

onscreentext()

if object exist(currentpart(1))=1 then position object currentpart(1), object position x(currentpart(1)),object position y(currentpart(1))+mousemovex(),object position z(currentpart(1))

if partnames$(currentpart(1))="Light" then repositionlight()

endwhile

endfunction

function movepartz()

while mouseclick()=1

onscreentext()

if object exist(currentpart(1))=1 then position object currentpart(1), object position x(currentpart(1)),object position y(currentpart(1)),object position z(currentpart(1))+mousemovex()

if partnames$(currentpart(1))="Light" then repositionlight()

endwhile

endfunction

function rotatepartx()

while mouseclick()=2

onscreentext()

if object exist(currentpart(1))=1 then rotate object currentpart(1), wrapvalue(object angle x(currentpart(1))+mousemovex()),object angle y(currentpart(1)),object angle z(currentpart(1))

endwhile

endfunction

function rotateparty()

while mouseclick()=2

onscreentext()

if object exist(currentpart(1))=1 then rotate object currentpart(1), object angle x(currentpart(1)),wrapvalue(object angle y(currentpart(1))+mousemovex()),object angle z(currentpart(1))

endwhile

endfunction

function rotatepartz()

while mouseclick()=2

onscreentext()

if object exist(currentpart(1))=1 then rotate object currentpart(1), object angle x(currentpart(1)),object angle y(currentpart(1)),wrapvalue(object angle z(currentpart(1))+mousemovex()):onscreentext()

endwhile

endfunction

function scalepartx()

if object exist(currentpart(1))=1

s=partscalex(allparts(currentpart(1)))

onscreentext()

if s>1 and mousemove_y(1)<0

scale object currentpart(1),s,partscaley(allparts(currentpart(1))),partscalez(allparts(currentpart(1))):s=s-2

if s<1 then s=1

partscalex(allparts(currentpart(1)))=s

endif

if s<10000 and mousemove_y(1)>0

scale object currentpart(1),s,partscaley(allparts(currentpart(1))),partscalez(allparts(currentpart(1))):s=s+2

if s>10000 then s=10000

partscalex(allparts(currentpart(1)))=s

endif

endfunction

function scaleparty()

if object exist(currentpart(1))=1

s=partscaley(allparts(currentpart(1)))

onscreentext()

if s>1 and mousemove_y(1)<0

scale object currentpart(1),partscalex(allparts(currentpart(1))),s,partscalez(allparts(currentpart(1))):s=s-2

if s<1 then s=1

partscaley(allparts(currentpart(1)))=s

endif

if s<10000 and mousemove_y(1)>0

scale object currentpart(1),partscalex(allparts(currentpart(1))),s,partscalez(allparts(currentpart(1))):s=s+2

if s>10000 then s=10000

partscaley(allparts(currentpart(1)))=s

endif

endfunction

function scalepartz()

if object exist(currentpart(1))=1

s=partscalez(allparts(currentpart(1)))

onscreentext()

if s>1 and mousemove_y(1)<0

scale object currentpart(1),partscalex(allparts(currentpart(1))),partscaley(allparts(currentpart(1))),s:s=s-2

if s<1 then s=1

partscalez(allparts(currentpart(1)))=s

endif

if s<10000 and mousemove_y(1)>0

scale object currentpart(1),partscalex(allparts(currentpart(1))),partscaley(allparts(currentpart(1))),s:s=s+2

if s>10000 then s=10000

partscalez(allparts(currentpart(1)))=s

endif

endfunction

function findalltextures()

d=1

searchdir$=dirjunk$(3)

set dir searchdir$

for clear=0 to 1024

foundtexturesforload$(clear)=""

next clear

find first

repeat

if get file type()=0

texture$=get file name$():maptag$=right$(texture$,4)

endif

if maptag$=".bmp" or maptag$=".BMP"

foundtexturesforload$(d)=texture$:d=d+1

endif

find next

until get file type()=-1

maxtextures(1)=d

if maxtextures(1)>1 then currenttexture$(1)=foundtexturesforload$(1):currenttexture(1)=1

endfunction

function changecurrtexture()

searchdir$=dirjunk$(3)

set dir searchdir$

redo1234:

if upkey()=1 and currenttexture(1)>1

currenttexture(1)=currenttexture(1)-1

endif

if downkey()=1 and currenttexture(1)<maxtextures(1)-1

currenttexture(1)=currenttexture(1)+1

endif

texturestring$=foundtexturesforload$(currenttexture(1)):currenttexture$(1)=foundtexturesforload$(currenttexture(1))

if file exist(currenttexture$(1)) then load image currenttexture$(1),1:paste image 1,1,1:text 1,1,"Current texture: "+texturestring$

onscreentext()

if scancode()=20 then goto redo1234

endfunction

function applytexture()

if totalparts(1)>0 and image exist(1) then texture object allparts(currentpart(1)),1:todo$(1)="":parttexture$(allparts(currentpart(1)))=currenttexture$(1)

endfunction

function scrolltexture()

u#=parttexturescrollx(allparts(currentpart(1))):v#=parttexturescrolly(allparts(currentpart(1)))

onscreentext()

if mousemove_y(1)<0 and u#>1 then u#=u#-.0001

if mousemove_y(1)>0 and u#<2 then u#=u#+.0001

if mousemove_x(1)<0 and v#>1 then v#=v#-.0001

if mousemove_x(1)>0 and v#<2 then v#=v#+.0001

parttexturescrollx(allparts(currentpart(1)))=u#

parttexturescrolly(allparts(currentpart(1)))=v#

scroll object texture allparts(currentpart(1)), u#,v#:onscreentext()

endfunction

function scaletexture()

u#=parttexturescalex(allparts(currentpart(1))):v#=parttexturescaley(allparts(currentpart(1)))

onscreentext()

if mousemove_y(1)<0 and u#>1 then u#=u#-.001

if mousemove_y(1)>0 and u#<50 then u#=u#+.001

if mousemove_x(1)<0 and v#>1 then v#=v#-.001

if mousemove_x(1)>0 and v#<50 then v#=v#+.001

parttexturescalex(allparts(currentpart(1)))=u#

parttexturescaley(allparts(currentpart(1)))=v#

scale object texture allparts(currentpart(1)), u#,v#:onscreentext()

endfunction

function unsleep(ms)

b=timer():e=b+ms

while timer()<e

onscreentext()

endwhile

endfunction

rem -------------------------------------------------------------------------

function onscreentext()

ink rgb(255,255,255),rgb(0,0,0)

if totalparts(1)>0

partinfo1$="":textureinfo1$="":partinfo2$="":textureinfo2$="":partinfo3$="":textureinfo3$="":partinfo4$="":textureinfo4$="":partinfo5$="":textureinfo5$="":limbinfo1$=""

partinfo1$="Part "+str$(currentpart(1))+" of "+str$(totalparts(1))+" selected : "+partnames$(currentpart(1))

partinfo2$=" Offset:"+str$(object position x(allparts(currentpart(1))))+","+str$(object position y(allparts(currentpart(1))))+","+str$(object position z(allparts(currentpart(1))))

partinfo3$=" Rotation:"+str$(object angle x(allparts(currentpart(1))))+"Â°, "+str$(object angle y(allparts(currentpart(1))))+"Â°, "+str$(object angle z(allparts(currentpart(1))))+"Â°"

partinfo4$=" Scale: "+str$(partscalex(allparts(currentpart(1))))+"%, "+str$(partscaley(allparts(currentpart(1))))+"%, "+str$(partscalez(allparts(currentpart(1))))+"%"

else

partinfo1$="No parts in scene."

partinfo2$="Add parts using the"

partinfo3$="menu above."

endif

text 1,508, partinfo1$

text 1,530, partinfo2$

text 1,552, partinfo3$

text 1,574, partinfo4$

if maxtextures(1)>0

textureinfo1$="Texture "+str$(currenttexture(1))+" of "+str$(maxtextures(1)-1)+" in clipboard."

textureinfo2$=" Scroll:"+str$(parttexturescrollx(allparts(currentpart(1))))+","+str$(parttexturescrolly(allparts(currentpart(1))))

textureinfo3$=" Scale:"+str$(parttexturescalex(allparts(currentpart(1))))+","+str$(parttexturescaley(allparts(currentpart(1))))

else

textureinfo1$="No textures found in \Textures folder."

textureinfo2$="Add .bmp textures to this folder."

endif

text 280,508, textureinfo1$

text 280,530, textureinfo2$

text 280,552, textureinfo3$

if currentlight(1)<>0

lightinfo1$="Light "+str$(currentlight(1))+" of 7 selected"

lightinfo2$=" Offset:"+str$(lightsx(currentlight(1)))+","+str$(lightsy(currentlight(1)))+","+str$(lightsx(currentlight(1)))

lightinfo3$=" Color:R"+str$(lightscolor(currentlight(1),1))+"G"+str$(lightscolor(currentlight(1),2))+"B"+str$(lightscolor(currentlight(1),3))

else

lightinfo1$=""

lightinfo2$=""

lightinfo3$=""

endif

text 560,508, lightinfo1$

text 560,530, lightinfo2$

text 560,552, lightinfo3$

if mouseclick()=1

if scancode()=44 then text 1,486,"Moving about Z"

if scancode()=45 then text 1,486,"Moving about X"

if scancode()=21 then text 1,486,"Moving about Y"

endif

if mouseclick()=2

if scancode()=44 then text 1,486,"Rotating about Z"

if scancode()=45 then text 1,486,"Rotating about X"

if scancode()=21 then text 1,486,"Rotating about Y"

endif

if mouseclick()=3

if scancode()=44 then text 1,486,"Scaling about Z"

if scancode()=45 then text 1,486,"Scaling about X"

if scancode()=21 then text 1,486,"Scaling about Y"

endif

if scancode()=59

text 1,464,"FPS:"+str$(screen fps())

endif

sync

endfunction

function savemap()

if totalparts(1)<1 then exitfunction

set dir dirjunk$(4)

filename$="TLD"+str$(rnd(9999))+".tld"

if file exist(filename$)=1 then filename$=filename$+str$(rnd(99999))

open to write 1,filename$

fileattribs$=filename$+" last modified on "+get date$()

write string 1,fileattribs$

write string 1,str$(totalparts(1))

for part=1 to totalparts(1)

if object exist(allparts(part))=1

partname$=partnames$(allparts(part)):if partname$="" then partname$="error"

pn$=str$(allparts(allparts(part)))

oax$=str$(object angle x(allparts(part)))

oay$=str$(object angle y(allparts(part)))

oaz$=str$(object angle z(allparts(part)))

opx$=str$(object position x(allparts(part)))

opy$=str$(object position y(allparts(part)))

opz$=str$(object position z(allparts(part)))

osx$=str$(partscalex(allparts(part)))

osy$=str$(partscaley(allparts(part)))

osz$=str$(partscalez(allparts(part)))

ot$=parttexture$(part):if ot$="" then ot$="none"

otsru$=str$(parttexturescrollx(allparts(part)))

otsrv$=str$(parttexturescrolly(allparts(part)))

otslu$=str$(parttexturescalex(allparts(part)))

otslv$=str$(parttexturescaley(allparts(part)))

partflags$=str$(parttype(allparts(allparts(part))))

write string 1,"#################################################"

write string 1,partname$

write string 1,pn$

write string 1,oax$

write string 1,oay$

write string 1,oaz$

write string 1,opx$

write string 1,opy$

write string 1,opz$

write string 1,osx$

write string 1,osy$

write string 1,osz$

write string 1,ot$

write string 1,otsru$

write string 1,otsrv$

write string 1,otslu$

write string 1,otslv$

write string 1,partflags$

endif

next part

close file 1

todo$(1)=""

set dir dirjunk$(1)

endfunction

function loadmap(filename$)

resetall()

partnum=1

set dir dirjunk$(4)

open to read 1,filename$

read string 1,fileattribs$

read string 1,tp$

tp=val(tp$)

for parts=1 to tp

read string 1,null$

read string 1,partname$:parttype$=partname$

read string 1,pn$:pn=val(pn$)

read string 1,oax$:oax=val(oax$)

read string 1,oay$:oay=val(oay$)

read string 1,oaz$:oaz=val(oaz$)

read string 1,opx$:opx=val(opx$)

read string 1,opy$:opy=val(opy$)

read string 1,opz$:opz=val(opz$)

read string 1,osx$:osx=val(osx$)

read string 1,osy$:osy=val(osy$)

read string 1,osz$:osz=val(osz$)

read string 1,ot$

read string 1,otsru$:otsru=val(otsru$)

read string 1,otsrv$:otsrv=val(otsrv$)

read string 1,otslu$:otslu=val(otslu$)

read string 1,otslv$:otslv=val(otslv$)

read string 1,partflags$

if right$(partname$,2)=".x" then parttype$="X":set dir dirjunk$(2)

if right$(partname$,4)=".3ds" then parttype$="3DS":set dir dirjunk$(2)

select parttype$

case "Sphere"

make object sphere pn,25

endcase

case "Box"

make object box pn,25,25,25

endcase

case "Cylinder"

make object cylinder pn,25

endcase

case "Cone"

make object cone pn,25

endcase

case "Plane"

make object plain pn,25,25

endcase

case "X"

load object partname$,pn

endcase

case "3DS"

load object partname$,pn

endcase

case "Light"

make object sphere pn,5

makelights()

endcase

endselect

partnames$(partnum)=parttype$

allparts(partnum)=pn

parttexturescalex(partnum)=otslu

parttexturescaley(partnum)=otslv

parttexturescrollx(partnum)=otsru

parttexturescrolly(partnum)=otsrv

scale object pn,osx,osy,osz

rotate object pn,oax,oay,oaz

position object pn,opx,opy,opz

if ot$<>"none"

set dir dirjunk$(3)

if image exist(1) then delete image 1

if file exist(ot$) then load image ot$,1:parttexture$(pn)=ot$

texture object pn,1

scale object texture pn,otslu,otslv

scroll object texture pn,otsru,otsrv

endif

partnum=partnum+1

next parts

close file 1

todo$(1)=""

findallparts()

endfunction

function makecollisionpart()

if totalparts(1)>0 and object exist(currentpart(1))=1

parttype(currentpart(1))=2

endif

endfunction

function makestaticbox()

if totalparts(1)>0 and object exist(currentpart(1))=1

parttype(currentpart(1))=3

endif

endfunction

function resetall()

for part=1 to 5000

if object exist(part)=1 then delete object part

next part

todo$(1)=""

settings("StudioSettings.ini")

endfunction

function filemenu()

submenu=0:subsubmenu=0

if mousey()>250 then exitfunction

onscreentext()

mx=mousex()

my=mousey()

ink rgb(0,0,255),rgb(0,0,0)

for textx=1 to 10

text menualign(textx),1,menu$(textx,1)

next textx

if mx>0 and mx<50 then submenu=1

if mx>49 and mx<123 then submenu=2

if mx>122 and mx<196 then submenu=3

if mx>195 and mx<296 then submenu=4

if mx>295 and mx<420 then submenu=5

if mx>419 and mx<800 then submenu=6

if my>(-1) and my<22 then subsubmenu=10

if my>21 and my<44 then subsubmenu=2

if my>43 and my<66 then subsubmenu=3

if my>65 and my<88 then subsubmenu=4

if my>87 and my<110 then subsubmenu=5

if my>119 and my<132 then subsubmenu=6

if my>131 and my<154 then subsubmenu=7

if my>153 and my<176 then subsubmenu=8

if my>175 and my<198 then subsubmenu=9

if my>197 and my<220 then subsubmenu=10

ink rgb(255,255,255),rgb(0,0,0)

for texty=2 to 10

text menualign(submenu),(texty*22)-22,menu$(submenu,texty)

next texty

text menualign(submenu),(subsubmenu*22)-22,menu$(submenu,subsubmenu)

if mouseclick()=1

takeaction(submenu,subsubmenu)

exitfunction

endif

loop

endfunction

function takeaction(submenu,subsubmenu)

select submenu

case 1

if subsubmenu=2 then todo$(1)="new"

if subsubmenu=3 then todo$(1)="open"

if subsubmenu=4 then todo$(1)="save"

if subsubmenu=5 then todo$(1)="exit"

rem if subsubmenu=6 then

rem if subsubmenu=7 then

rem if subsubmenu=8 then

rem if subsubmenu=9 then

rem if subsubmenu=10 then

endcase

case 2

rem if subsubmenu=2 then copy

rem if subsubmenu=3 then paste

rem if subsubmenu=4 then clear

rem if subsubmenu=5 then move

rem if subsubmenu=6 then rotate

rem if subsubmenu=7 then scale

rem if subsubmenu=8 then

rem if subsubmenu=9 then

rem if subsubmenu=10 then

endcase

case 3

if subsubmenu=2 then todo$(1)="addx"

if subsubmenu=3 then todo$(1)="add3ds"

if subsubmenu=4 then todo$(1)="addsphere"

if subsubmenu=5 then todo$(1)="addbox"

if subsubmenu=6 then todo$(1)="addcylinder"

if subsubmenu=7 then todo$(1)="addcone"

if subsubmenu=8 then todo$(1)="addplane"

if subsubmenu=9 then todo$(1)="addtriangle"

if subsubmenu=10 then todo$(1)="addlight"

endcase

case 4

if subsubmenu=2 then todo$(1)="applycurrenttexture"

rem if subsubmenu=3 then remove

rem if subsubmenu=4 then

rem if subsubmenu=5 then

rem if subsubmenu=6 then

rem if subsubmenu=7 then

rem if subsubmenu=8 then

rem if subsubmenu=9 then

rem if subsubmenu=10 then

endcase

case 5

rem if subsubmenu=2 then settings

rem if subsubmenu=3 then set keyframe

rem if subsubmenu=4 then remove keyframe

rem if subsubmenu=5 then

rem if subsubmenu=6 then

rem if subsubmenu=7 then

rem if subsubmenu=8 then

rem if subsubmenu=9 then

rem if subsubmenu=10 then

endcase

case 6

rem if subsubmenu=2 then

rem if subsubmenu=3 then

rem if subsubmenu=4 then

rem if subsubmenu=5 then

rem if subsubmenu=6 then

rem if subsubmenu=7 then

rem if subsubmenu=8 then

rem if subsubmenu=9 then

rem if subsubmenu=10 then

endcase

case 7

rem if subsubmenu=2 then

rem if subsubmenu=3 then

rem if subsubmenu=4 then

rem if subsubmenu=5 then

rem if subsubmenu=6 then

rem if subsubmenu=7 then

rem if subsubmenu=8 then

rem if subsubmenu=9 then

rem if subsubmenu=10 then

endcase

case 8

rem if subsubmenu=2 then

rem if subsubmenu=3 then

rem if subsubmenu=4 then

rem if subsubmenu=5 then

rem if subsubmenu=6 then

rem if subsubmenu=7 then

rem if subsubmenu=8 then

rem if subsubmenu=9 then

rem if subsubmenu=10 then

endcase

case 9

rem if subsubmenu=2 then

rem if subsubmenu=3 then

rem if subsubmenu=4 then

rem if subsubmenu=5 then

rem if subsubmenu=6 then

rem if subsubmenu=7 then

rem if subsubmenu=8 then

rem if subsubmenu=9 then

rem if subsubmenu=10 then

endcase

case 10

rem if subsubmenu=2 then

rem if subsubmenu=3 then

rem if subsubmenu=4 then

rem if subsubmenu=5 then

rem if subsubmenu=6 then

rem if subsubmenu=7 then

rem if subsubmenu=8 then

rem if subsubmenu=9 then

rem if subsubmenu=10 then

endcase

endselect

endfunction

function d2db(decimal)

if decimal<0

sign$="-"

else

sign$="+"

endif

decimal=abs(decimal)

returnbits$=""

31bits$=""

for b=30 to 0 step -1

if decimal>(2^b)-1

bit$="1"

decimal=decimal-(2^b)

else

bit$="0"

endif

31bits$=31bits$+bit$

if sign$="-" then returnbits$="1"+31bits$ else returnbits$="0"+31bits$

next b

endfunction returnbits$

rem This function accepts up to a 32bit binary string (DWORD) and returns a

rem decimal equivalent. MSB determines positive or negative number so output

rem rangeis (-2,147,483,647 to +2,147,483,647). If len(bits$)<32 then binary

rem data is automatically padded up to 32bits.

function db2d(bits$)

total=0

pad$=""

bitlen=len(bits$)

if bitlen>32 then bits$="0": bitlen=1

if bitlen<32

oldbit$=bits$

for pad=1 to (32-bitlen)

pad$=pad$+"0"

next pad

bits$=pad$+oldbit$

bitlen=len(bits$)

endif

if bitlen=32 then stopbit=2 else stopbit=1

for newbit=bitlen to stopbit step -1

bit$=mid$(bits$,newbit)

if bit$="1" then total=total + (2^(bitlen-newbit))

next newbit

if bitlen=32 and mid$(bits$,1)="1" then total=total-(2*total)

endfunction total

rem This function accepts a decimal (0-255) and converts it to an 8bit binary

rem string.

function d2b(decimal)

8bits$=""

for b=7 to 0 step -1

if decimal>(2^b)-1

bit$="1"

decimal=decimal-(2^b)

else

bit$="0"

endif

8bits$=8bits$+bit$

next b

endfunction 8bits$

rem This function accepts an 8bit binary string and converts it to a decimal.

rem (0-255)

function b2d(8bits$)

decimal=0

for b=0 to 7

bit$=mid$(8bits$,8-b)

if bit$="1"

decimal=decimal+(2^b)

else

bit$="0"

endif

next b

endfunction decimal

rem This function accepts a decimal (0-65535) and converts it to a 16bit binary

rem string.

function d2w(decimal)

16bits$=""

for b=15 to 0 step -1

if decimal>(2^b)-1

bit$="1"

decimal=decimal-(2^b)

else

bit$="0"

endif

16bits$=16bits$+bit$

next b

endfunction 16bits$

rem This function accepts a 16bit binary string and converts it to a decimal.

rem (0-65535)

function w2d(16bits$)

decimal=0

for b=0 to 15

bit$=mid$(16bits$,16-b)

if bit$="1"

decimal=decimal+(2^b)

else

bit$="0"

endif

next b

endfunction decimal

function settings(f$)

if file exist(f$)=1

open to read 20,"StudioSettings.ini"

read string 20, dir$

read string 20, partsdir$

read string 20, texturesdir$

read string 20, displayx$

read string 20, displayy$

read string 20, displayz$

read string 20, font$

read string 20, fontsize$

close file 20

endif

menu$(1,1)="File":menu$(1,2)="New":menu$(1,3)="Open":menu$(1,4)="Save":menu$(1,5)="Exit"

menu$(2,1)="Edit":menu$(2,2)="Copy":menu$(2,3)="Paste":menu$(2,4)="Clear"

menu$(3,1)="Part":menu$(3,2)="Add X part":menu$(3,3)="Add 3ds part":menu$(3,4)="Add Sphere":menu$(3,5)="Add Box":menu$(3,6)="Add Cylinder":menu$(3,7)="Add Cone":menu$(3,8)="Add Plane":menu$(3,9)="Add Triangle":menu$(3,10)="Add Light"

menu$(4,1)="Texture":menu$(4,2)="Apply":menu$(4,3)="Remove"

menu$(5,1)="Animation":menu$(5,2)="Settings":menu$(5,3)="Set keyframe":menu$(5,4)="Remove all keyframes":menu$(5,5)="Save animation":menu$(5,6)="Append animation"

menu$(6,1)="Help":menu$(6,2)="Contents":menu$(6,3)="Register":menu$(6,4)="About"

menualign(1)=1: menualign(2)=70: menualign(3)=140: menualign(4)=210: menualign(5)=310: menualign(6)=440:

for ss=1 to 5000

partscalex(ss)=100

partscaley(ss)=100

partscalez(ss)=100

parttexturescalex(ss)=1

parttexturescaley(ss)=1

parttexturescrollx(ss)=1

parttexturescrolly(ss)=1

next ss

viewmode(1)=1

randomize timer()

autocam off

totalparts(1)=0

maxparts(1)=5000

position camera 0,0,-100

x=val(displayx$)

y=val(displayy$)

z=val(displayz$)

set text font font$

set text size val(fontsize$)

sync on

sync rate 0

backdrop on

randomize timer()

ink rgb(255,255,0),rgb(0,0,0)

color backdrop rgb(0,0,0)

findalltextures()

changecurrtexture()

endfunction

function getfileforload(dir$,type$)

tl=len(type$)

set dir dir$

d=1

for clear=0 to 1024

foundfilesforload$(clear)=""

next clear

find first

repeat

if get file type()=0

temp$=get file name$()

maptag$=right$(temp$,tl)

endif

if maptag$=type$

foundfilesforload$(d)=temp$

d=d+1

endif

find next

until get file type()=-1

max=d

ink rgb(255,255,0),rgb(0,0,0)

d=1

repeat

if upkey()=1 and d>1

d=d-1:sleep 200

cls

rem while upkey()=1:endwhile

endif

if downkey()=1 and d<max-1

d=d+1:sleep 200

cls

rem while downkey()=1:endwhile

endif

loadstring$="Load "+chr$(40)+type$+chr$(41)+" file : "+foundfilesforload$(d)

text 1,23,loadstring$

sync

until returnkey()=1

selectedfile$=foundfilesforload$(d)

endfunction selectedfile$

function quit()

for p=1 to maxparts(1)

if object exist(p)=1 then delete object p

next p

quitt(1)=1

endfunction

rem function copy(currentpart(1))

rem copy$(nextcopy()))

rem endfunction

function msgbox()

endfunction

function makelights()

nav=0

for l=7 to 1 step -1

if light exist(l)=0 then lightsavailable(l)=1:nav=l

next l

if nav<>99

if nav<>0 then make light nav

findallparts():colorparts()

lights(nav)=currentpart(1)

currentlight(1)=nav

lightscolor(currentlight(1),1)=rnd(255)

lightscolor(currentlight(1),2)=rnd(255)

lightscolor(currentlight(1),3)=rnd(255)

color light nav,lightscolor(currentlight(1),1),lightscolor(currentlight(1),2),lightscolor(currentlight(1),3)

endif

endfunction

function shadowon()

set shadow shading on currentpart(1)

endfunction

function repositionlight()

lightsx(currentlight(1))=object position x(currentpart(1))

lightsy(currentlight(1))=object position y(currentpart(1))

lightsz(currentlight(1))=object position z(currentpart(1))

position light currentlight(1), lightsx(currentlight(1)),lightsy(currentlight(1)),lightsz(currentlight(1))

endfunction

remstart

function packfiles()

open to write 1,"archive.pak"

AddToFile("img1.jpg")

AddToFile("img2.jpg")

AddToFile("img3.jpg")

AddToFile("img4.jpg")

AddToFile("img5.jpg")

close file 1

open to read 1,"archive.pak"

GetFile("image1.jpg")

GetFile("image2.jpg")

close file 1

endfunction

function AddToFile(Name$)

open to read 2,Name$

make memblock from file 1,2

write memblock 1,1

delete memblock 1

close file 2

endfunction

function GetFile(Name$)

read memblock 1,1

open to write 2,Name$

make file from memblock 2,1

delete memblock 1

close file 2

endfunction

remend

function startup()

homedir$=dirjunk$(1)

set dir homedir$

if file exist("TLDLevelEdit.ini")=0 then buildini()

endfunction

function buildini()

text 1,1,"TLDLevelEdit.ini is not present or is corrupt in the home directory. Rebuilding now":sync

open to write 1,"TLDLevelEdit.ini"

write string 1,";The Lone Danger - Level Editor"

write string 1,";This program is freeware, so enjoy!"

write string 1,""

cgc$=";Display info for : "+current graphics card$()

write string 1,cgc$

perform checklist for display modes

nummodes=checklist quantity()

text 15,1,"Checking your graphics card...":sync

for mode=1 to nummodes

mode$=checklist string$(mode)

width=checklist value a(mode)

height=checklist value b(mode)

depth=checklist value c(mode)

avm$=";mode "+str$(mode)+" : "+mode$

write string 1,avm$

next mode

rem for chopstring=1 to len(mode$)

rem if mid$(mode$)="x" then

rem set display mode

close file 1

endfunction

Download

Please login to download

Comments

No comments yet.

Author Name:	jwurmz
CodeBase Entries:	3

CodeBase - Level Editor (3D)

Information

Summary

Full Description

DarkBASIC Professional Source Code

Download

Screen Shot

Author

Comments