have fun creating the shapes that come to your mind
'Simple lathing programme to create 3D objects with basic colouring
'by drawing and colouring in a line
'By Jolly Roger
DEF win:WINDOW
DEF readytostartline,linefinished,mousex,mousey,oldmousex,oldmousey,run:INT
DEF linepointx[10000],linepointy[10000],numberoflinepoints,latheaxisx:INT
DEF numberofsections,linepoint,smooth,numberoffaces:INT
DEF red[8],green[8],blue[8],currentcolour,colour,colourboxtop,colourboxleft,drawcolourboxbackground:INT
DEF redbarx,redbary,greenbarx,greenbary,bluebarx,bluebary,colourx[8],coloury[8]:INT
DEF colourboxbackground,linecolournumber[10000],pointadded[10000]:INT
DEF scene,camera,light,lastframetime,timesincelastframe,shape,yaxispivot:INT
DEF rubberbandstartx,rubberbandstarty,rubberbandendx,rubberbandendy,ycentreofline:INT
DEF screen:STRING
DEF colourtransparency[8],degrees:FLOAT
degrees=6.283/360:smooth=1:numberofsections=12
DECLARE anglegreaterthanminangle(point1:INT,point2:INT,point3:INT)
DECLARE latheline()
'Set up timer
DECLARE "kernel32",GetTickCount(),int
colourboxtop=200:colourboxleft=110:colourboxbackground=RGB(255,255,200)
FOR colour=0 TO 7
colourx[colour]=colourboxleft+14+24*(colour % 4)
coloury[colour]=colourboxtop+90+10*(colour-(colour % 4))
NEXT colour
redbarx=colourboxleft+20:redbary=colourboxtop+40
greenbarx=colourboxleft+50:greenbary=colourboxtop+40
bluebarx=colourboxleft+80:bluebary=colourboxtop+40
initialisevariables
latheaxisx=280
createwindowandcontrols
setupdata
IF numberoflinepoints>0
'There is data in setupdata routine.Add required offsets then create object.
FOR linepoint=1 TO numberoflinepoints
linepointx[linepoint]=linepointx[linepoint]+latheaxisx
linepointy[linepoint]=227-linepointy[linepoint]
NEXT linepoint
findycentreofline
setup3Dscreen
shape=latheline()
'Save the shape to a temporary file
IF smooth=1
D3DCOMMAND shape,@SAVESHAPE,GETSTARTPATH+"temporary.x",@FORMATTEXT,@SAVEMATERIALS
ELSE
D3DCOMMAND shape,@SAVESHAPE,GETSTARTPATH+"temporary.x",@FORMATTEXT,@SAVEMATERIALS | @SAVENORMALS
ENDIF
ELSE
setupdrawingscreen
ENDIF
run=1
WAITUNTIL run=0
'Delete temporary x file
DELETEFILE (GETSTARTPATH+"temporary.x")
closethewindow
END
SUB mainwindow
SELECT @CLASS
CASE @IDPAINT
'Window needs redrawing
IF screen="drawing"
setupdrawingscreen
IF numberoflinepoints<>0 THEN drawline
ENDIF
IF screen="colouring"
setupcolouringscreen
RECT win,latheaxisx,0,634-latheaxisx,455,0,0
drawline
ENDIF
IF screen="parameter input"
setupparameterinputscreen
RECT win,latheaxisx,0,634-latheaxisx,455,0,0
drawline
ENDIF
CASE @IDCONTROL
IF @CONTROLID=1
'Drawing finished/colouring finished/create object button pressed
IF screen="parameter input"
'Create object button pressed
numberofsections=VAL(GETCONTROLTEXT(win,2))
'Test for tick in checkbox
smooth=GETSTATE (win,3)
IF numberofsections>2 & numberofsections<31
'Create object
IF numberoflinepoints>=5 THEN optimiseline
findycentreofline
setup3Dscreen
shape=latheline()
'Save the shape to a temporary file
IF smooth=1
D3DCOMMAND shape,@SAVESHAPE,GETSTARTPATH+"temporary.x",@FORMATTEXT,@SAVEMATERIALS
ELSE
D3DCOMMAND shape,@SAVESHAPE,GETSTARTPATH+"temporary.x",@FORMATTEXT,@SAVEMATERIALS | @SAVENORMALS
ENDIF
ELSE
MESSAGEBOX 0,"Number of sections" + chr$(13) + "must be 3 to 30","Oops"
ENDIF
ENDIF
IF screen="colouring"
'Colouring finished button pressed
setupparameterinputscreen
ENDIF
IF screen="drawing"
'Drawing finished button pressed
'Split lines longer than 10 into smaller lines for more accurate colouring
splitlonglines
setupcolouringscreen
ENDIF
ENDIF
IF @CONTROLID=4
'Save object button pressed
filename$=FILEREQUEST ("Save as .x file",win,0,".x files (*.x)|*.x||","x")
IF filename$<>""
'Copy temporary object file to specified file name
COPYFILE(GETSTARTPATH+"temporary.x",filename$,0)
ENDIF
ENDIF
IF @CONTROLID=5
'Start new object button pressed
screen="drawing"
closethewindow
createwindowandcontrols
initialisevariables
setupdrawingscreen
FRONTPEN win,RGB(200,200,200)
ENDIF
CASE @IDCLOSEWINDOW
run=0
CASE @IDCHAR
IF (@CODE = ASC("Q")) | (@CODE=ASC("q")) then run = 0
IF screen="3D"
IF (@CODE = ASC("N")) | (@CODE=ASC("n"))
screen="drawing"
closethewindow
createwindowandcontrols
initialisevariables
setupdrawingscreen
FRONTPEN win,RGB(200,200,200)
ENDIF
IF (@CODE = ASC("B")) | (@CODE=ASC("b"))
screen="parameter input"
closethewindow
createwindowandcontrols
setupparameterinputscreen
'Enable create object,save object and start new object buttons
ENABLECONTROL win,1,1
ENABLECONTROL win,4,1
ENABLECONTROL win,5,1
RECT win,latheaxisx,0,634-latheaxisx,455,0,0
drawline
ENDIF
ENDIF
IF @CODE=ASC("D")|@CODE=ASC("d")
IF (screen="drawing") & readytostartline=1
IF numberoflinepoints>2
'Erase old rubber band line
LINE win,rubberbandstartx,rubberbandstarty,rubberbandendx,rubberbandendy,0
'Delete last point and line
LINE win,linepointx[numberoflinepoints-1],linepointy[numberoflinepoints-1],linepointx[numberoflinepoints],linepointy[numberoflinepoints],0
numberoflinepoints=numberoflinepoints-1
drawline
linefinished=0
'Disable "Drawing Finished" button
ENABLECONTROL win,1,0
ELSE
RECT win,latheaxisx,0,634-latheaxisx,455,0,0
IF numberoflinepoints=0 THEN readytostartline=0
numberoflinepoints=0
ENDIF
ENDIF
ENDIF
CASE @IDLBUTTONDN
mousex=@MOUSEX:mousey=@MOUSEY
IF (screen="drawing") & linefinished=0
IF numberoflinepoints=0 & mousex<latheaxisx
oldmousex=mousex:oldmousey=mousey:readytostartline=1
ENDIF
IF numberoflinepoints>0 & mousex>latheaxisx
continueline
ENDIF
IF numberoflinepoints>0 & mousex<latheaxisx
endline
ENDIF
IF numberoflinepoints=0 & readytostartline=1 & mousex>latheaxisx
startline
ENDIF
ENDIF
IF (screen="colouring") & mousex<latheaxisx
'On colouring screen.Click is to left of drawing area.
checkforclickoncolourbox
ENDIF
CASE @IDMOUSEMOVE
mousex=@MOUSEX:mousey=@MOUSEY
IF GETKEYSTATE(0x01) & GETKEYSTATE(0x01)
IF (screen="colouring") & mousex>latheaxisx
'On colouring screen,left mouse button down and mouse in drawing area
'Colour line if mouse near linepoint
FOR linepoint=1 TO numberoflinepoints-1
IF ABS(mousex-linepointx[linepoint])<5
IF ABS(mousey-linepointy[linepoint])<5
linecolournumber[linepoint]=currentcolour
LINE win,linepointx[linepoint],linepointy[linepoint],linepointx[linepoint+1],linepointy[linepoint+1],RGB(red[currentcolour],green[currentcolour],blue[currentcolour])
ENDIF
ENDIF
NEXT linepoint
ENDIF
IF (screen="drawing") & linefinished=0
IF numberoflinepoints>0 & mousex>latheaxisx & ABS(mousex-linepointx[numberoflinepoints])+ABS(mousey-linepointy[numberoflinepoints])>5
continueline
ENDIF
IF numberoflinepoints>1 & mousex<latheaxisx
endline
ENDIF
IF numberoflinepoints=0 & mousex>latheaxisx & readytostartline=1
startline
ENDIF
IF numberoflinepoints=0 & mousex<latheaxisx
oldmousex=mousex:oldmousey=mousey
ENDIF
ENDIF
ELSE
'Left mouse button is up
IF readytostartline=1 & linefinished=0 & (screen="drawing") THEN drawrubberbandline
ENDIF
CASE @IDDXUPDATE
DEF mult:FLOAT
'find time since last frame to make things run at a constant speed
timesincelastframe=GetTickCount()-lastframetime
IF timesincelastframe>2 & (screen="3D")
lastframetime=GetTickCount()
mult=timesincelastframe/8
'Rotate the shape using the arrow keys
'Up arrow
IF(GETKEYSTATE(0x26))
D3DCOMMAND shape,@ADDROTATION,1,0,0,(.5 * (3.1415/180))*mult
ENDIF
'Down arrow
IF(GETKEYSTATE(0x28))
D3DCOMMAND shape,@ADDROTATION,1,0,0,(-.5 * (3.1415/180))*mult
ENDIF
'Left arrow
IF(GETKEYSTATE(0x25))
D3DCOMMAND yaxispivot,@ADDROTATION,0,1,0,(-.5 * (3.1415/180))*mult
ENDIF
'Right arrow
IF(GETKEYSTATE(0x27))
D3DCOMMAND yaxispivot,@ADDROTATION,0,1,0,(.5 * (3.1415/180))*mult
ENDIF
'Render the scene to the DirectX surface
D3DRENDER scene,camera
'Add any 2D elements after the scene is rendered.
MOVE win,5,15:PRINT win,"Rotate the object using the arrow keys"
MOVE win,5,30:PRINT win,"Press N to start new object.Press B to save object or alter object parameters"
MOVE win,5,45:PRINT win,"Press Q to exit"
MOVE win,5,425:PRINT win,numberoffaces," faces in object"
'Show the DirectX surface
DXFLIP win,0,0
ENDIF
ENDSELECT
RETURN
SUB endline
'Enable drawing finished button
ENABLECONTROL win,1,1
linefinished=1
numberoflinepoints=numberoflinepoints+1
linepointx[numberoflinepoints]=latheaxisx
linepointy[numberoflinepoints]=linepointy[numberoflinepoints-1]+(mousey-linepointy[numberoflinepoints-1])*(linepointx[numberoflinepoints-1]-latheaxisx)/(linepointx[numberoflinepoints-1]-mousex)
LINE win,linepointx[numberoflinepoints-1],linepointy[numberoflinepoints-1],linepointx[numberoflinepoints],linepointy[numberoflinepoints]
RETURN
SUB startline
numberoflinepoints=2
linepointx[2]=mousex:linepointy[2]=mousey
linepointx[1]=latheaxisx
linepointy[1]=mousey+(oldmousey-mousey)*(mousex-latheaxisx)/(mousex-oldmousex)
LINE win,linepointx[1],linepointy[1],linepointx[2],linepointy[2]
RETURN
SUB continueline
numberoflinepoints=numberoflinepoints+1
linepointx[numberoflinepoints]=mousex
linepointy[numberoflinepoints]=mousey
LINE win,linepointx[numberoflinepoints-1],linepointy[numberoflinepoints-1],mousex,mousey
RETURN
SUB drawline
IF screen="drawing"
MOVE win,linepointx[1],linepointy[1]
FOR linepoint=2 TO numberoflinepoints
LINE win,linepointx[linepoint],linepointy[linepoint]
NEXT linepoint
ELSE
MOVE win,linepointx[1],linepointy[1]
FOR linepoint=2 TO numberoflinepoints
colour=linecolournumber[linepoint-1]
LINE win,linepointx[linepoint],linepointy[linepoint],RGB(red[colour],green[colour],blue[colour])
NEXT linepoint
ENDIF
RETURN
SUB drawcolourbox
IF drawcolourboxbackground=1 THEN RECT win,colourboxleft,colourboxtop,100,150,0,colourboxbackground
'Draw red bar
RECT win,redbarx-10,redbary-30,20,(255-red[currentcolour])*60/255,0,0
RECT win,redbarx-10,redbary-30+(255-red[currentcolour])*60/255,20,red[currentcolour]*60/255,RGB(255,0,0),RGB(255,0,0)
'Draw green bar
RECT win,greenbarx-10,greenbary-30,20,(255-green[currentcolour])*60/255,0,0
RECT win,greenbarx-10,greenbary-30+(255-green[currentcolour])*60/255,20,green[currentcolour]*60/255,RGB(0,255,0),RGB(0,255,0)
'Draw blue bar
RECT win,bluebarx-10,bluebary-30,20,(255-blue[currentcolour])*60/255,0,0
RECT win,bluebarx-10,bluebary-30+(255-blue[currentcolour])*60/255,20,blue[currentcolour]*60/255,RGB(0,0,25),RGB(0,0,255)
'Draw colour squares
FOR colour=0 TO 7
RECT win,colourx[colour]-10,coloury[colour]-10,20,20,0,RGB(red[colour],green[colour],blue[colour])
IF colour=currentcolour
RECT win,colourx[colour]-12,coloury[colour]-12,24,24,RGB(255,0,0)
ELSE
RECT win,colourx[colour]-12,coloury[colour]-12,24,24,colourboxbackground
ENDIF
NEXT colour
RETURN
SUB setup3Dscreen
'Hide create object,save object,start new object buttons,edit box and check box
SHOWWINDOW win,@SWHIDE,1
SHOWWINDOW win,@SWHIDE,2
SHOWWINDOW win,@SWHIDE,3
SHOWWINDOW win,@SWHIDE,4
SHOWWINDOW win,@SWHIDE,5
IF GETDXVERSION < 7
MESSAGEBOX 0,"The preview requires" + chr$(13) + "DirectX 7.0 or greater","Error"
END
ENDIF
'Create a 3D screen for object preview
error=CREATE3DSCREEN(win,640,480)
IF error<>0
'Couldn't open windowed Direct3D screen.Try opening fullscreen
error=CREATE3DSCREEN(win,640,480,16)
IF error<>0
MESSAGEBOX win, "Could not create Direct3D screen","Error"
CLOSEWINDOW win
END
ENDIF
ENDIF
D3DSETQUALITY win,@LIGHTON | @FILLSOLID | @SHADEGOURAUD
FRONTPEN win,RGB(255,255,255)
BACKPEN win,0
DRAWMODE win,@TRANSPARENT
'The parent scene frame
scene = D3DSCENE(win)
D3DCOMMAND scene,@SETSCENEBACKCOLOR,.2,.2,1
'Create and position the camera
camera = D3DCAMERA(scene)
D3DCOMMAND camera,@SETPOSITION,scene,0,0,-800
D3DCOMMAND camera,@SETORIENTATION,scene,0,0,1,0,1,0
'create and position a light source
light = D3DLIGHT(scene,@LIGHTDIRECTIONAL,1.2,1.2,1.2)
D3DCOMMAND light,@SETORIENTATION,scene,-1,-1,1, -1,1,1
lastframetime=GetTickCount()
'Create object to rotate shape about y axis
yaxispivot=D3DSHAPE(scene,@SHAPECUSTOM)
screen="3D"
RETURN
SUB optimiseline
DEF deletepoint:INT
linepoint=3
DO
deletepoint=0
IF linecolournumber[linepoint]=linecolournumber[linepoint-1]
'Lines on either side of point are same colour
'Check if point is one added to make colouring more accurate.If so,mark it for deletion.
IF pointadded[linepoint]=1
deletepoint=1
ELSE
IF anglegreaterthanminangle(linepoint-1,linepoint,linepoint+1)=1
'Angle at linepoint is greater than minimum angle
IF anglegreaterthanminangle(linepoint-2,linepoint-1,linepoint+1)=1
'Angle at linepoint-1 will be greater than minimum angle if linepoint removed
IF anglegreaterthanminangle(linepoint-1,linepoint+1,linepoint+2)=1
'Angle at linepoint+1 will be greater than minimum angle if linepoint removed
'Point is deletable
deletepoint=1
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
IF deletepoint=0
linepoint=linepoint+1
ELSE
removepoint
ENDIF
UNTIL linepoint=numberoflinepoints-1
'Check if linepoint 2 deletable
linepoint=2
IF linecolournumber[linepoint]=linecolournumber[linepoint-1] & pointadded[linepoint]=1 THEN removepoint
'Check if penultimate point deletable
linepoint=numberoflinepoints-1
IF linecolournumber[linepoint]=linecolournumber[linepoint-1] & pointadded[linepoint]=1 THEN removepoint
RETURN
SUB anglegreaterthanminangle(point1,point2,point3)
DEF cosangle,angle,minangle:FLOAT
DEF OK,dx,dy,linelength1squared,linelength2squared,linelength3squared:INT
'Find angle between line from point1 to point2 and line from point2 to point3
dx=linepointx[point1]-linepointx[point2]
dy=linepointy[point1]-linepointy[point2]
linelength1squared=dx*dx+dy*dy
dx=linepointx[point2]-linepointx[point3]
dy=linepointy[point2]-linepointy[point3]
linelength2squared=dx*dx+dy*dy
dx=linepointx[point1]-linepointx[point3]
dy=linepointy[point1]-linepointy[point3]
linelength3squared=dx*dx+dy*dy
IF linelength1squared=0 | linelength2squared=0
angle=180*degrees
ELSE
cosangle=(linelength1squared+linelength2squared-linelength3squared)/(2*SQRT(linelength1squared)*SQRT(linelength2squared))
angle=ACOS(cosangle)
ENDIF
minangle=(140+SQRT(linelength3squared))*degrees
IF minangle>165*degrees THEN minangle=165*degrees
IF angle>minangle
OK=1
ELSE
OK=0
ENDIF
RETURN OK
SUB splitlonglines
DEF linelengthsquared,numberofnewpoints:INT
DEF dx,dy:INT
'Check if any line sections longer than 10 pixels.
'If so then split into lines less than 10 long for more accurate colouring
linepoint=1
DO
numberofnewpoints=0
dx=linepointx[linepoint+1]-linepointx[linepoint]
dy=linepointy[linepoint+1]-linepointy[linepoint]
linelengthsquared=dx*dx+dy*dy
IF linelengthsquared>100
numberofnewpoints=FLOOR(SQRT(linelengthsquared)/10)
'Make room for new points in arrays
FOR pointinline=numberoflinepoints+numberofnewpoints TO linepoint+1+numberofnewpoints STEP -1
linepointx[pointinline]=linepointx[pointinline-numberofnewpoints]
linepointy[pointinline]=linepointy[pointinline-numberofnewpoints]
pointadded[pointinline]=pointadded[pointinline-numberofnewpoints]
NEXT pointinline
numberoflinepoints=numberoflinepoints+numberofnewpoints
'Add new points
FOR pointinline=linepoint+1 TO linepoint+numberofnewpoints
linepointx[pointinline]=linepointx[linepoint]+(linepointx[linepoint+numberofnewpoints+1]-linepointx[linepoint])*(pointinline-linepoint)/(numberofnewpoints+1)
linepointy[pointinline]=linepointy[linepoint]+(linepointy[linepoint+numberofnewpoints+1]-linepointy[linepoint])*(pointinline-linepoint)/(numberofnewpoints+1)
'Mark point as one that has been added so can be easily removed when optimise line
pointadded[pointinline]=1
NEXT pointinline
ENDIF
linepoint=linepoint+1+numberofnewpoints
UNTIL linepoint=numberoflinepoints
RECT win,latheaxisx,0,634-latheaxisx,455,0,0
drawline
RETURN
SUB checkforclickoncolourbox
drawcolourboxbackground=0
'Check if click on red,green or blue colour bars
IF ABS(mousex-redbarx)<10 & ABS(mousey-redbary)<35
red[currentcolour]=127.5-(mousey-redbary)*127.5/30
IF red[currentcolour]<0 THEN red[currentcolour]=0
IF red[currentcolour]>255 THEN red[currentcolour]=255
drawcolourbox
drawline
ENDIF
IF ABS(mousex-greenbarx)<10 & ABS(mousey-greenbary)<35
green[currentcolour]=127.5-(mousey-greenbary)*127.5/30
IF green[currentcolour]<0 THEN green[currentcolour]=0
IF green[currentcolour]>255 THEN green[currentcolour]=255
drawcolourbox
drawline
ENDIF
IF ABS(mousex-bluebarx)<10 & ABS(mousey-bluebary)<35
blue[currentcolour]=127.5-(mousey-bluebary)*127.5/30
IF blue[currentcolour]<0 THEN blue[currentcolour]=0
IF blue[currentcolour]>255 THEN blue[currentcolour]=255
drawcolourbox
drawline
ENDIF
'Check if click on one of colour squares
FOR coloursquare=0 TO 7
IF ABS(mousex-colourx[coloursquare])<10
IF ABS(mousey-coloury[coloursquare])<10
currentcolour=coloursquare
GOSUB drawcolourbox
coloursquare=7
ENDIF
ENDIF
NEXT coloursquare
RETURN
SUB setupcolouringscreen
screen="colouring"
SETCONTROLTEXT win,1,"Colouring finished"
RECT win,0,0,280,455,RGB(255,255,255),RGB(255,255,255)
drawcolourboxbackground=1
drawcolourbox
FRONTPEN win,0
MOVE win,0,0:PRINT win,"By default the line is coloured using the"
MOVE win,0,15:PRINT win,"first colour (top left colour square below)."
MOVE win,0,30:PRINT win,"Alter this colour as required by clicking"
MOVE win,0,45:PRINT win,"on the red,green and blue bars."
MOVE win,0,60:PRINT win,"To use a new colour:click on another"
MOVE win,0,75:PRINT win,"coloured square and alter it as above."
MOVE win,0,90:PRINT win,"To colour the line:Move the cursor over"
MOVE win,0,105:PRINT win,"the line,holding down the left mousebutton."
MOVE win,0,120:PRINT win,"When you have finished drawing,click on"
MOVE win,0,135:PRINT win, "the ",CHR$(34),"Colouring finished",CHR$(34)," button."
RETURN
SUB setupparameterinputscreen
screen="parameter input"
RECT win,0,0,280,455,RGB(255,255,255),RGB(255,255,255)
'Show editbox,checkbox,save object and start new object buttons
SHOWWINDOW win,@SWRESTORE,2
SHOWWINDOW win,@SWRESTORE,3
SHOWWINDOW win,@SWRESTORE,4
SHOWWINDOW win,@SWRESTORE,5
'Set text on button
SETCONTROLTEXT win,1,"Create object"
FRONTPEN win,0
MOVE win,0,0:PRINT win,"By default,the object has smooth shading."
MOVE win,0,15:PRINT win,"If you require flat shading then remove"
MOVE win,0,30:PRINT win,"the tick from the box below."
MOVE win,0,45:PRINT win,"Enter the number of sections you require in"
MOVE win,0,60:PRINT win,"the box."
MOVE win,0,75:PRINT win,"Three sections gives the object a triangular"
MOVE win,0,90:PRINT win,"cross section as viewed from the top."
MOVE win,0,105:PRINT win,"Four sections gives a square cross section"
MOVE win,0,120:PRINT win,"A large number of sections gives a nearly"
MOVE win,0,135:PRINT win,"circular cross section."
MOVE win,0,150:PRINT win,"Press the Create object button to create"
MOVE win,0,165:PRINT win,"and preview the object."
MOVE win,0,180:PRINT win,"After creating the object you can save"
MOVE win,0,195:PRINT win,"it by pressing the Save previewed object"
MOVE win,0,210:PRINT win,"button."
MOVE win,0,300:PRINT win,"Number of lathe sections"
RETURN
SUB latheline()
'Lathes a 2D line about the y axis to form a 3D object
DEF numberofpoints,colournumber,face,section:INT
numberofpoints=(numberoflinepoints-2)*numberofsections+2
numberoffaces=(numberoflinepoints-1)*numberofsections
DEF pointnumber,shape,vertex[numberofpoints],x,y,z,normalnumber,facedata[10]:INT
DEF normaly,normalx2D,linesegmentangle[numberoflinepoints]:FLOAT
DEF dx,dy:INT
DEF angle:FLOAT
IF smooth=0
DEF normal[numberoffaces]:INT
ELSE
DEF normal[numberofpoints]:INT
ENDIF
shape=D3DSHAPE(yaxispivot,@SHAPECUSTOM)
'First find angle of each line segment
FOR linepoint=1 TO numberoflinepoints-1
dx=linepointx[linepoint+1]-linepointx[linepoint]:dy=linepointy[linepoint+1]-linepointy[linepoint]
IF dx=0
IF dy>0
angle=1.571
ELSE
angle=4.712
ENDIF
ELSE
angle=ATAN(dy/dx)
ENDIF
IF dx<0 THEN angle=3.142+angle
IF dx>0 & dy<0 THEN angle=6.283+angle
linesegmentangle[linepoint]=angle
NEXT linepoint
'Create points
vertex[0]=D3DCOMMAND (shape,@ADDVERTEX,0,ycentreofline-linepointy[1],0)
FOR linepoint=2 TO numberoflinepoints-1
FOR section=0 TO numberofsections-1
pointnumber=1+(linepoint-2)*numberofsections+section
x=(linepointx[linepoint]-latheaxisx)*SIN(6.283*section/numberofsections)
z=(linepointx[linepoint]-latheaxisx)*COS(6.283*section/numberofsections)
y=ycentreofline-linepointy[linepoint]
vertex[pointnumber]=D3DCOMMAND (shape,@ADDVERTEX,x,y,z)
NEXT section
NEXT linepoint
vertex[numberofpoints-1]=D3DCOMMAND (shape,@ADDVERTEX,0,ycentreofline-linepointy[numberoflinepoints],0)
'Create normals
'One per point if smooth.One per face if flat.
IF smooth=1
normal[0]=D3DCOMMAND (shape,@ADDNORMAL,0,1,0)
normal[numberofpoints-1]=D3DCOMMAND (shape,@ADDNORMAL,0,-1,0)
ENDIF
FOR linepoint=1 TO numberoflinepoints-1
IF smooth=0
normaly=COS(linesegmentangle[linepoint])
normalx2D=SIN(linesegmentangle[linepoint])
ELSE
IF linepoint<numberoflinepoints-1
normaly=COS((linesegmentangle[linepoint]+linesegmentangle[linepoint+1])/2)
normalx2D=SIN((linesegmentangle[linepoint]+linesegmentangle[linepoint+1])/2)
ENDIF
ENDIF
FOR section=0 TO numberofsections-1
IF smooth=0
normalnumber=(linepoint-1)*numberofsections+section
normal[normalnumber]=D3DCOMMAND (shape,@ADDNORMAL,normalx2D*SIN(6.283*(section+.5)/numberofsections),normaly,normalx2D*COS(6.283*(section+.5)/numberofsections))
ELSE
IF linepoint<numberoflinepoints-1
normalnumber=1+(linepoint-1)*numberofsections+section
normal[normalnumber]=D3DCOMMAND (shape,@ADDNORMAL,normalx2D*SIN(6.283*section/numberofsections),normaly,normalx2D*COS(6.283*section/numberofsections))
ENDIF
ENDIF
NEXT section
NEXT linepoint
'Create top faces
FOR face=0 TO numberofsections-1
facedata[0]=3:facedata[7]=0:facedata[1]=vertex[0]:facedata[3]=vertex[face+1]
IF face<>numberofsections-1
facedata[5]=vertex[face+2]
ELSE
facedata[5]=vertex[1]
ENDIF
IF smooth=0
facedata[2]=normal[face]:facedata[4]=normal[face]:facedata[6]=normal[face]
ELSE
'Smooth=1
facedata[2]=normal[0]:facedata[4]=normal[face+1]
IF face<>numberofsections-1
facedata[6]=normal[face+2]
ELSE
facedata[6]=normal[1]
ENDIF
ENDIF
D3DCOMMAND shape,@ADDFACES,facedata
colournumber=linecolournumber[1]
D3DCOMMAND shape,@SETFACECOLOR,face,red[colournumber]/255,green[colournumber]/255,blue[colournumber]/255,1-colourtransparency[colournumber]
NEXT face
IF numberoflinepoints>3
'Create middle faces
FOR linepoint=2 TO numberoflinepoints-2
FOR section=0 TO numberofsections-1
facedata[0]=4:facedata[9]=0:facedata[1]=vertex[1+(linepoint-2)*numberofsections+section]
facedata[3]=vertex[1+(linepoint-1)*numberofsections+section]
IF section<>numberofsections-1
facedata[5]=vertex[1+(linepoint-1)*numberofsections+section+1]
facedata[7]=vertex[1+(linepoint-2)*numberofsections+section+1]
ELSE
facedata[5]=vertex[1+(linepoint-1)*numberofsections]
facedata[7]=vertex[1+(linepoint-2)*numberofsections]
ENDIF
IF smooth=0
facedata[2]=normal[(linepoint-1)*numberofsections+section]
facedata[4]=facedata[2]:facedata[6]=facedata[2]:facedata[8]=facedata[2]
ELSE
facedata[2]=normal[1+(linepoint-2)*numberofsections+section]
facedata[4]=normal[1+(linepoint-1)*numberofsections+section]
IF section<>numberofsections-1
facedata[6]=normal[1+(linepoint-1)*numberofsections+section+1]
facedata[8]=normal[1+(linepoint-2)*numberofsections+section+1]
ELSE
facedata[6]=normal[1+(linepoint-1)*numberofsections]
facedata[8]=normal[1+(linepoint-2)*numberofsections]
ENDIF
ENDIF
D3DCOMMAND shape,@ADDFACES,facedata
colournumber=linecolournumber[linepoint]
face=(linepoint-1)*numberofsections+section
D3DCOMMAND shape,@SETFACECOLOR,face,red[colournumber]/255,green[colournumber]/255,blue[colournumber]/255,1-colourtransparency[colournumber]
NEXT section
NEXT linepoint
ENDIF
'Create bottom faces
FOR face=numberoffaces-numberofsections TO numberoffaces-1
facedata[0]=3:facedata[7]=0:facedata[1]=vertex[numberofpoints-1-numberoffaces+face]:facedata[3]=vertex[numberofpoints-1]
IF face<>numberoffaces-1
facedata[5]=vertex[numberofpoints-numberoffaces+face]
ELSE
facedata[5]=vertex[numberofpoints-1-numberofsections]
ENDIF
IF smooth=0
facedata[2]=normal[face]:facedata[4]=normal[face]:facedata[6]=normal[face]
ELSE
facedata[2]=normal[numberofpoints-1-numberoffaces+face]
facedata[4]=normal[numberofpoints-1]
IF face<>numberoffaces-1
facedata[6]=normal[numberofpoints-numberoffaces+face]
ELSE
facedata[6]=normal[numberofpoints-1-numberofsections]
ENDIF
ENDIF
D3DCOMMAND shape,@ADDFACES,facedata
colournumber=linecolournumber[numberoflinepoints-1]
D3DCOMMAND shape,@SETFACECOLOR,face,red[colournumber]/255,green[colournumber]/255,blue[colournumber]/255,1-colourtransparency[colournumber]
NEXT face
'Initialise shape
D3DCOMMAND shape,@CUSTOMINIT
RETURN shape
SUB closethewindow
IF (screen="3D")
D3DDELETE scene
D3DDELETE light
D3DDELETE camera
D3DDELETE shape
D3DDELETE yaxispivot
ENDIF
'Hide cursor.Avoids possible cursor distortion
SETCURSOR win,@CSCUSTOM,0
CLOSEWINDOW win
RETURN
SUB setupdrawingscreen
RECT win,latheaxisx,0,634-latheaxisx,455,0,0
FRONTPEN win,0
MOVE win,0,0:PRINT win,"Click to the left of the drawing area (black"
MOVE win,0,15:PRINT win,"rectangle to the right) to start drawing."
MOVE win,0,30:PRINT win,"To draw smooth lines,hold the left mouse"
MOVE win,0,45:PRINT win,"button down and move the mouse around"
MOVE win,0,60:PRINT win,"in the drawing area."
MOVE win,0,75:PRINT win,"To draw straight lines,click in the drawing"
MOVE win,0,90:PRINT win,"area.A line will be drawn from the last"
MOVE win,0,105:PRINT win,"point to where the mouse pointer is."
MOVE win,0,120:PRINT win,"To delete the last point/line drawn,press"
MOVE win,0,135:PRINT win, "the D key."
MOVE win,0,150:PRINT win, "The line is ended when you create a point"
MOVE win,0,165:PRINT win, "off the left side of the drawing area."
MOVE win,0,180:PRINT win,"When you have finished drawing,click on"
MOVE win,0,195:PRINT win,"the ",CHR$(34),"Drawing finished",CHR$(34)," button."
MOVE win,0,210:PRINT win,"N.B. The beginning of the line should be"
MOVE win,0,225:PRINT win,"higher up than the end else the object will"
MOVE win,0,240:PRINT win,"not render properly."
MOVE win,0,255:PRINT win,"Also line should not cross itself for the"
MOVE win,0,270:PRINT win,"same reason."
FRONTPEN win,RGB(200,200,200)
RETURN
SUB drawrubberbandline
DEF y:INT
'Erase old rubber band line
LINE win,rubberbandstartx,rubberbandstarty,rubberbandendx,rubberbandendy,0
IF mousex>latheaxisx
IF numberoflinepoints=0
'Find y value where line enters drawing area
y=oldmousey+(mousey-oldmousey)*((latheaxisx-oldmousex)/(mousex-oldmousex))
LINE win,latheaxisx,y,mousex,mousey
rubberbandstartx=latheaxisx:rubberbandstarty=y
ELSE
LINE win,linepointx[numberoflinepoints],linepointy[numberoflinepoints],mousex,mousey
drawline
rubberbandstartx=linepointx[numberoflinepoints]:rubberbandstarty=linepointy[numberoflinepoints]
ENDIF
rubberbandendx=mousex:rubberbandendy=mousey
ELSE
'Mouse is to left of drawing area
IF numberoflinepoints>0
'Find where line crossed into drawing area
y=mousey+(latheaxisx-mousex)*(linepointy[numberoflinepoints]-mousey)/(linepointx[numberoflinepoints]-mousex)
LINE win,linepointx[numberoflinepoints],linepointy[numberoflinepoints],latheaxisx,y
drawline
rubberbandstartx=linepointx[numberoflinepoints]:rubberbandstarty=linepointy[numberoflinepoints]
rubberbandendx=latheaxisx:rubberbandendy=y
ENDIF
ENDIF
RETURN
SUB initialisevariables
'Set up initial colours in colour box
red[0]=200:green[0]=200:blue[0]=200
red[1]=255:green[1]=0:blue[1]=0
red[2]=0:green[2]=255:blue[2]=0
red[3]=0:green[3]=0:blue[3]=255
red[4]=255:green[4]=255:blue[4]=0
red[5]=255:green[5]=0:blue[5]=255
red[6]=0:green[6]=255:blue[6]=255
red[7]=150:green[7]=100:blue[7]=0
FOR linepoint=0 TO 9999
linecolournumber[linepoint]=0
pointadded[linepoint]=0
NEXT linepoint
currentcolour=0
numberoflinepoints=0:readytostartline=0:linefinished=0
screen="drawing"
RETURN
SUB createwindowandcontrols
WINDOW win,0,0,640,480,@MINBOX|@NOAUTODRAW,0,"Jolly Lather",mainwindow
DRAWMODE win,@TRANSPARENT
'Create button
CONTROL win,"B,Drawing finished,50,390,150,20,0,1"
'Disable button (so greyed out)
ENABLECONTROL win,1,0
'Create edit box.Allow only numbers to be entered
CONTROL win,"E,,200,300,50,20,@CTEDITNUMBER,2"
'Allow only two digits in edit box
CONTROLCMD win,2,@EDSETLIMITTEXT,2
'Set number of lathe sections
SETCONTROLTEXT win,2,LTRIM$(STR$(numberofsections))
'Hide edit box
SHOWWINDOW win,@SWHIDE,2
'Create smooth/flat check box
CONTROL win,"C,Smooth,4,250,80,20,@GROUP,3"
'Set background colour to white
SETCONTROLCOLOR win,3,0,RGB(255,255,255)
'Set smooth/flat
SETSTATE win,3,smooth
'Hide check box
SHOWWINDOW win,@SWHIDE,3
'Create save object button
CONTROL win,"B,Save previewed object,40,435,170,20,0,4"
'Disable button (so greyed out)
ENABLECONTROL win,4,0
'Hide button
SHOWWINDOW win,@SWHIDE,4
'Create start new object button
CONTROL win,"B,Start new object,55,412,140,20,0,5"
'Disable button (so greyed out)
ENABLECONTROL win,5,0
'Hide button
SHOWWINDOW win,@SWHIDE,5
FRONTPEN win,0
RETURN
SUB removepoint
FOR pointinline=linepoint TO numberoflinepoints-1
linepointx[pointinline]=linepointx[pointinline+1]
linepointy[pointinline]=linepointy[pointinline+1]
linecolournumber[pointinline]=linecolournumber[pointinline+1]
pointadded[pointinline]=pointadded[pointinline+1]
NEXT pointinline
numberoflinepoints=numberoflinepoints-1
RETURN
SUB findycentreofline
DEF ymin,ymax:INT
'Find y value of middle of line so object is created centred on 3D origin
ymin=10000:ymax=-10000
FOR linepoint=1 TO numberoflinepoints
IF linepointy[linepoint]<ymin THEN ymin=linepointy[linepoint]
IF linepointy[linepoint]>ymax THEN ymax=linepointy[linepoint]
NEXT linepoint
ycentreofline=(ymax+ymin)/2
RETURN
'********************************
'If the setupdata routine contains object data then the object will be dislayed when
'the programme is run.If you delete all the lines between "SUB setupdata and "RETURN"
'then the drawing screen will appear when run.
'To view objects saved as IBasic subroutines copy and paste the saved routines to
'replace the one below.
'********************************
SUB setupdata
numberoflinepoints=46
smooth=1
numberofsections=12
latheaxisx=280
red=161,0,0,0,255,0,0,0
green=161,0,0,0,255,0,0,0
blue=200,0,0,0,0,0,0,0
linepointx[1]=0,45,49,52,55,64,68,70,74,77,80,79,65,60,53,50,47,47,52,63,63
linepointy[1]=-109,-109,-107,-104,-101,-98,-95,-91,-83,-68,-17,-12,24,31,42,51,66,72,88,113,113
linecolournumber[1]=0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
linepointx[21]=63,66,70,70,68,60,57,54,54,56,58,61,64,76,80,84,85,86,85,83,80
linepointy[21]=113,116,114,108,104,88,79,64,58,54,50,47,38,14,0,-20,-31,-48,-59,-75,-84
linecolournumber[21]=0,0,0,0,0,0,0,0,0,0,4,4,0,4,0,4,0,4,0,4,0
linepointx[41]=80,75,72,62,53,0
linepointy[41]=-84,-98,-102,-111,-117,-117
linecolournumber[41]=0,0,4,0,0,0
RETURN