There are many artists among us , and i am looking forward to see your creations using Jolly modeller
Roger created a bunch of 3d models with that. 8)
'Jolly Modeller
'Jolly Roger December 2003
AUTODEFINE "OFF"
IF GETDXVERSION < 7
MESSAGEBOX 0,"This program requires" + CHR$(13) + "DirectX 7.0 or greater","Error"
END
ENDIF
DECLARE "kernel32",GetTickCount(),INT
DECLARE modeller_object()
'Code to set up polypolyline for drawing grid quickly
'Adapted from code from Vikki's IBasic SAQ website
DECLARE "gdi32",PolyPolyline(hdc:INT,points:MEMORY,pointsperpolyline:MEMORY,numberofpolylines:INT),INT
TYPE point
DEF x:INT
DEF y:INT
ENDTYPE
DEF pnt:point
DEF points:MEMORY
ALLOCMEM points,124,8
DEF pointsperpolyline,ln:INT
DEF pppls:MEMORY
DEF hdc:INT
ALLOCMEM pppls,62,4
'Set number of points for each polyline to 2
pointsperpolyline=2
FOR ln= 1 TO 62
WRITEMEM pppls,ln,pointsperpolyline
NEXT ln
DEF win:WINDOW
DEF error,run,lastframetime,timesincelastframe:INT
DEF angle,orient[6],screenmult,gridspacing,g:FLOAT
DEF scene,camera,light,shape[2],yaxispivot:INT
DEF textheight,textwidth,usablewidth,windowheight,halfwidth,windowwidth,usableheight,textspacing:INT
DEF numberoflayers,numberofsections,numberofvertices,normal:INT
DEF vertex[1600],vertexx[1600],vertexz[1600],x[2,2,100],xcentre,zcentre,xradius,zradius,layery[100]:INT
DEF facedata[100],selectedlayer,currentshape,view,colour:INT
DEF front,side,left,right:INT
DEF mousex,mousey,leftbuttondown,rightbuttondown,lastmousex,lastmousey:INT
DEF dx,dy,v,vertexnumber,layer,section,absdy,minabsdy:INT
DEF runningfullscreen,colouringmode,layerclickedon,gotorientation,shapealtered:INT
DEF colourboxbackground,redbarleft,greenbarleft,bluebarleft,transbarleft:INT
DEF colourboxtop,colourboxleft,colourboxheight,colourboxwidth,squaresize,halfsquaresize:INT
DEF uppersquarestop,lowersquarestop,bartop,barheight:INT
DEF squareleft[8],squaretop[8],red[8],green[8],blue[8],trans[8],layercolournumber[100]:INT
DEF clickedonlayer,currentcolournumber:INT
DEF character:STRING
CONST front=0
CONST side=1
CONST left=0
CONST right=1
numberofsections=16
createinitialobjectdata
'Open a 600x400 window and maximise it
WINDOW win,0,0,600,400,@MAXIMIZED|@MAXBOX,0,"",mainwindow
'Find size of maximised window
GETSIZE win,v,v,v,windowheight
GETSCREENSIZE windowwidth,v
'Close 600x400 window and create window the size of the maximised window
CLOSEWINDOW win
'Wait until window properly closed before reopening to avoid potential problems
'(tip from post by Bluesteel)
WAITUNTIL win=0
WINDOW win,0,0,windowwidth,windowheight,@NOAUTODRAW|@MINBOX,0,"Jolly Modeller",mainwindow
'Find width of usable area
GETCLIENTSIZE win,v,v,usablewidth,usableheight
'Create a 3D screen
error=CREATE3DSCREEN(win,usablewidth,usableheight)
IF error
'Can't run windowed D3D.Try opening fullscreen with
'captionless window (so mouse coords not messed up)
CLOSEWINDOW win
WAITUNTIL win=0
usablewidth=640:usableheight=480
runningfullscreen=1
WINDOW win,0,0,usablewidth,windowheight,@NOAUTODRAW|@NOCAPTION,0,"",mainwindow
error=CREATE3DSCREEN(win,usablewidth,usableheight,16)
IF error
MESSAGEBOX win,"Cannot open Direct3D screen","Oops"
END
ENDIF
ENDIF
gridspacing=usablewidth/64:screenmult=usablewidth/640:halfwidth=usablewidth/2
'Set coordinates of points in grid lines so
'can quickly draw them using PolyPolyline API call
g=gridspacing
FOR ln=1 TO 124 STEP 4
'Set x and y for first point in vertical line
pnt.x=g:pnt.y=0
WRITEMEM points,ln,pnt
'Set x and y for second point in vertical line
pnt.x=g:pnt.y=halfwidth
WRITEMEM points,ln+1,pnt
'Set x and y for first point in horizontal line
pnt.x=0:pnt.y=g
WRITEMEM points,ln+2,pnt
'Set x and y for first point in horizontal line
pnt.x=halfwidth:pnt.y=g
WRITEMEM points,ln+3,pnt
g=g+gridspacing
NEXT ln
setfontsize
'Set up colour box positions
colourboxtop=halfwidth+1.6*textspacing:colourboxleft=10
colourboxheight=usableheight-(halfwidth+2*textspacing)
squaresize=colourboxheight/7:halfsquaresize=squaresize/2:barheight=squaresize*4
colourboxwidth=squaresize*5.25
redbarleft=colourboxleft+halfsquaresize/2
greenbarleft=colourboxleft+1.5*squaresize
bluebarleft=colourboxleft+2.75*squaresize
transbarleft=colourboxleft+4*squaresize
bartop=colourboxtop+halfsquaresize/2
uppersquarestop=bartop+4.25*squaresize
lowersquarestop=bartop+5.5*squaresize
squareleft=redbarleft,greenbarleft,bluebarleft,transbarleft,redbarleft,greenbarleft,bluebarleft,transbarleft
squaretop=uppersquarestop,uppersquarestop,uppersquarestop,uppersquarestop,lowersquarestop,lowersquarestop,lowersquarestop,lowersquarestop
setup3D
lastframetime=GetTickCount()-1
run=1
'Process messages until somebody closes us
WAITUNTIL run=0
FREEMEM points
FREEMEM pppls
closethewindow
DELETEFILE(GETSTARTPATH+"temporary.x")
END
SUB mainwindow
SELECT @CLASS
CASE @IDDXUPDATE
'Find time since last frame to make things run at a constant speed
timesincelastframe=GetTickCount()-lastframetime
IF timesincelastframe>2
lastframetime=GetTickCount()
angle=timesincelastframe/800
'The object can be rotated using the arrow keys
'Up arrow
IF(GETKEYSTATE(0x26))
D3DCOMMAND shape[currentshape],@ADDROTATION,1,0,0,angle
ENDIF
'Down arrow
IF(GETKEYSTATE(0x28))
D3DCOMMAND shape[currentshape],@ADDROTATION,1,0,0,-angle
ENDIF
'Left arrow
IF(GETKEYSTATE(0x25))
D3DCOMMAND yaxispivot,@ADDROTATION,0,1,0,angle
ENDIF
'Right arrow
IF(GETKEYSTATE(0x27))
D3DCOMMAND yaxispivot,@ADDROTATION,0,1,0,-angle
ENDIF
'Render the scene to the DirectX surface
D3DRENDER scene,camera
'Add any 2D elements after the scene is rendered
IF colouringmode
RECT win,0,0,halfwidth,halfwidth+1,0,0
ELSE
RECT win,0,0,halfwidth,halfwidth+1,0xFFFFFF,0xFFFFFF
drawgridlines
ENDIF
RECT win,0,halfwidth+1,usablewidth,usableheight-halfwidth,0xFF00C0,0xFF00C0
drawoutline
printtext
'Show the DirectX surface
DXFLIP win,0,0
ENDIF
CASE @IDMOUSEMOVE
IF colouringmode=0
leftbuttondown=0:rightbuttondown=0
IF (GETKEYSTATE(32) & GETKEYSTATE(32))=0
'Spacebar is not pressed
IF (GETKEYSTATE(1) & GETKEYSTATE(1)) THEN leftbuttondown=1
IF (GETKEYSTATE(2) & GETKEYSTATE(2)) THEN rightbuttondown=1
mousex=@MOUSEX/screenmult:mousey=@MOUSEY/screenmult
IF leftbuttondown & rightbuttondown=0
'Only left button down.Move selected layer
movelayer
ENDIF
IF leftbuttondown=0 & rightbuttondown
'Only right button down
scalelayer
ENDIF
ENDIF
lastmousex=mousex:lastmousey=mousey
ENDIF
CASE @IDKEYDOWN
IF @CODE=0x1B
'Esc key pressed
run=0
ENDIF
IF @CODE=0x2E & colouringmode=0
'Delete key pressed
IF numberoflayers>2 THEN deleteselectedlayer
ENDIF
CASE @IDCHAR
character=UCASE$(CHR$(@CODE))
IF colouringmode=0
SELECT character
CASE "A"
IF layery[selectedlayer]<=156 & colouringmode=0
'Selected layer isn't too close to top of screen
'Add new layer above selected layer
addnewlayer
ENDIF
CASE "X"
IF runningfullscreen THEN closethewindow
saveasxfile
IF runningfullscreen
'Recreate window
WINDOW win,0,0,usablewidth,usableheight,@NOAUTODRAW|@NOCAPTION,0,"",mainwindow
CREATE3DSCREEN(win,usablewidth,usableheight,16)
setfontsize
setup3D
ENDIF
CASE "L"
'If running fullscreen-need to close window so load box visible
IF runningfullscreen THEN closethewindow
loadobject
IF runningfullscreen
'Recreate window
WINDOW win,0,0,usablewidth,windowheight,@NOAUTODRAW|@NOCAPTION,0,"",mainwindow
CREATE3DSCREEN(win,usablewidth,usableheight,16)
setfontsize
setup3D
ELSE
'Recreate the object
D3DDELETE shape[currentshape]
currentshape=1-currentshape
shape[currentshape]=modeller_object()
updatenormals
selectedlayer=numberoflayers-1
ENDIF
CASE "I"
IF runningfullscreen THEN closethewindow
saveasIBasicsubroutine
IF runningfullscreen
'Recreate window
WINDOW win,0,0,usablewidth,windowheight,@NOAUTODRAW|@NOCAPTION,0,"",mainwindow
CREATE3DSCREEN(win,usablewidth,usableheight,16)
setfontsize
setup3D
ENDIF
CASE "N"
IF GETKEYSTATE(32) & GETKEYSTATE(32)
createinitialobjectdata
D3DDELETE shape[currentshape]
currentshape=1-currentshape
shape[currentshape]=modeller_object()
updatenormals
ENDIF
ENDSELECT
ENDIF
SELECT character
CASE "F"
view=front
CASE "M"
'Toggle colouring mode
colouringmode=1-colouringmode
CASE "S"
view=side
ENDSELECT
CASE @IDCLOSEWINDOW
run=0
CASE @IDLBUTTONUP
CASE @IDRBUTTONUP
IF shapealtered
updatenormals
shapealtered=0
ENDIF
CASE @IDRBUTTONDN
lastmousex=@MOUSEX/screenmult:lastmousey=@MOUSEY/screenmult
CASE @IDLBUTTONDN
IF colouringmode THEN checkforclickoncolourbox
mousex=@MOUSEX/screenmult:mousey=@MOUSEY/screenmult
lastmousex=mousex:lastmousey=mousey:clickedonlayer=0
'Check to see if clicked on layer
minabsdy=10000
FOR layer=0 TO numberoflayers-1
IF mousex>=x[view,left,layer] & mousex<=x[view,right,layer]
absdy=ABS(mousey-(160-layery[layer]))
IF absdy<gridspacing
IF absdy<minabsdy
layerclickedon=layer:minabsdy=absdy:clickedonlayer=1
ENDIF
ENDIF
ENDIF
NEXT layer
IF GETKEYSTATE(32) & GETKEYSTATE(32)
'Space bar is down.If layer has been clicked on then select this layer
IF clickedonlayer THEN selectedlayer=layerclickedon
ENDIF
IF colouringmode & clickedonlayer
'Colour the layer clicked on
layercolournumber[layerclickedon]=currentcolournumber
colour=layercolournumber[layerclickedon]
IF layerclickedon<>numberoflayers-1
'Layer is not top one.Colour faces above layer
FOR section=0 TO numberofsections-1
D3DCOMMAND shape[currentshape],@SETFACECOLOR,(layerclickedon*numberofsections+section),red[colour]/255,green[colour]/255,blue[colour]/255,1-trans[colour]/255
NEXT section
ELSE
'Clicked on top layer-colour top face
D3DCOMMAND shape[currentshape],@SETFACECOLOR,((numberoflayers-1)*numberofsections),red[colour]/255,green[colour]/255,blue[colour]/255,1-trans[colour]/255
ENDIF
IF layerclickedon=0
'Clicked on bottom layer-colour bottom face
D3DCOMMAND shape[currentshape],@SETFACECOLOR,((numberoflayers-1)*numberofsections+1),red[colour]/255,green[colour]/255,blue[colour]/255,1-trans[colour]/255
ENDIF
ENDIF
ENDSELECT
RETURN
SUB updatenormals
'Save shape without normals and reload.DirectX will calculate the normals
'Get orientation of shape if not already got it
IF gotorientation=0 THEN D3DCOMMAND shape[currentshape],@GETORIENTATION,scene,orient
D3DCOMMAND shape[currentshape],@SAVESHAPE,GETSTARTPATH+"temporary.x",@FORMATTEXT,@SAVEMATERIALS
D3DDELETE shape[currentshape]
'Create new shape with different variable to hold handle because can cause problems
'if re-use same variable
currentshape=1-currentshape
shape[currentshape]=D3DSHAPE(yaxispivot,@SHAPECUSTOM)
D3DCOMMAND shape[currentshape],@LOADSHAPE,GETSTARTPATH+"temporary.x",0
'Set orientation
D3DCOMMAND shape[currentshape],@SETORIENTATION,scene,orient[0],orient[1],orient[2],orient[3],orient[4],orient[5]
gotorientation=0
RETURN
SUB drawoutline
MOVE win,screenmult*x[view,left,0],screenmult*(160-layery[0])
FOR layer=1 TO numberoflayers-1
IF colouringmode
colour=layercolournumber[layer-1]
FRONTPEN win,RGB(red[colour],green[colour],blue[colour])
ENDIF
LINE win,screenmult*x[view,left,layer],screenmult*(160-layery[layer])
NEXT layer
FOR layer=numberoflayers-1 TO 0 STEP -1
IF colouringmode
colour=layercolournumber[layer]
FRONTPEN win,RGB(red[colour],green[colour],blue[colour])
ENDIF
LINE win,screenmult*x[view,right,layer],screenmult*(160-layery[layer])
NEXT layer
LINE win,screenmult*x[view,left,0],screenmult*(160-layery[0])
'Draw horizontal lines
FRONTPEN win,0
FOR layer=0 TO numberoflayers-1
IF colouringmode
colour=layercolournumber[layer]
colour=RGB(red[colour],green[colour],blue[colour])
ENDIF
LINE win,screenmult*x[view,left,layer],screenmult*(160-layery[layer]),screenmult*x[view,right,layer],screenmult*(160-layery[layer]),colour
NEXT layer
IF colouringmode=0
'Draw red line for selected layer
LINE win,screenmult*x[view,left,selectedlayer],screenmult*(160-layery[selectedlayer]),screenmult*x[view,right,selectedlayer],screenmult*(160-layery[selectedlayer]),255
ENDIF
RETURN
SUB saveasIBasicsubroutine
DEF textfile:FILE
DEF textline,textline2,textline3,textline4,filename:STRING
DEF onecolourused:INT
filename=FILEREQUEST("Save as text file",win,0,"Jolly modeller text files|*.jmo.txt||",".jmo.txt")
error=OPENFILE(textfile,filename,"W")
IF error=0
textline="d="
WRITE(textfile,"SUB readdata")
WRITE(textfile,"numberoflayers="+LTRIM$(STR$(numberoflayers)))
FOR layer=0 TO numberoflayers-1
textline=textline+LTRIM$(STR$(layery[layer]))+","
textline=textline+LTRIM$(STR$(x[front,left,layer]))+","+LTRIM$(STR$(x[front,right,layer]))
textline=textline+","+LTRIM$(STR$(x[side,left,layer]))+","+LTRIM$(STR$(x[side,right,layer]))
IF layer%4=3
WRITE(textfile,textline)
textline="d["+LTRIM$(STR$(layer*5+5))+"]="
ELSE
IF layer<>numberoflayers-1
textline=textline+","
ENDIF
ENDIF
NEXT layer
IF RIGHT$(textline,1)<>"="
'Is data in textline so save it
WRITE(textfile,textline)
ENDIF
'Save colour data
'Find out whether more than one colour used
onecolourused=1:colour=layercolournumber[0]
FOR layer=0 TO numberoflayers-1
IF layercolournumber[layer]<>colour
onecolourused=0:layer=numberoflayers-1
ENDIF
NEXT layer
IF onecolourused
WRITE (textfile,"r="+LTRIM$(STR$(red[colour]))+",-1:g="+LTRIM$(STR$(green[colour]))+":b="+LTRIM$(STR$(blue[colour]))+":t="+LTRIM$(STR$(trans[colour])))
ELSE
'More than one colour used.Need to save colour number for each layer
'and red,green and blue values for each colour
textline="lcn="
FOR layer=0 TO numberoflayers-1
textline=textline+LTRIM$(STR$(layercolournumber[layer]))
IF layer%30=29
'Thirty layer colour numbers in textline.Save to file
WRITE (textfile,textline)
textline="lcn["+LTRIM$(STR$(layer+1))+"]="
ELSE
IF layer<>numberoflayers-1 THEN textline=textline+","
ENDIF
NEXT layer
IF RIGHT$(textline,1)<>"="
'Textline contains data so save it
WRITE (textfile,textline)
ENDIF
'Write red,green,blue and transparency values for each colour
textline="r=":textline2="g=":textline3="b=":textline4="t="
FOR colour=0 TO 7
textline=textline+LTRIM$(STR$(red[colour]))
textline2=textline2+LTRIM$(STR$(green[colour]))
textline3=textline3+LTRIM$(STR$(blue[colour]))
textline4=textline4+LTRIM$(STR$(trans[colour]))
IF colour<>7
textline=textline+",":textline2=textline2+","
textline3=textline3+",":textline4=textline4+","
ENDIF
NEXT colour
WRITE (textfile,textline):WRITE (textfile,textline2)
WRITE (textfile,textline3):WRITE (textfile,textline4)
ENDIF
WRITE(textfile,"RETURN")
CLOSEFILE textfile
ENDIF
RETURN
SUB movelayer
'Find distance mouse moved in x and y directions
dx=mousex-lastmousex:dy=lastmousey-mousey
IF layery[selectedlayer]+dy>=-160 & layery[selectedlayer]+dy<=160
'Layer won't move off top or bottom of outline area
IF x[view,left,selectedlayer]+dx>=0 & x[view,right,selectedlayer]+dx<=320
'Layer won't move off sides of outline area
'Alter outline
layery[selectedlayer]=layery[selectedlayer]+dy
x[view,left,selectedlayer]=x[view,left,selectedlayer]+dx
x[view,right,selectedlayer]=x[view,right,selectedlayer]+dx
'Alter object-move vertices in selected layer
FOR v=numberofsections*selectedlayer TO (numberofsections*selectedlayer+numberofsections-1)
IF view=front
vertexx[v]=vertexx[v]+dx
ELSE
vertexz[v]=vertexz[v]+dx
ENDIF
D3DCOMMAND shape[currentshape],@SETVERTEX,vertex[v],vertexx[v],layery[selectedlayer],vertexz[v]
NEXT v
shapealtered=1
ENDIF
ENDIF
RETURN
SUB scalelayer
'Find distance mouse moved in x and y directions
dx=mousex-lastmousex:dy=lastmousey-mousey
IF x[view,left,selectedlayer]-dx>=0 & x[view,right,selectedlayer]+dx<=320
'No part of layer will be moved off sides of outline area
IF x[view,left,selectedlayer]-dx<=x[view,right,selectedlayer]+dx-5
'Left and right sides of layer don't get too close
'Alter outline
x[view,left,selectedlayer]=x[view,left,selectedlayer]-dx
x[view,right,selectedlayer]=x[view,right,selectedlayer]+dx
IF GETKEYSTATE(0x11) & GETKEYSTATE(0x11)
'Ctrl key pressed.Scale both front and side views
IF x[1-view,left,selectedlayer]-dx>=0 & x[1-view,right,selectedlayer]+dx<=320
'No part of layer will be moved off sides of outline area
IF x[1-view,left,selectedlayer]-dx<=x[1-view,right,selectedlayer]+dx-5
'Left and right sides of layer get too close
x[1-view,left,selectedlayer]=x[1-view,left,selectedlayer]-dx
x[1-view,right,selectedlayer]=x[1-view,right,selectedlayer]+dx
ENDIF
ENDIF
ENDIF
'Alter object-scale vertices in selected layer
FOR section=0 TO numberofsections-1
angle=6.283*section/numberofsections
xcentre=-160+(x[front,left,selectedlayer]+x[front,right,selectedlayer])/2
zcentre=-160+(x[side,left,selectedlayer]+x[side,right,selectedlayer])/2
xradius=(x[front,right,selectedlayer]-x[front,left,selectedlayer])/2
zradius=(x[side,right,selectedlayer]-x[side,left,selectedlayer])/2
vertexnumber=selectedlayer*numberofsections+section
vertexx[vertexnumber]=xcentre+xradius*SIN(angle):vertexz[vertexnumber]=zcentre+zradius*COS(angle)
D3DCOMMAND shape[currentshape],@SETVERTEX,vertex[vertexnumber],vertexx[vertexnumber],layery[selectedlayer],vertexz[vertexnumber]
NEXT section
shapealtered=1
ENDIF
ENDIF
RETURN
SUB modeller_object()
DEF objecthandle,facenumber:INT
IF numberofsections>2
DEF facedata[100]:INT
objecthandle=D3DSHAPE(scene,@SHAPECUSTOM)
normal=D3DCOMMAND (objecthandle,@ADDNORMAL,0,-1,0)
'Create vertices
FOR layer=0 TO numberoflayers-1
xcentre=-160+(x[front,left,layer]+x[front,right,layer])/2
zcentre=-160+(x[side,left,layer]+x[side,right,layer])/2
xradius=(x[front,right,layer]-x[front,left,layer])/2
zradius=(x[side,right,layer]-x[side,left,layer])/2
FOR section=0 TO numberofsections-1
angle=6.283*section/numberofsections
vertexnumber=layer*numberofsections+section
vertexx[vertexnumber]=xcentre+xradius*SIN(angle)
vertexz[vertexnumber]=zcentre+zradius*COS(angle)
vertex[vertexnumber]=D3DCOMMAND (objecthandle,@ADDVERTEX,vertexx[vertexnumber],layery[layer],vertexz[vertexnumber])
NEXT section
NEXT layer
'Create faces
facenumber=0
'Create side faces
facedata[0]=4:facedata[9]=0
facedata[2]=normal:facedata[4]=normal:facedata[6]=normal:facedata[8]=normal
FOR layer=1 TO numberoflayers-1
FOR section=0 TO numberofsections-1
facedata[7]=vertex[(layer-1)*numberofsections+section]
facedata[5]=vertex[layer*numberofsections+section]
IF section<>numberofsections-1
facedata[3]=vertex[layer*numberofsections+section+1]
facedata[1]=vertex[(layer-1)*numberofsections+section+1]
ELSE
facedata[3]=vertex[layer*numberofsections]
facedata[1]=vertex[(layer-1)*numberofsections]
ENDIF
D3DCOMMAND objecthandle,@ADDFACES,facedata
'Colour face
colour=layercolournumber[layer-1]
D3DCOMMAND objecthandle,@SETFACECOLOR,facenumber,red[colour]/255,green[colour]/255,blue[colour]/255,1-trans[colour]/255
facenumber=facenumber+1
NEXT section
D3DCOMMAND objecthandle,@CUSTOMINIT
NEXT layer
'Create top face
facedata[0]=numberofsections:facedata[2*numberofsections+1]=0
FOR section=0 TO numberofsections-1
facedata[2*section+1]=vertex[(numberoflayers-1)*numberofsections+section]
facedata[2*section+2]=normal
NEXT section
D3DCOMMAND objecthandle,@ADDFACES,facedata
'Colour face
colour=layercolournumber[numberoflayers-1]
D3DCOMMAND objecthandle,@SETFACECOLOR,facenumber,red[colour]/255,green[colour]/255,blue[colour]/255,1-trans[colour]/255
facenumber=facenumber+1
D3DCOMMAND objecthandle,@CUSTOMINIT
'Create bottom face
facedata[0]=numberofsections:facedata[2*numberofsections+1]=0
FOR section=numberofsections-1 TO 0 STEP -1
facedata[2*(numberofsections-1-section)+1]=vertex[section]
facedata[2*(numberofsections-1-section)+2]=normal
NEXT section
D3DCOMMAND objecthandle,@ADDFACES,facedata
'Colour face
colour=layercolournumber[0]
D3DCOMMAND objecthandle,@SETFACECOLOR,facenumber,red[colour]/255,green[colour]/255,blue[colour]/255,1-trans[colour]/255
facenumber=facenumber+1
D3DCOMMAND objecthandle,@CUSTOMINIT
ENDIF
RETURN objecthandle
SUB addnewlayer
'Copy data for each layer not below selected layer to layer above
FOR layer=numberoflayers-1 TO selectedlayer STEP -1
layery[layer+1]=layery[layer]:x[front,left,layer+1]=x[front,left,layer]:x[front,right,layer+1]=x[front,right,layer]
x[side,left,layer+1]=x[side,left,layer]:x[side,right,layer+1]=x[side,right,layer]
layercolournumber[layer+1]=layercolournumber[layer]
NEXT layer
'Set y for new layer
IF selectedlayer=numberoflayers-1
'Selected layer is top layer
IF layery[selectedlayer]<=130
layery[selectedlayer+1]=layery[selectedlayer]+20
ELSE
layery[selectedlayer+1]=layery[selectedlayer]+(160-layery[selectedlayer])/2
ENDIF
ELSE
'Set layery half way between layers above and below
layery[selectedlayer+1]=(layery[selectedlayer]+layery[selectedlayer+2])/2
ENDIF
numberoflayers=numberoflayers+1:selectedlayer=selectedlayer+1
'Get orientation of shape
D3DCOMMAND shape[currentshape],@GETORIENTATION,scene,orient
gotorientation=1
D3DDELETE shape[currentshape]
currentshape=1-currentshape
shape[currentshape]=modeller_object()
updatenormals
RETURN
SUB deleteselectedlayer
IF selectedlayer<>numberoflayers-1
'Layer selected is not top layer
FOR layer=selectedlayer TO numberoflayers-2
layery[layer]=layery[layer+1]:x[front,left,layer]=x[front,left,layer+1]:x[front,right,layer]=x[front,right,layer+1]
x[side,left,layer]=x[side,left,layer+1]:x[side,right,layer]=x[side,right,layer+1]
NEXT layer
ENDIF
numberoflayers=numberoflayers-1
IF selectedlayer<>0 THEN selectedlayer=selectedlayer-1
'Get orientation of shape
D3DCOMMAND shape[currentshape],@GETORIENTATION,scene,orient
gotorientation=1
D3DDELETE shape[currentshape]
currentshape=1-currentshape
shape[currentshape]=modeller_object()
updatenormals
RETURN
SUB saveasxfile
DEF filename:STRING
filename=FILEREQUEST("Save as x file",win,0,"x files|*.x||",".x")
COPYFILE(GETSTARTPATH+"temporary.x",filename,0)
RETURN
SUB drawgridlines
'Draw grid using points coordinates set above into points memory
FRONTPEN win,0xC0C0C0
hdc=GETHDC(win)
PolyPolyline(hdc,points,pppls,62)
RELEASEHDC win,hdc
g=usablewidth/4
LINE win,g,0,g,halfwidth,0x808080
LINE win,0,g,halfwidth,g,0x808080
FRONTPEN win,0
RETURN
SUB printtext
MOVE win,halfwidth+10,halfwidth+5:PRINT win,"Rotate the object using the arrow keys"
IF runningfullscreen
MOVE win,480,460:PRINT win,"Press ESC key to exit"
ENDIF
MOVE win,10,halfwidth+5
IF view=front
PRINT win,"Front view Press S key for side view"
ELSE
PRINT win,"Side view Press F key for front view"
ENDIF
IF colouringmode
drawcolourbox
MOVE win,colourboxleft+colourboxwidth+squaresize,halfwidth+3*textspacing:PRINT win,"Click on a colour square to select a colour."
MOVE win,colourboxleft+colourboxwidth+squaresize,halfwidth+4.5*textspacing:PRINT win,"Click on the red,green or blue bars to alter the selected colour."
MOVE win,colourboxleft+colourboxwidth+squaresize,halfwidth+6*textspacing:PRINT win,"Click on the rightmost bar to set the transparency for the selected colour."
MOVE win,colourboxleft+colourboxwidth+squaresize,halfwidth+7.5*textspacing:PRINT win,"Click on a layer (horizontal line) to apply the selected colour to the object."
MOVE win,colourboxleft+colourboxwidth+squaresize,halfwidth+9*textspacing:PRINT win,"Press the M key to return to editing mode."
ELSE
'Not in colouring mode
MOVE win,10,halfwidth+2*textspacing:PRINT win,"Hold down spacebar and click on a layer (horizontal line)"
MOVE win,10,halfwidth+3*textspacing:PRINT win,"to select it."
IF layery[selectedlayer]<=156 & numberoflayers<100
MOVE win,10,halfwidth+9*textspacing:PRINT win,"Press A to add a new layer above selected one."
ENDIF
IF numberoflayers>2
MOVE win,10,halfwidth+10*textspacing:PRINT win,"Press Delete key to delete selected layer."
ENDIF
MOVE win,halfwidth+10,halfwidth+2*textspacing:PRINT win,"Press I to save object as an IBasic subroutine."
MOVE win,halfwidth+10,halfwidth+3*textspacing:PRINT win,"Press X to save object as an x file."
MOVE win,halfwidth+10,halfwidth+4*textspacing:PRINT win,"Press L to load a Jolly Modeller object."
MOVE win,halfwidth+10,halfwidth+5*textspacing:PRINT win,"Press Spacebar+N to start a new object."
MOVE win,10,halfwidth+4*textspacing:PRINT win,"Move the mouse with the left button down to move layer."
MOVE win,10,halfwidth+5*textspacing:PRINT win,"Move the mouse with the right button down to scale layer."
MOVE win,10,halfwidth+6*textspacing:PRINT win,"If you hold down the Ctrl key while scaling then the layer"
MOVE win,10,halfwidth+7*textspacing:PRINT win,"will be scaled equally in both front and side views."
MOVE win,10,halfwidth+8*textspacing:PRINT win,"Press the M key to change to colouring mode."
ENDIF
RETURN
SUB loadobject
DEF filename,textline,textline2,textline3,textline4:STRING
DEF file:FILE
filename=FILEREQUEST("Load Jolly Modeller text file",win,1,"Jolly modeller text files|*.jmo.txt||")
IF filename<>""
error=OPENFILE(file,filename,"R")
IF error=0
READ file,textline
READ file,textline
IF VAL(MID$(textline,16))<2
MESSAGEBOX win,"This is not a valid Jolly Modeller object","Oops"
ELSE
numberoflayers=VAL(MID$(textline,16))
READ file,textline:textline=MID$(textline,INSTR(textline,"=")+1)
FOR layer=0 TO numberoflayers-1
layery[layer]=VAL(textline):textline=MID$(textline,INSTR(textline,",")+1)
x[front,left,layer]=VAL(textline):textline=MID$(textline,INSTR(textline,",")+1)
x[front,right,layer]=VAL(textline):textline=MID$(textline,INSTR(textline,",")+1)
x[side,left,layer]=VAL(textline):textline=MID$(textline,INSTR(textline,",")+1)
x[side,right,layer]=VAL(textline):textline=MID$(textline,INSTR(textline,",")+1)
IF INSTR(textline,",")=0 & (layer<>numberoflayers-1)
'Come to end of data in textline and is more data to be read
READ file,textline
textline=MID$(textline,INSTR(textline,"=")+1)
ENDIF
NEXT layer
'Read colour data
READ file,textline
IF LEFT$(textline,1)="r"
'Only one colour used
'Set colour number of all layers in object to zero
FOR layer=0 TO numberoflayers-1
layercolournumber[layer]=0
NEXT layer
'Read red,green,blue and transparency values for colour zero
textline=MID$(textline,INSTR(textline,"=")+1)
red[0]=VAL(textline)
textline=MID$(textline,INSTR(textline,"=")+1)
green[0]=VAL(textline)
textline=MID$(textline,INSTR(textline,"=")+1)
blue[0]=VAL(textline)
textline=MID$(textline,INSTR(textline,"=")+1)
trans[0]=VAL(textline)
ELSE
'More than one colour used.Need to read colour number for each layer
'and red,green and blue values for each colour
'Read layer colour numbers
textline=MID$(textline,INSTR(textline,"=")+1)
FOR layer=0 TO numberoflayers-1
layercolournumber[layer]=VAL(textline)
IF layer%30=29 & (layer<>numberoflayers-1)
'Read all 30 layer colour numbers from line
'and is still data to read so read next line
READ file,textline
textline=MID$(textline,INSTR(textline,"=")+1)
ENDIF
textline=MID$(textline,INSTR(textline,",")+1)
NEXT layer
'Read red,green and blue values
READ file,textline:READ file,textline2
READ file,textline3:READ file,textline4
textline=MID$(textline,INSTR(textline,"=")+1)
textline2=MID$(textline2,INSTR(textline2,"=")+1)
textline3=MID$(textline3,INSTR(textline3,"=")+1)
textline4=MID$(textline4,INSTR(textline4,"=")+1)
FOR colour=0 TO 7
red[colour]=VAL(textline):green[colour]=VAL(textline2)
blue[colour]=VAL(textline3):trans[colour]=VAL(textline4)
textline=MID$(textline,INSTR(textline,",")+1)
textline2=MID$(textline2,INSTR(textline2,",")+1)
textline3=MID$(textline3,INSTR(textline3,",")+1)
textline4=MID$(textline4,INSTR(textline4,",")+1)
NEXT colour
ENDIF
ENDIF
CLOSEFILE file
ENDIF
ENDIF
RETURN
SUB closethewindow
'Delete all the frames
D3DDELETE light
D3DDELETE camera
D3DDELETE shape[currentshape]
D3DDELETE yaxispivot
D3DDELETE scene
'Hide cursor.Avoids possible cursor distortion
SETCURSOR win,@CSCUSTOM,0
CLOSEWINDOW win
WAITUNTIL win=0
RETURN
SUB setup3D
D3DSETQUALITY win,@LIGHTON | @FILLSOLID | @SHADEGOURAUD
FRONTPEN win,0
DRAWMODE win,@TRANSPARENT
'The parent scene frame
scene = D3DSCENE(win)
D3DCOMMAND scene,@SETSCENEBACKCOLOR,.5,.5,1
'Create and position the camera
camera = D3DCAMERA(scene)
D3DCOMMAND camera,@SETPOSITION,scene,0,-80,-800
D3DCOMMAND camera,@SETORIENTATION,scene,-.23,0,1,0,1,0
'Create and orient a light source
light = D3DLIGHT(scene,@LIGHTDIRECTIONAL,1.2,1.2,1.2)
D3DCOMMAND light,@SETORIENTATION,scene,-1,-1,1, -1,1,1
yaxispivot=D3DSHAPE(scene,@SHAPECUSTOM)
currentshape=1-currentshape
shape[currentshape]=modeller_object()
updatenormals
selectedlayer=numberoflayers-1
RETURN
SUB drawcolourbox
RECT win,colourboxleft,colourboxtop,colourboxwidth,colourboxheight,0,colourboxbackground
'Draw red bar
RECT win,redbarleft,bartop,squaresize,barheight,255,255
RECT win,redbarleft,bartop,squaresize,(255-red[currentcolournumber])*barheight/255,0,0
'Draw green bar
RECT win,greenbarleft,bartop,squaresize,barheight,0xFF00,0xFF00
RECT win,greenbarleft,bartop,squaresize,(255-green[currentcolournumber])*barheight/255,0,0
'Draw blue bar
RECT win,bluebarleft,bartop,squaresize,barheight,0xFF0000,0xFF0000
RECT win,bluebarleft,bartop,squaresize,(255-blue[currentcolournumber])*barheight/255,0,0
'Draw transparency bar
RECT win,transbarleft,bartop,squaresize,barheight,0,0xFFFFFF
RECT win,transbarleft,bartop,squaresize,trans[currentcolournumber]*barheight/255,0,0
'Draw colour squares
FOR colour=0 TO 7
RECT win,squareleft[colour],squaretop[colour],squaresize,squaresize,0,RGB(red[colour],green[colour],blue[colour])
IF colour=currentcolournumber
RECT win,squareleft[colour]-2,squaretop[colour]-2,squaresize+4,squaresize+4,RGB(255,0,0)
ELSE
RECT win,squareleft[colour]-2,squaretop[colour]-2,squaresize+4,squaresize+4,colourboxbackground
ENDIF
NEXT colour
RETURN
SUB checkforclickoncolourbox
mousex=@MOUSEX:mousey=@MOUSEY
IF mousey>=bartop-squaresize/4 & mousey<=bartop+barheight+squaresize/4
'Check if click on bars
IF mousex>=redbarleft & mousex<=redbarleft+squaresize
red[currentcolournumber]=(bartop+barheight-mousey)*255/barheight
IF red[currentcolournumber]<0 THEN red[currentcolournumber]=0
IF red[currentcolournumber]>255 THEN red[currentcolournumber]=255
recolourobject
ENDIF
IF mousex>=greenbarleft & mousex<=greenbarleft+squaresize
green[currentcolournumber]=(bartop+barheight-mousey)*255/barheight
IF green[currentcolournumber]<0 THEN green[currentcolournumber]=0
IF green[currentcolournumber]>255 THEN green[currentcolournumber]=255
recolourobject
ENDIF
IF mousex>=bluebarleft & mousex<=bluebarleft+squaresize
blue[currentcolournumber]=(bartop+barheight-mousey)*255/barheight
IF blue[currentcolournumber]<0 THEN blue[currentcolournumber]=0
IF blue[currentcolournumber]>255 THEN blue[currentcolournumber]=255
recolourobject
ENDIF
IF mousex>=transbarleft & mousex<=transbarleft+squaresize
trans[currentcolournumber]=255-(bartop+barheight-mousey)*255/barheight
IF trans[currentcolournumber]<0 THEN trans[currentcolournumber]=0
IF trans[currentcolournumber]>255 THEN trans[currentcolournumber]=255
recolourobject
updatenormals
ENDIF
ELSE
'Check if click on one of colour squares
FOR colour=0 TO 7
IF mousex>=squareleft[colour] & mousex<=squareleft[colour]+squaresize
IF mousey>=squaretop[colour] & mousey<=squaretop[colour]+squaresize
currentcolournumber=colour
colour=7
ENDIF
ENDIF
NEXT colour
ENDIF
RETURN
SUB recolourobject
'Check through all layers to find any coloured in current colour
'which has just changed.Change colour of object faces accordingly
colour=currentcolournumber
FOR layer=0 TO numberoflayers-1
IF layercolournumber[layer]=currentcolournumber
IF layer<>numberoflayers-1
'Change side faces colour
FOR section=0 TO numberofsections-1
D3DCOMMAND shape[currentshape],@SETFACECOLOR,(layer*numberofsections+section),red[colour]/255,green[colour]/255,blue[colour]/255,1-trans[colour]/255
NEXT section
ELSE
'Change top face colour
D3DCOMMAND shape[currentshape],@SETFACECOLOR,((numberoflayers-1)*numberofsections),red[colour]/255,green[colour]/255,blue[colour]/255,1-trans[colour]/255
ENDIF
IF layer=0
'Change bottom face colour
D3DCOMMAND shape[currentshape],@SETFACECOLOR,((numberoflayers-1)*numberofsections+1),red[colour]/255,green[colour]/255,blue[colour]/255,1-trans[colour]/255
ENDIF
ENDIF
NEXT layer
RETURN
SUB createinitialobjectdata
view=front
colourboxbackground=RGB(255,255,200)
'Set up initial colours in colour box
red=200,255,0,0,255,255,0,150
green=200,0,255,0,255,0,255,100
blue=200,0,0,255,0,255,255,0
trans=0,0,0,0,0,0,0,0
currentcolournumber=0
'Start with simple cylinder
x[front,left,0]=100:x[front,right,0]=220:x[side,left,0]=100:x[side,right,0]=220:layery[0]=-160
x[front,left,1]=100:x[front,right,1]=220:x[side,left,1]=100:x[side,right,1]=220:layery[1]=-140
numberoflayers=2:selectedlayer=1:layercolournumber=0,0
RETURN
SUB setfontsize
'(Adapted from a post by Larry A)
'Find default font height
GETTEXTSIZE win,"M",v,textheight
IF textheight>(usableheight-(usablewidth/2))/16.5
'Text too high.Change font size
textheight=(usableheight-(usablewidth/2))/16.5
SETFONT win,"Ariel",textheight,600
ENDIF
'Check that font isn't too wide
GETTEXTSIZE win,"Move the mouse with the right button down to scale layer.",textwidth,v
IF textwidth>halfwidth
'Test line is too long.Reduce fontsize
textheight=FLOOR(textheight*halfwidth/textwidth)
SETFONT win,"Ariel",textheight,600
ENDIF
textspacing=textheight*1.5
RETURN
Clever stuff by Jolly Roger as always .. :)
Have you noticed how he always uses long variable names .. very informative, but I don't have the patience to keep typing long names myself. :)
Graham