Another one for Christmas by the Master of 3D Jolly Roger himself !
So cute!
'Merry Christmas
'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 savebitmap(width:INT,height:INT)
DECLARE cone(numberofsections:INT,smooth:INT,bottomfacepresent:INT,heighttowidthratio:FLOAT)
DECLARE cylinder(numberofsections:INT,topfacepresent:INT,bottomfacepresent:INT,smooth:INT)
DEF win:WINDOW
DEF error,run:INT
DEF mult,snowy,treex[9],treez[9],lastcamerax,lastcameraz,camerax,cameraz,cameraposn[3]:FLOAT
DEF scene,camera,light,lastframetime,timesincelastframe,snowmanhead,snowmanbody,yaxispivot,n:INT
DEF ground,normal,facedata[10],vertex1,vertex2,vertex3,vertex4,nose,eye1,eye2,showscene:INT
DEF light2,light3,light4,rand,snow,halfsnowheight,collision,hattop,hatbrim,musicstarttime:INT
DEF treetrunk[9],treetop[9],treemiddle[9],bottomleaves[9],middleleaves[9],topleaves[9]:INT
DEF rd[256,256],gn[256,256],bl[256,256]:CHAR
DEF istranslation,generatingtexture,savingtexture,generatingsnow,proportioncomplete:INT
DEF wrap[13]:FLOAT
DEF file:BFILE
DEF command:STRING
wrap=0,0,0, 0,1,0, 0,0,1, 0,0, .01,.01
halfsnowheight=300
'Open a window
WINDOW win,0,0,640,480,@CAPTION|@NOAUTODRAW,0,"Merry Christmas",mainwindow
'Check if midi file present
error=OPENFILE(file,GETSTARTPATH+"wewishuamerryxmas-edited-recreated.mid","R")
IF error
'Midi file is not present.Create it
DECLARE createmidi(w:WINDOW)
createmidi(win)
ELSE
'Midi is present.Close it
CLOSEFILE file
ENDIF
'Declare function to play midi and open midi file
DECLARE "winmm",mciSendStringA(lpszCommand:STRING,lpszReturnString:STRING,cchReturn:INT,hwndCallback:INT),INT
command="open "+CHR$(34)+GETSTARTPATH+"wewishuamerryxmas-edited-recreated.mid"+CHR$(34)+" type MpegVideo alias sound"
mciSendStringA(command,"",0,0)
'Create a 640x480 16 bit colour 3D screen
error=CREATE3DSCREEN(win,640,480,16)
IF error<>0
'Couldn't open Direct3D screen
MESSAGEBOX win, "Could not create Direct3D screen","Error"
CLOSEWINDOW win
END
ENDIF
D3DSETQUALITY win,@LIGHTON | @FILLSOLID | @SHADEGOURAUD
FRONTPEN win,RGB(255,255,255)
BACKPEN win,0
DRAWMODE win,@TRANSPARENT
error=OPENFILE (file,GETSTARTPATH+"snow-texture.bmp","R")
IF error
generatingtexture=1
'Snow texture bitmap is not present so create it
'Create colour data for snow texture
FOR x=0 TO 255
FOR y=0 TO 255
rand=RND(20)+210
rd[x,y]=rand-10:gn[x,y]=rand-10:bl[x,y]=rand
NEXT y
'Allow progress bar to be redrawn
IF x%5=0
proportioncomplete=x
WAIT 1
ENDIF
NEXT x
generatingtexture=0
savingtexture=1
savebitmap(256,256)
savingtexture=0
ELSE
'Snow texture bitmap is present
CLOSEFILE file
ENDIF
'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,45,-700
D3DCOMMAND camera,@SETORIENTATION,scene,0,0,1,0,1,0
'Create and orient a light source from front left
light = D3DLIGHT(scene,@LIGHTDIRECTIONAL,.75,.75,.75)
D3DCOMMAND light,@SETORIENTATION,scene,-1,-1,1, -1,1,1
'Create and orient a light source from front right
light2 = D3DLIGHT(scene,@LIGHTDIRECTIONAL,.6,.6,.6)
D3DCOMMAND light2,@SETORIENTATION,scene,1,-1,1, 1,1,1
'Create and orient a light source from below
light3 = D3DLIGHT(scene,@LIGHTDIRECTIONAL,1,1,1)
D3DCOMMAND light3,@SETORIENTATION,scene,0,1,0, 0,1,-1
'Create and orient a light source from back
light4 = D3DLIGHT(scene,@LIGHTDIRECTIONAL,1,1,1)
D3DCOMMAND light4,@SETORIENTATION,scene,0,-1,-1, 0,1,1
'Create ground
ground=D3DSHAPE(scene,@SHAPECUSTOM)
vertex1=D3DCOMMAND (ground,@ADDVERTEX,-700,0,700)
vertex2=D3DCOMMAND (ground,@ADDVERTEX,700,0,700)
vertex3=D3DCOMMAND (ground,@ADDVERTEX,700,0,-700)
vertex4=D3DCOMMAND (ground,@ADDVERTEX,-700,0,-700)
normal=D3DCOMMAND (ground,@ADDNORMAL,0,1,0)
facedata=4,vertex1,normal,vertex2,normal,vertex3,normal,vertex4,normal,0
D3DCOMMAND ground,@ADDFACES,facedata
D3DCOMMAND ground,@CUSTOMINIT
D3DCOMMAND ground,@CREATEWRAP,scene,@WRAPFLAT,wrap
D3DCOMMAND ground,@LOADTEXTURE,GETSTARTPATH+"snow-texture.bmp"
'Create trees
FOR n=0 TO 8
'Create trunks
treetrunk[n]=cylinder(12,1,0,1)
D3DCOMMAND treetrunk[n],@SCALE,10,40,10
D3DCOMMAND treetrunk[n],@SETSHAPECOLOR,.6,.4,0
'Create leaves
bottomleaves[n]=cone(12,1,1,1)
middleleaves[n]=cone(12,1,1,1)
topleaves[n]=cone(12,1,1,1)
'Colour bottom faces green
D3DCOMMAND bottomleaves[n],@SETFACECOLOR,12,0,.55,0
D3DCOMMAND middleleaves[n],@SETFACECOLOR,12,0,.55,0
D3DCOMMAND topleaves[n],@SETFACECOLOR,12,0,.55,0
'Work out pseudo random positions for trees
treex[n]=FLOOR((n/3)-1)*300+100-RND(200)
treez[n]=(1-n%3)*300+100-RND(200)
IF n=4
'Ensure tree not on top of snowman
treez[4]=50+RND(50)
ENDIF
D3DCOMMAND bottomleaves[n],@SCALE,40,30,40
D3DCOMMAND bottomleaves[n],@SETPOSITION,scene,treex[n],60,treez[n]
D3DCOMMAND middleleaves[n],@SCALE,32,22,32
D3DCOMMAND middleleaves[n],@SETPOSITION,scene,treex[n],90,treez[n]
D3DCOMMAND topleaves[n],@SCALE,22,15,22
D3DCOMMAND topleaves[n],@SETPOSITION,scene,treex[n],115,treez[n]
D3DCOMMAND treetrunk[n],@SETPOSITION,scene,treex[n],20,treez[n]
NEXT n
'Create snowman
snowmanhead=D3DSHAPE(scene,@SHAPESPHERE,14,10)
D3DCOMMAND snowmanhead,@SETPOSITION,scene,0,45,0
snowmanbody=D3DSHAPE(scene,@SHAPESPHERE,22,10)
D3DCOMMAND snowmanbody,@SETPOSITION,scene,0,16,0
'Create nose for snowman
nose=cone(12,1,0,2.8)
D3DCOMMAND nose,@ADDROTATION,1,0,0,-1.571
D3DCOMMAND nose,@SCALE,2,2,2
D3DCOMMAND nose,@SETPOSITION,scene,0,45,-13
'Colour nose orange
D3DCOMMAND nose,@SETSHAPECOLOR,1,.8,0
'Create eyes for snowman
eye1=D3DSHAPE(scene,@SHAPESPHERE,1.5,10)
D3DCOMMAND eye1,@ADDROTATION,1,0,0,-1.571
D3DCOMMAND eye1,@SETPOSITION,scene,-3.5,48,-12
D3DCOMMAND eye1,@SETSHAPECOLOR,.4,.4,.4
eye2=D3DSHAPE(scene,@SHAPESPHERE,1.5,10)
D3DCOMMAND eye2,@ADDROTATION,1,0,0,-1.571
D3DCOMMAND eye2,@SETPOSITION,scene,3.5,48,-12
D3DCOMMAND eye2,@SETSHAPECOLOR,.4,.4,.4
'Create hat for snowman
hattop=cylinder(12,0,0,1)
D3DCOMMAND hattop,@SCALE,10,10,10
D3DCOMMAND hattop,@SETPOSITION,scene,0,65,0
D3DCOMMAND hattop,@SETSHAPECOLOR,.4,.4,.4
hatbrim=cylinder(12,0,1,1)
D3DCOMMAND hatbrim,@SCALE,14,1,14
D3DCOMMAND hatbrim,@SETPOSITION,scene,0,55,0
D3DCOMMAND hatbrim,@SETSHAPECOLOR,.4,.4,.4
'Check if snow.x file exists
error=OPENFILE(file,GETSTARTPATH+"snow.x","R")
IF error
'Snow object does not exist so create it
createsnow
D3DCOMMAND snow,@SAVESHAPE,GETSTARTPATH+"snow.x",@FORMATTEXT,0
ELSE
CLOSEFILE file
snow=D3DSHAPE(scene,@SHAPECUSTOM)
D3DCOMMAND snow,@LOADSHAPE,GETSTARTPATH+"snow.x",0
ENDIF
DELETEFILE(GETSTARTPATH+"temporary.x")
run=1
SETFONT win,"Arial",50,600
FRONTPEN win,255
'Start music
mciSendStringA("play sound","",0,0)
musicstarttime=GetTickCount()
'Wait till music finished before showing 3D scene
WAITUNTIL (GetTickCount()>(musicstarttime+11000))|(run=0)
SETFONT win,"Arial",10,600
FRONTPEN win,0xFFFFFF
lastframetime=GetTickCount()-1
showscene=1
'Process messages until somebody closes us
WAITUNTIL run=0
'Delete all the frames
D3DDELETE light
D3DDELETE light2
D3DDELETE light3
D3DDELETE light4
D3DDELETE camera
FOR n=0 TO 8
D3DDELETE bottomleaves[n]
D3DDELETE treetrunk[n]
D3DDELETE middleleaves[n]
D3DDELETE topleaves[n]
NEXT n
D3DDELETE snowmanbody
D3DDELETE snowmanhead
D3DDELETE hattop
D3DDELETE hatbrim
D3DDELETE ground
D3DDELETE nose
D3DDELETE eye1
D3DDELETE eye2
D3DDELETE snow
D3DDELETE scene
'Hide cursor.Avoids possible cursor distortion
SETCURSOR win,@CSCUSTOM,0
'Stop midi music
mciSendStringA("close sound","",0,0)
CLOSEWINDOW win
END
SUB mainwindow
SELECT @CLASS
CASE @IDCHAR
IF (@CODE = ASC("Q")) | (@CODE = ASC("q")) THEN run = 0
CASE @IDCREATE
CENTERWINDOW win
CASE @IDCLOSEWINDOW
run=0
CASE @IDDXUPDATE
IF showscene
'Find time since last frame to make things run at a constant speed
timesincelastframe=GetTickCount()-lastframetime
IF timesincelastframe>2
lastframetime=GetTickCount()
mult=timesincelastframe/8
istranslation=0
'Move the camera using the arrow keys
'Up arrow
IF(GETKEYSTATE(0x26))
D3DCOMMAND camera,@ADDTRANSLATION,0,0,mult
istranslation=1
ENDIF
'Down arrow
IF(GETKEYSTATE(0x28))
D3DCOMMAND camera,@ADDTRANSLATION,0,0,-mult
istranslation=1
ENDIF
'Left arrow
IF(GETKEYSTATE(0x25))
D3DCOMMAND camera,@ADDROTATION,0,1,0,-.005*mult
ENDIF
'Right arrow
IF(GETKEYSTATE(0x27))
D3DCOMMAND camera,@ADDROTATION,0,1,0,.005*mult
ENDIF
'Move snow
snowy=snowy-mult
IF snowy<-halfsnowheight THEN snowy=snowy+halfsnowheight
D3DCOMMAND snow,@SETPOSITION,scene,0,snowy,0
'Find camera position
D3DCOMMAND camera,@GETPOSITION,scene,cameraposn
camerax=cameraposn[0]:cameraz=cameraposn[2]
'If camera translation then check for collisions
IF istranslation
'Check for collisions
collision=0
'Check for snowman collision
IF ABS(camerax)<25
IF ABS(cameraz)<25
'Hit snowman
collision=1
ENDIF
ENDIF
'Check for tree collisions
FOR n=0 TO 8
IF ABS(treex[n]-camerax)<15
IF ABS(treez[n]-cameraz)<15
'Hit tree
collision=1
ENDIF
ENDIF
NEXT n
IF collision
'Reset camera to position before collision
camerax=lastcamerax:cameraz=lastcameraz
D3DCOMMAND camera,@SETPOSITION,scene,camerax,45,cameraz
ENDIF
ENDIF
lastcamerax=camerax:lastcameraz=cameraz
'Render the scene to the DirectX surface
D3DRENDER scene,camera
'Add any 2D elements after the scene is rendered.
MOVE win,10,10:PRINT win,"Move around the scene using the arrow keys.Press Q to exit"
'Show the DirectX surface
DXFLIP win,0,0
ENDIF
ELSE
IF generatingtexture|savingtexture|generatingsnow
DXFILL win,0
MOVE win,100,220
IF generatingtexture
PRINT win,"Generating 192k texture"
ENDIF
IF savingtexture
PRINT win,"Saving texture"
ENDIF
IF generatingsnow
PRINT win,"Generating .x file"
ENDIF
RECT win,100,250,256,20
RECT win,100,250,proportioncomplete,20,0xFFFFFF,0xFFFFFF
ELSE
DXFILL win,0xFFFFFF
MOVE win,50,200:PRINT win,"Merry Christmas"
ENDIF
DXFLIP win,0,0
ENDIF
ENDSELECT
RETURN
SUB savebitmap(width,height)
'N.B.Width and height must be multiples of four for simple method to work
DEF twobytes:WORD
DEF filelength:INT
DEF integer:INT
DEF file:BFILE
DEF byte:CHAR
TYPE threebytes
DEF blue:CHAR
DEF green:CHAR
DEF red:CHAR
ENDTYPE
DEF colourdata:threebytes
filelength=54+width*height*3
error=OPENFILE (file,GETSTARTPATH+"snow-texture.bmp","W")
'Write header
byte=ASC("B"):WRITE file,byte
byte=ASC("M"):WRITE file,byte
WRITE file,filelength
integer=0:WRITE file,integer
integer=54:WRITE file,integer
integer=40:WRITE file,integer
WRITE file,width
WRITE file,height
twobytes=1:WRITE file,twobytes
twobytes=24:WRITE file,twobytes
integer=0
WRITE file,integer:WRITE file,integer:WRITE file,integer
WRITE file,integer:WRITE file,integer:WRITE file,integer
'Write colour data
FOR y=height-1 TO 0 STEP -1
FOR x=0 TO width-1
colourdata.red=rd[x,y]:colourdata.green=gn[x,y]:colourdata.blue=bl[x,y]
WRITE file,colourdata
NEXT x
'Allow progress bar to be redrawn
IF y%5=0
proportioncomplete=256*(height-y)/height
WAIT 1
ENDIF
NEXT y
CLOSEFILE file
RETURN
SUB createsnow
generatingsnow=1
DEF halfnumberofsnowflakes,facedata[29]:INT
DEF normal0,normal1,normal2,normal3,n:INT
DEF snowflakesize,snowflakex,snowflakey,snowflakez:FLOAT
halfnumberofsnowflakes=300:snowflakesize=1
n=8*halfnumberofsnowflakes
DEF vertex[n]:INT
snow=D3DSHAPE(scene,@SHAPECUSTOM)
normal0=D3DCOMMAND (snow,@ADDNORMAL,0,-1,1)
normal1=D3DCOMMAND (snow,@ADDNORMAL,1,-1,-1)
normal2=D3DCOMMAND (snow,@ADDNORMAL,-1,-1,-1)
normal3=D3DCOMMAND (snow,@ADDNORMAL,0,1,0)
FOR sf=0 TO halfnumberofsnowflakes-1
snowflakex=-700+RND(1400):snowflakey=RND(halfsnowheight):snowflakez=-700+RND(1400)
FOR n=0 TO 4 STEP 4
'If n=4 then create snowflake halfsnowheight above one created when n=0
'This is to allow the snow to appear to fall continually
IF n=4 THEN snowflakey=snowflakey+halfsnowheight
'Create vertices for snowflake
vertex[sf*8+n]=D3DCOMMAND (snow,@ADDVERTEX,snowflakex,snowflakey,snowflakez+2*snowflakesize)
vertex[sf*8+n+1]=D3DCOMMAND (snow,@ADDVERTEX,snowflakex+snowflakesize,snowflakey,snowflakez-snowflakesize)
vertex[sf*8+n+2]=D3DCOMMAND (snow,@ADDVERTEX,snowflakex-snowflakesize,snowflakey,snowflakez-snowflakesize)
vertex[sf*8+n+3]=D3DCOMMAND (snow,@ADDVERTEX,snowflakex,snowflakey+snowflakesize,snowflakez)
'Create faces for snowflake
facedata=3,vertex[sf*8+n+2],normal2,vertex[sf*8+n+1],normal1,vertex[sf*8+n],normal0
facedata[7]=3,vertex[sf*8+n],normal0,vertex[sf*8+n+1],normal1,vertex[sf*8+n+3],normal3
facedata[14]=3,vertex[sf*8+n+1],normal1,vertex[sf*8+n+2],normal2,vertex[sf*8+n+3],normal3
facedata[21]=3,vertex[sf*8+n+2],normal2,vertex[sf*8+n],normal0,vertex[sf*8+n+3],normal3,0
D3DCOMMAND snow,@ADDFACES,facedata
NEXT n
'Allow progress bar to be redrawn
IF sf%5=0
proportioncomplete=256*sf/halfnumberofsnowflakes
WAIT 1
ENDIF
NEXT sf
D3DCOMMAND snow,@CUSTOMINIT
generatingsnow=0
RETURN
SUB createmidi(w)
DEF d[20]:STRING
DEF data$[70]:ISTRING
DEF mem:MEMORY
DEF file:BFILE
DEF numberofcharacters,filelength,c,bytenumber,startposn,progressbarstep,intdata:INT
DEF byte1,byte2,byte3,d1,d2,d3,d4,d5:CHAR
ALLOCMEM (mem,1,70)
d="C:$s<$qpY)$;:J(>+*00##&gVttAB,'i>7iKhMJ_tt?haFcRwWDn^M>-GX<2-?V\-2ha8M"
d[1]="-H0G?CW14r-EV=6DQdWSFguA2H*M(w$Dd]*%V,WH$(_)w#%rg$##$^R$X%v_2LZW[2L7*8"
d[2]="2gd6<EP>DM4&#]Y'vHV\9i;L/Gd2/$;f$9^#*hTO$W2FW%SR1C#AsKE$;1A'Ej8>V-H0N;"
d[3]="->XfN->XfN->XfN=Ub@W6JVXtLOt*1QW?A;LTl8tQ`*0=LRipaQWl_E8$%018^.Oo7ZC65"
d[4]="KoD.'&Bd8KEJv0;[vK@IQV7pKLV\J-Q^9t)%aBKj5)_\[H-8S@;iF)u=j'1u'9#<5B#R4)"
d[5]="#)kw*B#d:)LJE;fQ`<<ALJE>f7^t^Q6JYP.6Hrul6JYt:6Hsl19AN%*9?hV49AN709?fHL"
d[6]="9\h+c9[-hl9AK`>9?gPj8_j]A8^1Ai8)4H>8'QD67,:;#LJ39PQ]+1sLPgSIQYo'SLP0r="
d[7]="QZPKY%aBKj5)_\[LW`'N7ZW+CKoD.D7Z;o@KoM4p8'Oue2G4%=Gb@c7###$9L._Oe$sNmL"
d[8]="CUw)N-FdL.:QS/G#AsKE$;1A'H*'DN->XgL->XfN->XfN->XfN7h,NF0A\tNLrb2$Qr$&#"
d[9]="2pHW''oX`wM8q78#f/)rLPvk@Is7'C7X9Sk2;Wc:0vTpPR#$<^Lf/\ZJBgE:$`boHLPvqB"
d[10]="#)k0wLs%C:7X9TqKmf,32pO2538P.61JEGK36hTQ1OanD1u8Y0Lk1-0QrcP/7a6:6Lg5(["
d[11]=".*Y#2Qs)b4,gLml#)jwd;bSlJ#.JWU#4qpw$X8-aCQes:B>.ru:RN?Ftt@X[##,,F8RM[("
d[12]="C;+W'->XgL->XfN->XfN#&GE.7aM5X#0/ak4%sveM3NV84&/&)7Yh29G(l-=#.lv$(<pWU"
d[13]="&WAa+6;Be,45V9OI#7pDLqYoR7Z)i-$B-iIR:wpN6qhQaE.J#77*cV&7YUr4-]Bom#/E1b"
d[14]="4%sR[G)$(86-hFD7Z%D=#)kKIR>jIm4%s[WGD?1@LVc5Y7Y-2&%#d,Q5u'\46Jj2[I>e0J"
d[15]="Lq#BI7Z;u$$]I#JR<:c\4\Ts`G)QFE6I,_f7Y;,<3/g++#/rUi4\U$fI>IsH4jQCK7YLu6"
d[16]="%?*PUR=RVi7SIcfGCon>?G\^+&r\j,7TVj;7Yq><I>X5b#.llv6;2QlM0+?q6;0Y67Z%J?"
d[17]="9oM)B#0/ak6;2E\6I1/-7YN+V(Q:4`#.lb[5YQBh5gOMm7Z%PA7>s*1#/WRk5YQ9\M+iKL"
d[18]="6r6.07YVDAG`7iB#/)rvM6CQX6=<'@7Z7G<Ee0FI#/E6&7ne&kM/%Xf5>4>'7Yh&5#)kiO"
d[19]="##$^R"
OPENFILE (file,GETSTARTPATH+"wewishuamerryxmas-edited-recreated.mid","W")
RECT w,0,0,200,20
filelength=1067:numberofcharacters=1335
progressbarstep=5*CEIL(numberofcharacters/100)
FOR c=0 TO numberofcharacters-1 STEP 5
startposn=c%70
IF startposn=0
data$=d[c/70]
WRITEMEM mem,1,data$
ENDIF
READMEM mem,1,d1,startposn
READMEM mem,1,d2,startposn+1
READMEM mem,1,d3,startposn+2
READMEM mem,1,d4,startposn+3
READMEM mem,1,d5,startposn+4
'Convert five characters to four bytes of data
intdata=52200625*(d1-35)+614125*(d2-35)+7225*(d3-35)+85*(d4-35)+(d5-35)
IF bytenumber<=filelength-4
WRITE (file,intdata)
bytenumber=bytenumber+4
ELSE
'Less than four bytes of data left
byte1=intdata & 0xFF
byte2=(intdata & 0xFF00)/0x100
byte3=(intdata & 0xFF0000)/0x10000
IF bytenumber<filelength THEN WRITE (file,byte1)
IF bytenumber<filelength-1 THEN WRITE (file,byte2)
IF bytenumber<filelength-2 THEN WRITE (file,byte3)
ENDIF
IF c%progressbarstep=0 THEN RECT w,0,0,200*c/numberofcharacters,20,0,0
NEXT c
CLOSEFILE file
FREEMEM mem
RECT w,0,0,200,20,0xFFFFFF,0xFFFFFF
RETURN
SUB cone(numberofsections,smooth,bottomfacepresent,heighttowidthratio)
DEF shape,vertex[numberofsections+1],topnormal[numberofsections]:INT
DEF bottomnormal[numberofsections],section,facedata[100],bottomfacenormal:INT
DEF angle,normaly,xznormalmult:FLOAT
shape=D3DSHAPE(scene,@SHAPECUSTOM)
'Create top vertex
vertex[0]=D3DCOMMAND(shape,@ADDVERTEX,0,2*heighttowidthratio,0)
'Calculate y component of side normals
normaly=COS(ATAN(2*heighttowidthratio))
'Calculate multiplier for x and z components of side normals
xznormalmult=SIN(ATAN(2*heighttowidthratio))
'Create bottom vertices and normals for bottom of side faces if needed
FOR section=0 TO numberofsections-1
angle=section*6.283/numberofsections
vertex[section+1]=D3DCOMMAND(shape,@ADDVERTEX,SIN(angle),0,COS(angle))
IF smooth
bottomnormal[section]=D3DCOMMAND(shape,@ADDNORMAL,SIN(angle)*xznormalmult,normaly,COS(angle)*xznormalmult)
ENDIF
NEXT section
'Create normals for top of side faces
FOR section=0 TO numberofsections-1
angle=(section+.5)*6.283/numberofsections
topnormal[section]=D3DCOMMAND(shape,@ADDNORMAL,SIN(angle)*xznormalmult,normaly,COS(angle)*xznormalmult)
NEXT section
'Create side faces
FOR section=0 TO numberofsections-1
IF section<>numberofsections-1
IF smooth
facedata=3,vertex[0],topnormal[section],vertex[section+1],bottomnormal[section],vertex[section+2],bottomnormal[section+1],0
ELSE
facedata=3,vertex[0],topnormal[section],vertex[section+1],topnormal[section],vertex[section+2],topnormal[section],0
ENDIF
ELSE
IF smooth
facedata=3,vertex[0],topnormal[0],vertex[numberofsections],bottomnormal[numberofsections-1],vertex[1],bottomnormal[0],0
ELSE
facedata=3,vertex[0],topnormal[numberofsections-1],vertex[numberofsections],topnormal[numberofsections-1],vertex[1],topnormal[numberofsections-1],0
ENDIF
ENDIF
D3DCOMMAND shape,@ADDFACES,facedata
NEXT section
'Add bottom face if present
IF bottomfacepresent
bottomfacenormal=D3DCOMMAND(shape,@ADDNORMAL,0,-1,0)
facedata[0]=numberofsections
FOR section=0 TO numberofsections-1
facedata[1+2*section]=vertex[numberofsections-section],bottomfacenormal
NEXT section
facedata[2*numberofsections+1]=0
D3DCOMMAND shape,@ADDFACES,facedata
ENDIF
D3DCOMMAND shape,@CUSTOMINIT
RETURN shape
SUB cylinder(numberofsections,topfacepresent,bottomfacepresent,smooth)
'Function creates a cylinder with the given number of sections.Minimum number of sections is three.
'topfacepresent,bottomfacepresent and smooth should be 0 or 1.
'If smooth is set to one then cylinder sides will appear smooth if @SHADEGOURAUD used.
'If smooth set to zero then sides will appear flat even if @SHADEGOURAUD is used.
'Jolly Roger March 2003
DEF shape,numberofvertices,topnormal,bottomnormal:INT
DEF x,z:FLOAT
IF numberofsections>2
shape=D3DSHAPE(scene,@SHAPECUSTOM)
numberofvertices=numberofsections*2
DEF vertex[numberofvertices],normal[numberofsections],facedata[((2*numberofsections)+5)]:INT
'Create vertices and side face normals
FOR section=0 TO numberofsections-1
x=SIN(6.28*section/numberofsections)
z=COS(6.28*section/numberofsections)
IF smooth=0
normal[section]=D3DCOMMAND(shape,@ADDNORMAL,SIN(6.28*(section+.5)/numberofsections),0,COS(6.28*(section+.5)/numberofsections))
ELSE
normal[section]=D3DCOMMAND(shape,@ADDNORMAL,x,0,z)
ENDIF
vertex[section]=D3DCOMMAND (shape,@ADDVERTEX,x,1,z)
vertex[section+numberofsections]=D3DCOMMAND (shape,@ADDVERTEX,x,-1,z)
NEXT section
'Create faces
IF topfacepresent=1
'Top face
facedata[0]=numberofsections
topnormal=D3DCOMMAND(shape,@ADDNORMAL,0,1,0)
FOR section=0 TO numberofsections-1
facedata[section*2+1]=vertex[section],topnormal
NEXT section
facedata[2*numberofsections+1]=0
D3DCOMMAND (shape,@ADDFACES,facedata)
ENDIF
IF bottomfacepresent=1
'Bottom face
facedata[0]=numberofsections
bottomnormal=D3DCOMMAND(shape,@ADDNORMAL,0,-1,0)
FOR section=0 TO numberofsections-1
facedata[section*2+1]=vertex[2*numberofsections-section-1],bottomnormal
NEXT section
facedata[2*numberofsections+1]=0
D3DCOMMAND (shape,@ADDFACES,facedata)
ENDIF
'Side faces
facedata[0]=4
FOR section=0 TO numberofsections-1
facedata[1]=vertex[section],normal[section],vertex[section+numberofsections],normal[section]
IF section<>numberofsections-1
facedata[5]=vertex[section+1+numberofsections],normal[section+1],vertex[section+1],normal[section+1]
ELSE
facedata[5]=vertex[numberofsections],normal[0],vertex[0],normal[0]
ENDIF
IF smooth=0
facedata[6]=normal[section]
facedata[8]=normal[section]
ENDIF
facedata[9]=0
D3DCOMMAND (shape,@ADDFACES,facedata)
NEXT section
D3DCOMMAND shape,@CUSTOMINIT
ENDIF
RETURN shape