3D Jolly lather by Jolly Roger

[pistol350]

have fun creating the shapes that come to your mind

Code Select Expand

'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