3D "Jolly Modeller" by Jolly Roger

[pistol350]

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.

Code Select Expand


'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


[GWS]

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