Sorry your browser is not supported!

sync on
autocam off
color backdrop 0
hide light 0
make light 1
set light range 1,3
set ambient light 0
make object sphere 1,1,4,4
position object 1,0,0,1.5
sync
get image 1000,screen width()*.25,screen height()*.25,screen width()*.75,screen width()*.75,1
delete object 1
color backdrop rgb(150,150,250)
position camera 0,2.5,0

radius=100
height=30
velocity#=0.12
numberofflakes=1000
for n=1000 to 1000+numberofflakes
make object box n,2*4/3.0,2,0.01
set object light n,0
texture object n,1000
set object transparency n,5
ghost object on n,2
set alpha mapping on n,40
position object n,camera position x()+rnd(radius*2)-radius,camera position y()+rnd(height),camera position z()+rnd(radius*2)-radius
rotate object n,rnd(360),rnd(360),rnd(360)
next n

make matrix 1,100,100,20,20
position matrix 1,-50,0,-50

do
for n=1000 to 1000+numberofflakes
position object n,object position x(n),object position y(n)-velocity#,object position z(n)
yrotate object n,object angle y(n)+1
if object position y(n)<get ground height(1,object position x(n),object position z(n))
position object n,camera position x()+rnd(radius*2)-radius,camera position y()+height,camera position z()+rnd(radius*2)-radius
endif
next n
control camera using arrowkeys 0,0.1,1
sync
loop

Rem Project: snowscene
Rem Created: 01/12/2005 20:00:06

Rem ***** Main Source File *****

`Snowy Island by Ric
`Thanks to Lost in Thought for the matrix to mesh function
detail=80

`display settings
if check display mode(1024,768,32)=1 then set display mode 1024,768,32
sync on
sync rate 35
hide mouse

autocam off
hide light 0
color backdrop 0
set ambient light 0
make light 1
set light range 1,3


create bitmap 1,screen width(),screen height()

`snowflake image
make object sphere 1,1,4,4
position object 1,0,0,1.5
sync
snowflake=free_image()
get image snowflake,screen width()*.25,screen height()*.25,screen width()*.75,screen width()*.75,1
delete object 1

position light 1,0,0,-1
set light range 1,2

make object sphere 1,1,100,100
set object specular power 1,20
set object specular 1,rgb(255,255,255)
position camera 0,0,-2
sync
sun=free_image()
get image sun,screen width()/4,screen height()/4,screen width()*.75,screen height()*.75,1
set object light 1,0
sync
flare1=free_image()
get image flare1,screen width()/4,screen height()/4,screen width()*.75,screen height()*.75,1
delete object 1

delete bitmap 1
text 0,0,"Please wait ......"
sync

`camera and light settings

set camera range 0.01,10000
position camera 64,0,64
color backdrop 0
set ambient light 20


`set the randomize seed to the timer, so random events are different each time
randomize timer()

`set size of terrain
global matrixsize
matrixsize=128

`fog settings
fog on
fog color rgb(200,200,200)
fog distance matrixsize

`set initial value for object numbers
global object_seed
object_seed=1000000

`set initial value for image numbers
global image_seed
image_seed=1000000

`position light for world illumination
position light 1,200,80,200
set light range 1,100000
make object cube 1,1
hide object 1
position object 1,light position x(1),light position y(1),light position z(1)

global skyimage
create_sky()
global snowimage
create_snowimage()
global snow

global height#
global rows
global columns
global terrainimage
`set size of terrain
rows=detail
columns=detail
global peaksoff
global peaksoff2
global dim peakx(100)
global dim peakz(100)
global dim peakh(100)
global dim peakx2(100)
global dim peakz2(100)
global dim peakh2(100)
terraform()
Matrix_to_Object(1000,1,128,128,rows,rows,rows,rows,rows,rows)

`make some buildings
global doortexture
make_door_texture()
global housetexture
make_house_texture()
`set house variables
global number_of_houses
number_of_houses=15
`set up an array to store house numbers
global dim house(number_of_houses)
global dim door(number_of_houses)
global dim roof(number_of_houses)

for house_number=1 to number_of_houses
  make_house(house_number)
next house_number

gosub calculate_shadows
delete object 1000

`hide buildings for skysphere image grab
for n=house(1) to house(number_of_houses)+2
hide object n
next n

global sphere1
global sphere2
global sphere3
create_skysphere()
create_snow()


for n=house(1) to house(number_of_houses)+2
show object n
next n

sunplane=free_object()
make object plain sunplane,160*4/3.0,160
set object fog sunplane,0
texture object sunplane,sun
set object light sunplane,0
ghost object on sunplane,2
set object transparency sunplane,2
flareplane1=free_object()
make object plain flareplane1,0.3*4/3.0,0.3
texture object flareplane1,flare1
set object light flareplane1,0
set alpha mapping on flareplane1,20
position object flareplane1,0,-0.5,0
`reference object for distant light source
dummy=free_object()
make object cube dummy,1
hide object dummy
point object dummy,light position x(1),light position y(1),light position z(1)
move object dummy,10000

`make snowflakes
radius=100
height=30
velocity#=0.12
numberofflakes=500
n=1000
make object box n,2*4/3.0,2,0.01
set object light n,0
texture object n,snowflake
set object transparency n,1
set object fog n,0
ghost object on n,2
set alpha mapping on n,40

for n=1001 to 1000+numberofflakes
instance object n,1000
set object transparency n,1
set object fog n,0
ghost object on n,2
set alpha mapping on n,40
position object n,camera position x()+rnd(radius*2)-radius,camera position y()+rnd(height),camera position z()+rnd(radius*2)-radius
rotate object n,rnd(360),rnd(360),rnd(360)
next n

position camera 64,height#+2+get ground height(1,64,64),64


`main program loop
do

move_camera()

position object sunplane,camera position x(),camera position y(),camera position z()
point object sunplane,object position x(dummy),object position y(dummy),object position z(dummy)
move object sunplane,128*7
point object sunplane,camera position x(),camera position y(),camera position z()

for n=1000 to 1000+numberofflakes
position object n,object position x(n),object position y(n)-velocity#,object position z(n)
yrotate object n,object angle y(n)+1
if object position y(n)<get ground height(1,object position x(n),object position z(n))
position object n,camera position x()+rnd(radius*2)-radius,camera position y()+height,camera position z()+rnd(radius*2)-radius
endif
next n
text 0,0,str$(screen fps())

sync
loop

`****************************************

`functions

function terraform

`create terrain
make matrix 1,matrixsize,matrixsize,columns,rows
set matrix 1,0,0,0,2,0,1,0

for peak=1 to 50
peakh(peak)=rnd(15)+5
peakx(peak)=rnd(rows-8)+4
peakz(peak)=rnd(rows-8)+4
set matrix height 1,peakx(peak),peakz(peak),peakh(peak)
next peak
update matrix 1


for times=1 to 120
if times>=90 then peaksoff=1
smooth_matrix(1,rows,rows)
next times
peaksoff=0


endfunction

function smooth_matrix(matnum,tilex,tilez)

for x=2 to tilex-2
for z=2 to tilez-2
b=-get matrix height(matnum,x,z)+get matrix height(matnum,x,z+1)
d=-get matrix height(matnum,x,z)+get matrix height(matnum,x+1,z)
f=-get matrix height(matnum,x,z)+get matrix height(matnum,x,z-1)
h=-get matrix height(matnum,x,z)+get matrix height(matnum,x-1,z)
total=b+d+f+h

set matrix height matnum,x,z,get matrix height(matnum,x,z)+total*0.1

next z
next x



for peak=1 to 100
`peakh(peak)=peakh(peak)*0.999
if matnum=1
  if peaksoff=0 then set matrix height 1,peakx(peak),peakz(peak),peakh(peak)
endif
if matnum=2
  if peaksoff=0 then set matrix height 2,peakx2(peak),peakz2(peak),peakh2(peak)
endif
next peak

update matrix matnum
endfunction

function free_object

object=object_seed
repeat
inc object
until object exist(object)=0

endfunction object

function check_free_object_number

object=object_seed
repeat
inc object
until object exist(object)=0

endfunction object

function free_image

image=image_seed
repeat
inc image
until image exist(image)=0

endfunction image



function create_skysphere

`get image for sphere by taking snapshot of terrain
terrainimage=free_image()
set camera fov 90
fog off
position camera matrixsize/2.0,3,-matrixsize*0.3
sync
get image terrainimage,0,0,screen width(),screen height()
fog on
fog color rgb(200,200,200)
fog distance matrixsize
set camera fov 60


sphere2=free_object()
make object sphere sphere2,matrixsize*10
set object collision off sphere2
xrotate object sphere2,180
`yrotate object sphere2,30
set object cull sphere2,0
texture object sphere2,terrainimage
set object texture sphere2,2,0
scale object texture sphere2,8,2.6
set object fog sphere2,0
set object transparency sphere2,2
ghost object on sphere2,5
set alpha mapping on sphere2,20
set object emissive sphere2,rgb(80,60,100)
`set object specular power sphere2,100
`fade object sphere2,200
`set object light sphere2,0
position object sphere2,matrixsize/2,-135,matrixsize/2

`sphere 3 (sky) - a third, outer sphere for the sky
sphere3=free_object()
make object sphere sphere3,matrixsize*20
set object collision off sphere3
set object cull sphere3,0
texture object sphere3,skyimage
scale object texture sphere3,1,1.8
set object light sphere3,0
set object fog sphere3,0
position object sphere3,matrixsize/2,0,matrixsize/2

endfunction

function create_sky()
`creates a dark to light bluish gradient
cls
for n=0 to 250
  ink rgb(n,n-20,n-40),0
  line 0,n,250,n
next n

skyimage=free_image()
get image skyimage,0,0,250,250

endfunction

function create_snowimage

create bitmap 1,128,128
set current bitmap 1
ink rgb(255,255,255),0
box 0,0,128,128
for n=0 to 5000
tone=rnd(40)+200
ink rgb(tone+15,tone+10,tone),0
dot rnd(128),rnd(128)
next n
snowimage=free_image()
get image snowimage,0,0,128,128
delete bitmap 1

endfunction

function create_snow

`snow=free_object()
`make object plain snow,matrixsize*12,matrixsize*12
`xrotate object snow,-90
`set object fog snow,0
`set object light snow,0
`texture object snow,snowimage
`position object snow,0,1,0

make matrix 2,matrixsize*12,matrixsize*12,40,40
set matrix 2,0,0,1,2,0,1,1
prepare matrix texture 2,snowimage,40,40
tile=1
for x=40-1 to 0 step -1
for z=0 to 40-1
set matrix tile 2,z,x,tile
inc tile
next z
next x
position matrix 2,-matrixsize*6,-10,-matrixsize*6

for peak=1 to 60
peakx2(peak)=rnd(40-4)+2
peakz2(peak)=rnd(40-4)+2
if peakx2(peak)<15 or peakx2(peak)>25
if peakz2(peak)<15 or peakz2(peak)>25
peakh2(peak)=rnd(20)+10
endif
endif
set matrix height 2,peakx2(peak),peakz2(peak),peakh2(peak)
next peak
update matrix 2


for times=1 to 100
if times>=96 then peaksoff=1
smooth_matrix(2,40,40)
next times
peaksoff=0

update matrix 2

endfunction



function move_camera

control camera using arrowkeys 0,0.2,3
position camera camera position x(),height#+2+get ground height(1,camera position x(),camera position z()),camera position z()
if inkey$()="a" then inc height#,1
if inkey$()="z" then dec height#,1
endfunction

calculate_shadows:
undim pixelshaded1(128,128)
undim pixelshaded2(128,128)
dim pixelshaded1(128,128)
dim pixelshaded2(128,128)
`if light1>0
create bitmap 1,128,128
set current bitmap 1
ink rgb(255,255,255),0
box 0,0,128,128
for n=0 to 5000
tone=rnd(40)+200
ink rgb(tone+15,tone+15,tone),0
dot rnd(128),rnd(128)
next n
ink rgb(10,10,10),0
for y=0 to 128
for x=0 to 128

`shadows cast by objects
for object=house(1) to house(number_of_houses)
if object exist(object)
ray1#=intersect object(object,x,get ground height(1,x,y),y,light position x(1),light position y(1),light position z(1))
if ray1#=0 then ray1#=1000
if ray1#<0 then ray1#=1
if ray1#<=100
  tone=100+ray1#*10
  `if pixelshaded2(x,y)=1 or pixelshaded1(x,y)=1 then tone=tone/1.5
  if tone>255 then tone=255
  ink rgb(tone,tone,tone),0
  dot x,128-y
  `pixelshaded1(x,y)=1
endif
endif
next object

`shadows cast by terrain - matrix converted to object 1000
ray2#=intersect object(1000,x,get ground height(1,x,y)+0.1,y,light position x(1),light position y(1),light position z(1))
if ray2#=0 then ray2#=1000
if ray2#<0 then ray2#=1
if ray2#<=100
  tone=100+ray2#*10

  `if pixelshaded2(x,y)=1 or pixelshaded1(x,y)=1 then tone=tone/1.5
  if tone>255 then tone=255
  ink rgb(tone,tone,tone),0
  dot x,128-y
  `pixelshaded1(x,y)=1
endif


next x
next y
blur bitmap 1,3
shadowmap=5000000
get image shadowmap,0,0,128,128

delete bitmap 1
`set light mapping on 2,shadowmap
 `(light1 exist)

`texture matrix
prepare matrix texture 1,shadowmap,rows,columns
tile=1
for x=rows-1 to 0 step -1
for z=0 to columns-1
set matrix tile 1,z,x,tile
inc tile
next z
next x
`endif
update matrix 1

return

`Matrix to Object function by Lost in Thought - thanks.

function Matrix_to_Object( object, matrixnum, matxsize#, matzsize#, matxsegs, matzsegs, tilex, tilez, limbx, limbz )
   `safety in case limbx and limbz is smaller than the texture x and z
   a = 0
   if limbx < tilex then limbx = tilex : a = 1
   if limbz < tilez then limbz = tilez : a = 1
   if a > 0
      sync
      print "limbx or limbz was less than tilex or tilez : Error corrected"
      print "Press any key to continue."
      sync
      wait key
   endif
   `safety in case matxsegs and matzsegs is not evenly divisible by tilex and tilez
   if matxsegs mod tilex > 0
      EXIT PROMPT "Number of matrix xsegs not evenly divisible by tilex", "Texture tilex error"
      end
   endif
   if matzsegs mod tilez > 0
      EXIT PROMPT "Number of matrix zsegs not evenly divisible by tilez", "Texture tilez error"
      end
   endif
   `safety in case matxsegs and matzsegs is not evenly divisible by tilex and tilez
   if matxsegs mod limbx > 0
      EXIT PROMPT "Number of matrix xsegs not evenly divisible by limbx", "Texture tilex error"
      end
   endif
   if matzsegs mod limbz > 0
      EXIT PROMPT "Number of matrix zsegs not evenly divisible by limbz", "Texture tilez error"
      end
   endif

   `calc the number of polys in the matrix
   num_mat_polys = (matxsegs*matzsegs)*2
   `make array to store vert info
   `storage indexs = poly number, vert number, x/y/z vert pos/norm/uv
   `polys are numbered starting from left to right, front to
   `back, one row at a time (with 2 polys per tile)
   dim vert_store#(num_mat_polys,2,7)

   `calc the width and depth of each tile on the matrix
   `formula size#/number
   mat_x_wide# = matxsize#/matxsegs
   mat_z_deep# = matzsize#/matzsegs


`******************************************************************************
   `get vert position data
   `placeholder variable for poly numbers
   a = 1
   `one row at a time (front to back)
   for j = 0 to matzsegs - 1
      `one tile at a time (left to right)
      for i = 0 to matxsegs - 1

         `tile top left poly info

         `bottom left vert (x,y,z)
         vert_store#(a,0,0) = i*mat_x_wide#
         vert_store#(a,0,1) = GET MATRIX HEIGHT(matrixnum, i, j)
         vert_store#(a,0,2) = j*mat_z_deep#
         `top left vert (x,y,z)
         vert_store#(a,1,0) = i*mat_x_wide#
         vert_store#(a,1,1) = GET MATRIX HEIGHT(matrixnum, i, j+1)
         vert_store#(a,1,2) = (j+1)*mat_z_deep#
         `top right vert (x,y,z)
         vert_store#(a,2,0) = (i+1)*mat_x_wide#
         vert_store#(a,2,1) = GET MATRIX HEIGHT(matrixnum, i+1, j+1)
         vert_store#(a,2,2) = (j+1)*mat_z_deep#
         inc a, 1

         `tile bottom right poly info

         `bottom left vert (x,y,z)
         vert_store#(a,0,0) = i*mat_x_wide#
         vert_store#(a,0,1) = GET MATRIX HEIGHT(matrixnum, i, j)
         vert_store#(a,0,2) = j*mat_z_deep#
         `top right vert (x,y,z)
         vert_store#(a,1,0) = (i+1)*mat_x_wide#
         vert_store#(a,1,1) = GET MATRIX HEIGHT(matrixnum, i+1, j+1)
         vert_store#(a,1,2) = (j+1)*mat_z_deep#
         `bottom right vert (x,y,z)
         vert_store#(a,2,0) = (i+1)*mat_x_wide#
         vert_store#(a,2,1) = GET MATRIX HEIGHT(matrixnum, i+1, j)
         vert_store#(a,2,2) = j*mat_z_deep#
         inc a, 1
      next i
   next j
`******************************************************************************


`******************************************************************************
   `calc normals for polys
   `Thanks to ADR for posting this code on the DBP forums :)
   for i = 1 to num_mat_polys
      `acuire vert positions
      P1X# = vert_store#(i,0,0)
      P1Y# = vert_store#(i,0,1)
      P1Z# = vert_store#(i,0,2)
      P2X# = vert_store#(i,1,0)
      P2Y# = vert_store#(i,1,1)
      P2Z# = vert_store#(i,1,2)
      P3X# = vert_store#(i,2,0)
      P3Y# = vert_store#(i,2,1)
      P3Z# = vert_store#(i,2,2)

      null = make vector3(1)
      null = make vector3(2)
      null = make vector3(3)

      ` -- calculate the two directional vectors for the adj and opp edges...
      set vector3 1, P1X#, P1Y#, P1Z#
      set vector3 2, P2X#, P2Y#, P2Z#
      set vector3 3, P3X#, P3Y#, P3Z#
      subtract vector3 2, 2, 1
      subtract vector3 3, 3, 1   ` -- vector 3 and 1 are now directional vectors
      normalize vector3 2,2      ` -- normalize em
      normalize vector3 3,3
      cross product vector3 1, 2,3  ` -- use the origin vector (1) to store the face normal
      normalize vector3 1,1

      `save normals (all 3 verts have same normals)
      vert_store#(i,0,3) = x vector3(1)
      vert_store#(i,0,4) = y vector3(1)
      vert_store#(i,0,5) = z vector3(1)
      vert_store#(i,1,3) = vert_store#(i,0,3)
      vert_store#(i,1,4) = vert_store#(i,0,4)
      vert_store#(i,1,5) = vert_store#(i,0,5)
      vert_store#(i,2,3) = vert_store#(i,0,3)
      vert_store#(i,2,4) = vert_store#(i,0,4)
      vert_store#(i,2,5) = vert_store#(i,0,5)

      null = delete vector3(1)
      null = delete vector3(2)
      null = delete vector3(3)
   next i
`******************************************************************************


`******************************************************************************
   `calc UV data for polys

   `save current x tile number
   xtiles = 1
   `save current z tile number
   ztiles = 1
   `calc how much to step each u data per tile
   stepu# = (1.0/tilex)
   `calc how much to step each v data per tile
   stepv# = (1.0/tilez)
   `set base u data for new set of tiles
   baseu# = 0
   `set base v data for new set of tiles
   basev# = 1-stepv#
   `poly number placeholder variable
   i = 1
   `from front to back
   for k = 1 to matzsegs
      `reset the number of x tiles to 1 and the u base to 0
      `at the beginning of each row
      xtiles = 1
      baseu# = 0
      `from left to right
      for l = 1 to matxsegs
         `2 polys per tile
         for m = 1 to 2
            `write all 3 verts of each matrix poly
            for j = 0 to 2
               `select which formula to apply depending on polygon side
               `and vert number (0 to 2)
               `j selects the vert number
               `m selects the polygon side (back/left or front right : 1 or 2)
               select j
                  case 0
                     if m = 1
                        testu# = baseu#
                        testv# = basev#+stepv#
                     else
                        testu# = baseu#
                        testv# = basev#+stepv#
                     endif
                  endcase
                  case 1
                     if m = 1
                        testu# = baseu#
                        testv# = basev#
                     else
                        testu# = baseu#+stepu#
                        testv# = basev#
                     endif
                  endcase
                  case 2
                     if m = 1
                        testu# = baseu#+stepu#
                        testv# = basev#
                     else
                        testu# = baseu#+stepu#
                        testv# = basev#+stepv#
                     endif
                  endcase
               endselect
               `store calculated data for each vert of each poly
               `u data
               vert_store#(i,j,6) = testu#
               `v data
               vert_store#(i,j,7) = testv#
            next j
            inc i, 1
         `next polygon side of this tile
         next m
         `update u data and xtiles place holder
         inc baseu#, stepu#
         inc xtiles, 1
         `reset data when texture tile width has been reached
         if xtiles > tilex
            baseu# = 0
            xtiles = 1
         endif
      `next x tile
      next l
      `update v data and ztiles place holder
      dec basev#, stepv#
      inc ztiles, 1
      `reset data when texture depth has been reached
      if ztiles > tilez
         basev# = 1-stepv#
         ztiles = 1
      endif
   `next z tile
   next k
`******************************************************************************


`******************************************************************************
   `make object from matrix verts

   `calc number of memblocks needed
   tempx = matxsegs/limbx
   tempz = matzsegs/limbz
   tempmem = tempx * tempz
   `make arrays to store memblock positions and memblock numbers
   dim membhold(tempx, tempz)
   dim mempos(tempmem)
   `enter memblock numbers for each texture tile based on the x and z limbs to use
   a = 1
   for i = 1 to tempz
      for j = 1 to tempx
         membhold(j, i) = a
         inc a, 1
      next j
   next i
   `calc the memblock size
   `formula is 12 byte header + ((( 32 bytes per vert * limb x segs)*(limb z segs * 2 polys))* 3 verts per poly)
   mat_mem_size = 12+(((32*limbx)*(limbz*2))*3)
   `make memblocks and write headers for each memblock and set the beginning
   `position for vert data to 12
   for i = 1 to tempmem
      make memblock i, mat_mem_size
      `write objects fvf format as 274
      write memblock dword i, 0, 274
      `write bytes per vert as 32 (8 floats xpos#,ypos#,zpos#,xnorm#,ynorm#,znorm#,u#,v#)
      write memblock dword i, 4, 32
      `write number of verts in matrix (polys*3)
      write memblock dword i, 8, ((limbx*limbz)*2)*3
      `set beginning position for vert data after header(0-8)+4 = 12
      mempos(i) = 12
   next i

   `image tile, row, and memblock placeholders
   xtile = 1
   ztile = 1
   xrow = 1
   xmem = 1
   zmem = 1
   `polygon placeholders (b=2 is 1 tile complete)
   b = 1
   `enter all polys' verts to memblock
   for i = 1 to num_mat_polys
      `select memblock number to write to use current x and z limb tile to pick
      tempmemnum = membhold(xmem, zmem)
      `write all 3 verts of each matrix poly
      for j = 0 to 2
         `xpos
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,0)
         `increment the current memblock position
         inc mempos(tempmemnum), 4
         `ypos
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,1)
         inc mempos(tempmemnum), 4
         `zpos
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,2)
         inc mempos(tempmemnum), 4
         `xnorm
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,3)
         inc mempos(tempmemnum), 4
         `ynorm
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,4)
         inc mempos(tempmemnum), 4
         `znorm
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,5)
         inc mempos(tempmemnum), 4
         `u data
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,6)
         inc mempos(tempmemnum), 4
         `v data
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,7)
         inc mempos(tempmemnum), 4
      next j
      `after each poly increase b by 1
      inc b, 1
      `after 2 polys have been completed 1 tile has been entered
      if b > 2
         `reset poly count to 1
         b = 1
         `move to next x tile
         inc xtile, 1
         `if at the next limb
         if xtile > limbx
            `reseet the x tile to 1
            xtile = 1
            `update the tile count to know when to move to the next row
            inc xrow, limbx
            `inc the xmem selector placeholder
            inc xmem, 1
            `if at the last xmem wide then start back at the begining
            if xmem > tempx
               xmem = 1
            endif
         endif
         `when at the end of the row
         if xrow > matxsegs
            `go back to the far left
            xrow = 1
            `update the number of rows done
            inc ztile, 1
            `when the number of rows done is > the preset depth
            if ztile > limbz
               `reset row count back to 1
               ztile = 1
               `move to the next zmem selector placeholder
               inc zmem, 1
               `if row count overlaps predetermined number
               if zmem > tempz
                  `wrap to 1
                  zmem = 1
               endif
            endif
         endif
      endif
   next i
   `undim arrays when done with them
   undim vert_store#(0,0,0)
   undim membhold(0, 0)
   undim mempos(0)
   `set the mesh number to use (can be replaced with a findfreemesh function)
   mesh = 1
   `make object and limbs from data setup
   for i = 1 to tempmem
      `make temp mesh from info
      make mesh from memblock mesh, i
      `delete temp memblock
      delete memblock i
      `if it is the first memblock mesh, use it as the base object
      if i = 1
         `make temp object for NGC
         make object object, mesh, 0
      `else turn each memblock mesh into limbs
      else
         add limb object, i-1, mesh
      endif
      `delete temp mesh
      delete mesh mesh
   next i
`******************************************************************************
endfunction

function make_house(house)

`give each house a numbered variable ( eg. house(1),house(2), etc,)
` and store the actual object number in that variable
house(house)=check_free_object_number()
make object box house(house),2,2,1
set object specular power house(house),2
set object specular house(house),rgb(220,200,200)
set object emissive house(house),rgb(220,200,200)
set object collision on house(house)
set object cull house(house),0
texture object house(house),housetexture
scale object texture house(house),20,40
roof(house)=check_free_object_number()
make object box roof(house),1.98,1,1
color object roof(house),rgb(220,220,230)
set object specular power roof(house),20
set object specular roof(house),rgb(150,150,150)
set object emissive roof(house),rgb(150,150,150)
position object roof(house),0,1,0
xrotate object roof(house),45
glue object to limb roof(house),house(house),0
door(house)=check_free_object_number()
make object box door(house),0.2,0.4,0.02
texture object door(house),doortexture
position object door(house),0,0,0
glue object to limb door(house),house(house),0

repeat
x=rnd(matrixsize)
z=rnd(matrixsize)
goodlocation=1
position object house(house),x,get ground height(1,x,z),z
if house>1
  for checkprevioushouses=1 to house-1
    if x<object position x(house(checkprevioushouses))+4 and x>object position x(house(checkprevioushouses))-4 and z<object position z(house(checkprevioushouses))+4 and z>object position z(house(checkprevioushouses))-4 then goodlocation=0
  next checkprevioushouses
endif
until goodlocation=1

`glue object to limb door(house),house(house),0
yrotate object house(house),rnd(360)
position object door(house),object position x(door(house)),get ground height(1,object position x(house(house))-0.5*sin(object angle y(house(house))),object position z(house(house))-0.5*cos(object angle y(house(house))))+0.2-object position y(house(house)),object position z(door(house))
position object door(house),object position x(door(house)),object position y(door(house)),object position z(door(house))-0.492

endfunction

function make_house_texture

cls
ink rgb(200,200,180),0
box 0,0,5,15
ink rgb(250,230,210),0
box 0,0,4,15
housetexture=free_image()
get image housetexture,0,0,5,15

endfunction

function make_door_texture

cls
colour=rgb(rnd(250),rnd(250),rnd(250))
ink colour,0
box 0,0,8,8
ink 0,0
box 1,1,3,3
box 5,1,7,3
ink colour-100,0
box 1,4,7,7
doortexture=free_image()
get image doortexture,0,0,8,8,1

endfunction

`CODE BASED ON:
`   http://2dnow.zenzer.net/viewarticle.php?a=10
set display mode 1280, 1024, 32
sync on
sync rate 0

`Define the required constants for the fire
#constant MAX_CHANGES          6
#constant SECTOR_WIDTH         128
#constant SECTOR_HEIGHT        128
#constant COOLING_RATE         1
#constant NUM_COALS_PER_UPDATE 1
#constant UPDATE_RATE          20
global SPARK_HEAT = 16

#constant MEMBLOCK_ID   1
#constant IMAGE_ID      1


`Define image
dim FireData(SECTOR_WIDTH, SECTOR_HEIGHT)
for x = 0 to SECTOR_WIDTH-1
   for y = 0 to SECTOR_HEIGHT-1
      FireData(x, y) = 0
   next y
next x



`Create a memblock for it
make memblock MEMBLOCK_ID, 12 + (SECTOR_WIDTH * SECTOR_HEIGHT * 4)
write memblock dword 1, 0, SECTOR_WIDTH
write memblock dword 1, 4, SECTOR_HEIGHT
write memblock dword 1, 8, 32




`Define Flame Colors
Type FireColour
   Red
   Green
   Blue
   Alpha
   Temperature as Byte
EndType
Dim ColourChanges(MAX_CHANGES) as FireColour

ColourChanges(0).Red = 255
ColourChanges(0).Green = 255
ColourChanges(0).Blue = 255
ColourChanges(0).Alpha = 255
ColourChanges(0).Temperature = 255


ColourChanges(1).Red = 255
ColourChanges(1).Green = 255
ColourChanges(1).Blue = 0
ColourChanges(1).Alpha = 160
ColourChanges(1).Temperature = 64


ColourChanges(2).Red = 255
ColourChanges(2).Green = 128
ColourChanges(2).Blue = 0
ColourChanges(2).Alpha = 160
ColourChanges(2).Temperature = 48


ColourChanges(3).Red = 128
ColourChanges(3).Green = 64
ColourChanges(3).Blue = 64
ColourChanges(3).Alpha = 128
ColourChanges(3).Temperature = 32


ColourChanges(4).Red = 64
ColourChanges(4).Green = 32
ColourChanges(4).Blue = 0
ColourChanges(4).Alpha = 64
ColourChanges(4).Temperature = 16


ColourChanges(5).Red = 0
ColourChanges(5).Green = 0
ColourChanges(5).Blue = 0
ColourChanges(5).Alpha = 0
ColourChanges(5).Temperature = 0

`Create the fire color interpolation
currentC as FireColour
nextC as FireColour
CurrentEntry = 255
r as byte
g as byte
b as byte

Dim FireColours(255) as DWORD
for i = 0 to 4
   currentC = ColourChanges(i)
   nextC = ColourChanges(i+1)
   for j = currentC.Temperature to nextC.Temperature + 1 step -1
      interpFactor# = (currentC.Temperature - CurrentEntry) / (1.0 * (currentC.Temperature - nextC.Temperature))
      r = currentC.Red   + (nextC.Red   - currentC.Red)   * interpFactor#
      g = currentC.Green + (nextC.Green - currentC.Green) * interpFactor#
      b = currentC.Blue  + (nextC.Blue  - currentC.Blue)  * interpFactor#
      a = currentC.Alpha + (nextC.Alpha - currentC.Alpha) * interpFactor#
      FireColours(CurrentEntry) = rgba(r, g, b, a)
      dec CurrentEntry
   next j
next i




make object plain 1, 2, 1
position object 1, 0, 0, 0
point object 1, 0, 0, 1
set object transparency 1, 3
set object light 1, 0
UpdateFire()
texture object 1, 1


make object cube 2, 5
position object 2, 0, 0, -5

autocam off
position camera 0, 0, 4
point camera 0, 0, 0


`Start the firedrawing!!
frameTime# = 1.0
startTime = timer()
FLAME_UPDATE# = 0
do
   frameTime# = (frameTime# * 0.8) + ((timer() - startTime) * 0.2)
   startTime = timer()

   text 0, 0, "FPS: " + str$(screen fps())
   text 0, 10, "Flame heat: " + str$(SPARK_HEAT)
   y = mousemovey()
   if SPARK_HEAT < 255 AND y < 0   then inc SPARK_HEAT
   if SPARK_HEAT > 0   AND y > 0 then dec SPARK_HEAT

   if FLAME_UPDATE# >= UPDATE_RATE
      UpdateFire()
      FLAME_UPDATE# = 0
   else
      inc FLAME_UPDATE#, frameTime#
   endif
   sync
loop









function UpdateFire()
   Dim FireDataCopy(SECTOR_WIDTH, SECTOR_HEIGHT)
`   clr as byte

   for x = 0 to SECTOR_WIDTH - 2
      for y = 0 to SECTOR_HEIGHT - 2
         clr = FireData(x, y)
         write memblock dword 1, 12 + ((y * SECTOR_WIDTH) + x) * 4, FireColours(clr)
         FireDataCopy(x, y) = clr
      next y
   next x
   make image from memblock 1, 1


   `Scroll the flame
   for x = 0 to SECTOR_WIDTH - 1
      for y = 0 to SECTOR_HEIGHT - 2
         FireDataCopy(x, y) = FireDataCopy(x, y + 1)
      next y
   next x


   `Create sparks
   for y = SECTOR_HEIGHT - 4 to SECTOR_HEIGHT -2
      for x = 1 to SECTOR_WIDTH - 2
         FireDataCopy(x, y) = rand() * SPARK_HEAT
      next x
   next y


   `Create coals
   y = SECTOR_HEIGHT -2
   For i = 0 to NUM_COALS_PER_UPDATE -1
      x = rand() * (SECTOR_WIDTH - 2)

      FireDataCopy(x - 1, y - 1) = 255
      FireDataCopy(x - 1, y    ) = 255
      FireDataCopy(x - 1, y + 1) = 255
      FireDataCopy(x    , y - 1) = 255
      FireDataCopy(x    , y    ) = 255
      FireDataCopy(x    , y + 1) = 255
      FireDataCopy(x + 1, y - 1) = 255
      FireDataCopy(x + 1, y    ) = 255
      FireDataCopy(x + 1, y + 1) = 255
   next i



   `Blur the image
   for x = 1 to SECTOR_WIDTH - 1
      for y = 1 to SECTOR_HEIGHT -1
         clr = (_
                  FireDataCopy(x - 1, y    ) +_
                  FireDataCopy(x + 1, y    ) +_
                  FireDataCopy(x    , y - 1) +_
                  FireDataCopy(x    , y + 1) +_
                  FireDataCopy(x - 1, y - 1) +_
                  FireDataCopy(x - 1, y + 1) +_
                  FireDataCopy(x + 1, y - 1) +_
                  FireDataCopy(x + 1, y + 1)  _
                ) / 8.0

         if clr >= COOLING_RATE then dec clr, COOLING_RATE

         FireData(x, y) = clr
      next y
   next x
endfunction


function rand()
   rndVal# = rnd(1000000) / 1000000.0
endfunction rndVal#

function rgba(r as integer,g as integer,b as integer,a as integer)
  colour as dword
  colour = (b)+(g*256)+(r*65536)+(a*16777216)
endfunction colour

Rem Project: snowscene
Rem Created: 01/12/2005 20:00:06

Rem ***** Main Source File *****

`Snowy Island by Ric

detail=80

`display settings
if check display mode(1024,768,32)=1 then set display mode 1024,768,32
sync on
sync rate 35
hide mouse

autocam off
hide light 0
color backdrop 0
set ambient light 0
make light 1
set light range 1,3


create bitmap 1,screen width(),screen height()

`snowflake image
make object sphere 1,1,4,4
position object 1,0,0,1.5
sync
snowflake=free_image()
get image snowflake,screen width()*.25,screen height()*.25,screen width()*.75,screen width()*.75,1
delete object 1

position light 1,0,0,-1
set light range 1,2

make object sphere 1,1,100,100
set object specular power 1,20
set object specular 1,rgb(255,255,255)
position camera 0,0,-2
sync
sun=free_image()
get image sun,screen width()/4,screen height()/4,screen width()*.75,screen height()*.75,1
set object light 1,0
sync
flare1=free_image()
get image flare1,screen width()/4,screen height()/4,screen width()*.75,screen height()*.75,1
delete object 1

delete bitmap 1
text 0,0,"Please wait (approx 60 seconds) ......"
sync

`camera and light settings

set camera range 0.01,10000
position camera 64,0,64
color backdrop 0
set ambient light 20


`set the randomize seed to the timer, so random events are different each time
randomize timer()

`set size of terrain
global matrixsize
matrixsize=128

`fog settings
fog on
fog color rgb(200,200,200)
fog distance matrixsize

`set initial value for object numbers
global object_seed
object_seed=1000000

`set initial value for image numbers
global image_seed
image_seed=1000000

`position light for world illumination
position light 1,200,80,200
set light range 1,100000
make object cube 1,1
hide object 1
position object 1,light position x(1),light position y(1),light position z(1)

global skyimage
create_sky()
global snowimage
create_snowimage()
global snow

global height#
global rows
global columns
global terrainimage
`set size of terrain
rows=detail
columns=detail
global peaksoff
global peaksoff2
global dim peakx(100)
global dim peakz(100)
global dim peakh(100)
global dim peakx2(100)
global dim peakz2(100)
global dim peakh2(100)
terraform()
Matrix_to_Object(1000,1,128,128,rows,rows,rows,rows,rows,rows)

`make some buildings
global doortexture
make_door_texture()
global housetexture
make_house_texture()
`set house variables
global number_of_houses
number_of_houses=15
`set up an array to store house numbers
global dim house(number_of_houses)
global dim door(number_of_houses)
global dim roof(number_of_houses)

for house_number=1 to number_of_houses
  make_house(house_number)
next house_number

`make trees
global theta#
global numberoftrees
numberoftrees=40
global treenumberseed
treenumberseed=free_object()
global dim treeimage(numberoftrees+treenumberseed)
global resolution
resolution=6
global bark
create_bark()
`text 0,0,"Please wait ......"
`sync
for number=1+treenumberseed to numberoftrees+treenumberseed
create_tree(number)
ink rgb(255,255,255),0
`text 0,0,"Generating trees: "+str$(number-treenumberseed)+" out of "+str$(numberoftrees)
`sync
next number
gosub calculate_shadows
delete object 1000
delete bitmap 2
set current bitmap 0
`hide buildings for skysphere image grab
for n=house(1) to house(number_of_houses)+2
hide object n
next n

global sphere1
global sphere2
global sphere3
create_skysphere()
create_snow()


for n=house(1) to house(number_of_houses)+2
show object n
next n

sunplane=free_object()
make object plain sunplane,160*4/3.0,160
set object fog sunplane,0
texture object sunplane,sun
set object light sunplane,0
ghost object on sunplane,2
set object transparency sunplane,2
flareplane1=free_object()
make object plain flareplane1,0.3*4/3.0,0.3
texture object flareplane1,flare1
set object light flareplane1,0
set alpha mapping on flareplane1,20
position object flareplane1,0,-0.5,0
`reference object for distant light source
dummy=free_object()
make object cube dummy,1
hide object dummy
point object dummy,light position x(1),light position y(1),light position z(1)
move object dummy,10000

`make snowflakes
radius=100
height=30
velocity#=0.12
numberofflakes=500
n=1000
make object box n,2*4/3.0,2,0.01
set object light n,0
texture object n,snowflake
set object transparency n,1
set object fog n,0
ghost object on n,2
set alpha mapping on n,40

for n=1001 to 1000+numberofflakes
instance object n,1000
set object transparency n,1
set object fog n,0
ghost object on n,2
set alpha mapping on n,40
position object n,camera position x()+rnd(radius*2)-radius,camera position y()+rnd(height),camera position z()+rnd(radius*2)-radius
rotate object n,rnd(360),rnd(360),rnd(360)
next n

position camera 64,height#+2+get ground height(1,64,64),64




`main program loop
do

move_camera()
move_trees()

position object sunplane,camera position x(),camera position y(),camera position z()
point object sunplane,object position x(dummy),object position y(dummy),object position z(dummy)
move object sunplane,128*7
point object sunplane,camera position x(),camera position y(),camera position z()

for n=1000 to 1000+numberofflakes
position object n,object position x(n),object position y(n)-velocity#,object position z(n)
yrotate object n,object angle y(n)+1
if object position y(n)<get ground height(1,object position x(n),object position z(n))
position object n,camera position x()+rnd(radius*2)-radius,camera position y()+height,camera position z()+rnd(radius*2)-radius
endif
next n
text 0,0,str$(screen fps())

sync
loop

`****************************************

`functions

function terraform

`create terrain
make matrix 1,matrixsize,matrixsize,columns,rows
set matrix 1,0,0,0,2,0,1,0

for peak=1 to 50
peakh(peak)=rnd(15)+5
peakx(peak)=rnd(rows-8)+4
peakz(peak)=rnd(rows-8)+4
set matrix height 1,peakx(peak),peakz(peak),peakh(peak)
next peak
update matrix 1


for times=1 to 120
if times>=90 then peaksoff=1
smooth_matrix(1,rows,rows)
next times
peaksoff=0


endfunction

function smooth_matrix(matnum,tilex,tilez)

for x=2 to tilex-2
for z=2 to tilez-2
b=-get matrix height(matnum,x,z)+get matrix height(matnum,x,z+1)
d=-get matrix height(matnum,x,z)+get matrix height(matnum,x+1,z)
f=-get matrix height(matnum,x,z)+get matrix height(matnum,x,z-1)
h=-get matrix height(matnum,x,z)+get matrix height(matnum,x-1,z)
total=b+d+f+h

set matrix height matnum,x,z,get matrix height(matnum,x,z)+total*0.1

next z
next x



for peak=1 to 100
`peakh(peak)=peakh(peak)*0.999
if matnum=1
  if peaksoff=0 then set matrix height 1,peakx(peak),peakz(peak),peakh(peak)
endif
if matnum=2
  if peaksoff=0 then set matrix height 2,peakx2(peak),peakz2(peak),peakh2(peak)
endif
next peak

update matrix matnum
endfunction

function free_object

object=object_seed
repeat
inc object
until object exist(object)=0

endfunction object

function check_free_object_number

object=object_seed
repeat
inc object
until object exist(object)=0

endfunction object

function free_image

image=image_seed
repeat
inc image
until image exist(image)=0

endfunction image



function create_skysphere

`get image for sphere by taking snapshot of terrain
terrainimage=free_image()
set camera fov 90
fog off
position camera matrixsize/2.0,3,-matrixsize*0.3
sync
get image terrainimage,0,0,screen width(),screen height()
fog on
fog color rgb(200,200,200)
fog distance matrixsize
set camera fov 60


sphere2=free_object()
make object sphere sphere2,matrixsize*10
set object collision off sphere2
xrotate object sphere2,180
`yrotate object sphere2,30
set object cull sphere2,0
texture object sphere2,terrainimage
set object texture sphere2,2,0
scale object texture sphere2,8,2.6
set object fog sphere2,0
set object transparency sphere2,2
ghost object on sphere2,5
set alpha mapping on sphere2,20
set object emissive sphere2,rgb(80,60,100)
`set object specular power sphere2,100
`fade object sphere2,200
`set object light sphere2,0
position object sphere2,matrixsize/2,-135,matrixsize/2

`sphere 3 (sky) - a third, outer sphere for the sky
sphere3=free_object()
make object sphere sphere3,matrixsize*20
set object collision off sphere3
set object cull sphere3,0
texture object sphere3,skyimage
scale object texture sphere3,1,1.8
set object light sphere3,0
set object fog sphere3,0
position object sphere3,matrixsize/2,0,matrixsize/2

endfunction

function create_sky()
`creates a dark to light bluish gradient
cls
for n=0 to 250
  ink rgb(n,n-20,n-40),0
  line 0,n,250,n
next n

skyimage=free_image()
get image skyimage,0,0,250,250

endfunction

function create_snowimage

create bitmap 1,128,128
set current bitmap 1
ink rgb(255,255,255),0
box 0,0,128,128
for n=0 to 5000
tone=rnd(40)+200
ink rgb(tone+15,tone+10,tone),0
dot rnd(128),rnd(128)
next n
snowimage=free_image()
get image snowimage,0,0,128,128
delete bitmap 1

endfunction

function create_snow

`snow=free_object()
`make object plain snow,matrixsize*12,matrixsize*12
`xrotate object snow,-90
`set object fog snow,0
`set object light snow,0
`texture object snow,snowimage
`position object snow,0,1,0

make matrix 2,matrixsize*12,matrixsize*12,40,40
set matrix 2,0,0,1,2,0,1,1
prepare matrix texture 2,snowimage,40,40
tile=1
for x=40-1 to 0 step -1
for z=0 to 40-1
set matrix tile 2,z,x,tile
inc tile
next z
next x
position matrix 2,-matrixsize*6,-10,-matrixsize*6

for peak=1 to 60
peakx2(peak)=rnd(40-4)+2
peakz2(peak)=rnd(40-4)+2
if peakx2(peak)<15 or peakx2(peak)>25
if peakz2(peak)<15 or peakz2(peak)>25
peakh2(peak)=rnd(20)+10
endif
endif
set matrix height 2,peakx2(peak),peakz2(peak),peakh2(peak)
next peak
update matrix 2


for times=1 to 100
if times>=96 then peaksoff=1
smooth_matrix(2,40,40)
next times
peaksoff=0

update matrix 2

endfunction



function move_camera

control camera using arrowkeys 0,0.2,3
position camera camera position x(),height#+.2+get ground height(1,camera position x(),camera position z()),camera position z()
if inkey$()="a" then inc height#,1
if inkey$()="z" then dec height#,1
endfunction

calculate_shadows:
undim pixelshaded1(128,128)
undim pixelshaded2(128,128)
dim pixelshaded1(128,128)
dim pixelshaded2(128,128)
`if light1>0
create bitmap 1,128,128
set current bitmap 1
ink rgb(255,255,255),0
box 0,0,128,128
for n=0 to 5000
tone=rnd(40)+200
ink rgb(tone+15,tone+15,tone),0
dot rnd(128),rnd(128)
next n
ink rgb(10,10,10),0
for y=0 to 128
for x=0 to 128

`shadows cast by objects
for object=house(1) to house(number_of_houses)
if object exist(object)
ray1#=intersect object(object,x,get ground height(1,x,y),y,light position x(1),light position y(1),light position z(1))
if ray1#=0 then ray1#=1000
if ray1#<0 then ray1#=1
if ray1#<=100
  tone=100+ray1#*10
  `if pixelshaded2(x,y)=1 or pixelshaded1(x,y)=1 then tone=tone/1.5
  if tone>255 then tone=255
  ink rgb(tone,tone,tone),0
  dot x,128-y
  `pixelshaded1(x,y)=1
endif
endif
next object

`shadows cast by trees
for object=1+treenumberseed+1000 to numberoftrees+treenumberseed+1000
if object exist(object)
ray1#=intersect object(object,x,get ground height(1,x,y),y,light position x(1),light position y(1),light position z(1))
if ray1#=0 then ray1#=1000
if ray1#<0 then ray1#=1
if ray1#<=100
  tone=100+ray1#*10
  `if pixelshaded2(x,y)=1 or pixelshaded1(x,y)=1 then tone=tone/1.5
  if tone>255 then tone=255
  ink rgb(tone,tone,tone),0
  dot x,128-y
  `pixelshaded1(x,y)=1
endif
endif
next object

`shadows cast by terrain - matrix converted to object 1000
ray2#=intersect object(1000,x,get ground height(1,x,y)+0.1,y,light position x(1),light position y(1),light position z(1))
if ray2#=0 then ray2#=1000
if ray2#<0 then ray2#=1
if ray2#<=100
  tone=100+ray2#*10

  `if pixelshaded2(x,y)=1 or pixelshaded1(x,y)=1 then tone=tone/1.5
  if tone>255 then tone=255
  ink rgb(tone,tone,tone),0
  dot x,128-y
  `pixelshaded1(x,y)=1
endif


next x
next y
blur bitmap 1,3
shadowmap=5000000
get image shadowmap,0,0,128,128

delete bitmap 1
`set light mapping on 2,shadowmap
 `(light1 exist)

`texture matrix
prepare matrix texture 1,shadowmap,rows,columns
tile=1
for x=rows-1 to 0 step -1
for z=0 to columns-1
set matrix tile 1,z,x,tile
inc tile
next z
next x
`endif
update matrix 1

return

function Matrix_to_Object( object, matrixnum, matxsize#, matzsize#, matxsegs, matzsegs, tilex, tilez, limbx, limbz )
   `safety in case limbx and limbz is smaller than the texture x and z
   a = 0
   if limbx < tilex then limbx = tilex : a = 1
   if limbz < tilez then limbz = tilez : a = 1
   if a > 0
      sync
      print "limbx or limbz was less than tilex or tilez : Error corrected"
      print "Press any key to continue."
      sync
      wait key
   endif
   `safety in case matxsegs and matzsegs is not evenly divisible by tilex and tilez
   if matxsegs mod tilex > 0
      EXIT PROMPT "Number of matrix xsegs not evenly divisible by tilex", "Texture tilex error"
      end
   endif
   if matzsegs mod tilez > 0
      EXIT PROMPT "Number of matrix zsegs not evenly divisible by tilez", "Texture tilez error"
      end
   endif
   `safety in case matxsegs and matzsegs is not evenly divisible by tilex and tilez
   if matxsegs mod limbx > 0
      EXIT PROMPT "Number of matrix xsegs not evenly divisible by limbx", "Texture tilex error"
      end
   endif
   if matzsegs mod limbz > 0
      EXIT PROMPT "Number of matrix zsegs not evenly divisible by limbz", "Texture tilez error"
      end
   endif

   `calc the number of polys in the matrix
   num_mat_polys = (matxsegs*matzsegs)*2
   `make array to store vert info
   `storage indexs = poly number, vert number, x/y/z vert pos/norm/uv
   `polys are numbered starting from left to right, front to
   `back, one row at a time (with 2 polys per tile)
   dim vert_store#(num_mat_polys,2,7)

   `calc the width and depth of each tile on the matrix
   `formula size#/number
   mat_x_wide# = matxsize#/matxsegs
   mat_z_deep# = matzsize#/matzsegs


`******************************************************************************
   `get vert position data
   `placeholder variable for poly numbers
   a = 1
   `one row at a time (front to back)
   for j = 0 to matzsegs - 1
      `one tile at a time (left to right)
      for i = 0 to matxsegs - 1

         `tile top left poly info

         `bottom left vert (x,y,z)
         vert_store#(a,0,0) = i*mat_x_wide#
         vert_store#(a,0,1) = GET MATRIX HEIGHT(matrixnum, i, j)
         vert_store#(a,0,2) = j*mat_z_deep#
         `top left vert (x,y,z)
         vert_store#(a,1,0) = i*mat_x_wide#
         vert_store#(a,1,1) = GET MATRIX HEIGHT(matrixnum, i, j+1)
         vert_store#(a,1,2) = (j+1)*mat_z_deep#
         `top right vert (x,y,z)
         vert_store#(a,2,0) = (i+1)*mat_x_wide#
         vert_store#(a,2,1) = GET MATRIX HEIGHT(matrixnum, i+1, j+1)
         vert_store#(a,2,2) = (j+1)*mat_z_deep#
         inc a, 1

         `tile bottom right poly info

         `bottom left vert (x,y,z)
         vert_store#(a,0,0) = i*mat_x_wide#
         vert_store#(a,0,1) = GET MATRIX HEIGHT(matrixnum, i, j)
         vert_store#(a,0,2) = j*mat_z_deep#
         `top right vert (x,y,z)
         vert_store#(a,1,0) = (i+1)*mat_x_wide#
         vert_store#(a,1,1) = GET MATRIX HEIGHT(matrixnum, i+1, j+1)
         vert_store#(a,1,2) = (j+1)*mat_z_deep#
         `bottom right vert (x,y,z)
         vert_store#(a,2,0) = (i+1)*mat_x_wide#
         vert_store#(a,2,1) = GET MATRIX HEIGHT(matrixnum, i+1, j)
         vert_store#(a,2,2) = j*mat_z_deep#
         inc a, 1
      next i
   next j
`******************************************************************************


`******************************************************************************
   `calc normals for polys
   `Thanks to ADR for posting this code on the DBP forums :)
   for i = 1 to num_mat_polys
      `acuire vert positions
      P1X# = vert_store#(i,0,0)
      P1Y# = vert_store#(i,0,1)
      P1Z# = vert_store#(i,0,2)
      P2X# = vert_store#(i,1,0)
      P2Y# = vert_store#(i,1,1)
      P2Z# = vert_store#(i,1,2)
      P3X# = vert_store#(i,2,0)
      P3Y# = vert_store#(i,2,1)
      P3Z# = vert_store#(i,2,2)

      null = make vector3(1)
      null = make vector3(2)
      null = make vector3(3)

      ` -- calculate the two directional vectors for the adj and opp edges...
      set vector3 1, P1X#, P1Y#, P1Z#
      set vector3 2, P2X#, P2Y#, P2Z#
      set vector3 3, P3X#, P3Y#, P3Z#
      subtract vector3 2, 2, 1
      subtract vector3 3, 3, 1   ` -- vector 3 and 1 are now directional vectors
      normalize vector3 2,2      ` -- normalize em
      normalize vector3 3,3
      cross product vector3 1, 2,3  ` -- use the origin vector (1) to store the face normal
      normalize vector3 1,1

      `save normals (all 3 verts have same normals)
      vert_store#(i,0,3) = x vector3(1)
      vert_store#(i,0,4) = y vector3(1)
      vert_store#(i,0,5) = z vector3(1)
      vert_store#(i,1,3) = vert_store#(i,0,3)
      vert_store#(i,1,4) = vert_store#(i,0,4)
      vert_store#(i,1,5) = vert_store#(i,0,5)
      vert_store#(i,2,3) = vert_store#(i,0,3)
      vert_store#(i,2,4) = vert_store#(i,0,4)
      vert_store#(i,2,5) = vert_store#(i,0,5)

      null = delete vector3(1)
      null = delete vector3(2)
      null = delete vector3(3)
   next i
`******************************************************************************


`******************************************************************************
   `calc UV data for polys

   `save current x tile number
   xtiles = 1
   `save current z tile number
   ztiles = 1
   `calc how much to step each u data per tile
   stepu# = (1.0/tilex)
   `calc how much to step each v data per tile
   stepv# = (1.0/tilez)
   `set base u data for new set of tiles
   baseu# = 0
   `set base v data for new set of tiles
   basev# = 1-stepv#
   `poly number placeholder variable
   i = 1
   `from front to back
   for k = 1 to matzsegs
      `reset the number of x tiles to 1 and the u base to 0
      `at the beginning of each row
      xtiles = 1
      baseu# = 0
      `from left to right
      for l = 1 to matxsegs
         `2 polys per tile
         for m = 1 to 2
            `write all 3 verts of each matrix poly
            for j = 0 to 2
               `select which formula to apply depending on polygon side
               `and vert number (0 to 2)
               `j selects the vert number
               `m selects the polygon side (back/left or front right : 1 or 2)
               select j
                  case 0
                     if m = 1
                        testu# = baseu#
                        testv# = basev#+stepv#
                     else
                        testu# = baseu#
                        testv# = basev#+stepv#
                     endif
                  endcase
                  case 1
                     if m = 1
                        testu# = baseu#
                        testv# = basev#
                     else
                        testu# = baseu#+stepu#
                        testv# = basev#
                     endif
                  endcase
                  case 2
                     if m = 1
                        testu# = baseu#+stepu#
                        testv# = basev#
                     else
                        testu# = baseu#+stepu#
                        testv# = basev#+stepv#
                     endif
                  endcase
               endselect
               `store calculated data for each vert of each poly
               `u data
               vert_store#(i,j,6) = testu#
               `v data
               vert_store#(i,j,7) = testv#
            next j
            inc i, 1
         `next polygon side of this tile
         next m
         `update u data and xtiles place holder
         inc baseu#, stepu#
         inc xtiles, 1
         `reset data when texture tile width has been reached
         if xtiles > tilex
            baseu# = 0
            xtiles = 1
         endif
      `next x tile
      next l
      `update v data and ztiles place holder
      dec basev#, stepv#
      inc ztiles, 1
      `reset data when texture depth has been reached
      if ztiles > tilez
         basev# = 1-stepv#
         ztiles = 1
      endif
   `next z tile
   next k
`******************************************************************************


`******************************************************************************
   `make object from matrix verts

   `calc number of memblocks needed
   tempx = matxsegs/limbx
   tempz = matzsegs/limbz
   tempmem = tempx * tempz
   `make arrays to store memblock positions and memblock numbers
   dim membhold(tempx, tempz)
   dim mempos(tempmem)
   `enter memblock numbers for each texture tile based on the x and z limbs to use
   a = 1
   for i = 1 to tempz
      for j = 1 to tempx
         membhold(j, i) = a
         inc a, 1
      next j
   next i
   `calc the memblock size
   `formula is 12 byte header + ((( 32 bytes per vert * limb x segs)*(limb z segs * 2 polys))* 3 verts per poly)
   mat_mem_size = 12+(((32*limbx)*(limbz*2))*3)
   `make memblocks and write headers for each memblock and set the beginning
   `position for vert data to 12
   for i = 1 to tempmem
      make memblock i, mat_mem_size
      `write objects fvf format as 274
      write memblock dword i, 0, 274
      `write bytes per vert as 32 (8 floats xpos#,ypos#,zpos#,xnorm#,ynorm#,znorm#,u#,v#)
      write memblock dword i, 4, 32
      `write number of verts in matrix (polys*3)
      write memblock dword i, 8, ((limbx*limbz)*2)*3
      `set beginning position for vert data after header(0-8)+4 = 12
      mempos(i) = 12
   next i

   `image tile, row, and memblock placeholders
   xtile = 1
   ztile = 1
   xrow = 1
   xmem = 1
   zmem = 1
   `polygon placeholders (b=2 is 1 tile complete)
   b = 1
   `enter all polys' verts to memblock
   for i = 1 to num_mat_polys
      `select memblock number to write to use current x and z limb tile to pick
      tempmemnum = membhold(xmem, zmem)
      `write all 3 verts of each matrix poly
      for j = 0 to 2
         `xpos
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,0)
         `increment the current memblock position
         inc mempos(tempmemnum), 4
         `ypos
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,1)
         inc mempos(tempmemnum), 4
         `zpos
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,2)
         inc mempos(tempmemnum), 4
         `xnorm
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,3)
         inc mempos(tempmemnum), 4
         `ynorm
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,4)
         inc mempos(tempmemnum), 4
         `znorm
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,5)
         inc mempos(tempmemnum), 4
         `u data
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,6)
         inc mempos(tempmemnum), 4
         `v data
         write memblock float tempmemnum, mempos(tempmemnum), vert_store#(i,j,7)
         inc mempos(tempmemnum), 4
      next j
      `after each poly increase b by 1
      inc b, 1
      `after 2 polys have been completed 1 tile has been entered
      if b > 2
         `reset poly count to 1
         b = 1
         `move to next x tile
         inc xtile, 1
         `if at the next limb
         if xtile > limbx
            `reseet the x tile to 1
            xtile = 1
            `update the tile count to know when to move to the next row
            inc xrow, limbx
            `inc the xmem selector placeholder
            inc xmem, 1
            `if at the last xmem wide then start back at the begining
            if xmem > tempx
               xmem = 1
            endif
         endif
         `when at the end of the row
         if xrow > matxsegs
            `go back to the far left
            xrow = 1
            `update the number of rows done
            inc ztile, 1
            `when the number of rows done is > the preset depth
            if ztile > limbz
               `reset row count back to 1
               ztile = 1
               `move to the next zmem selector placeholder
               inc zmem, 1
               `if row count overlaps predetermined number
               if zmem > tempz
                  `wrap to 1
                  zmem = 1
               endif
            endif
         endif
      endif
   next i
   `undim arrays when done with them
   undim vert_store#(0,0,0)
   undim membhold(0, 0)
   undim mempos(0)
   `set the mesh number to use (can be replaced with a findfreemesh function)
   mesh = 1
   `make object and limbs from data setup
   for i = 1 to tempmem
      `make temp mesh from info
      make mesh from memblock mesh, i
      `delete temp memblock
      delete memblock i
      `if it is the first memblock mesh, use it as the base object
      if i = 1
         `make temp object for NGC
         make object object, mesh, 0
      `else turn each memblock mesh into limbs
      else
         add limb object, i-1, mesh
      endif
      `delete temp mesh
      delete mesh mesh
   next i
`******************************************************************************
endfunction

function make_house(house)

`give each house a numbered variable ( eg. house(1),house(2), etc,)
` and store the actual object number in that variable
house(house)=check_free_object_number()
make object box house(house),2,2,1
set object specular power house(house),2
set object specular house(house),rgb(220,200,200)
set object emissive house(house),rgb(220,200,200)
set object collision on house(house)
set object cull house(house),0
texture object house(house),housetexture
scale object texture house(house),20,40
roof(house)=check_free_object_number()
make object box roof(house),1.98,1,1
color object roof(house),rgb(220,220,230)
set object specular power roof(house),20
set object specular roof(house),rgb(150,150,150)
set object emissive roof(house),rgb(150,150,150)
position object roof(house),0,1,0
xrotate object roof(house),45
glue object to limb roof(house),house(house),0
door(house)=check_free_object_number()
make object box door(house),0.2,0.4,0.02
texture object door(house),doortexture
position object door(house),0,0,0
glue object to limb door(house),house(house),0

repeat
x=rnd(matrixsize)
z=rnd(matrixsize)
goodlocation=1
position object house(house),x,get ground height(1,x,z),z
if house>1
  for checkprevioushouses=1 to house-1
    if x<object position x(house(checkprevioushouses))+4 and x>object position x(house(checkprevioushouses))-4 and z<object position z(house(checkprevioushouses))+4 and z>object position z(house(checkprevioushouses))-4 then goodlocation=0
  next checkprevioushouses
endif
until goodlocation=1

`glue object to limb door(house),house(house),0
yrotate object house(house),rnd(360)
position object door(house),object position x(door(house)),get ground height(1,object position x(house(house))-0.5*sin(object angle y(house(house))),object position z(house(house))-0.5*cos(object angle y(house(house))))+0.2-object position y(house(house)),object position z(door(house))
position object door(house),object position x(door(house)),object position y(door(house)),object position z(door(house))-0.492

endfunction

function make_house_texture

cls
ink rgb(200,200,180),0
box 0,0,5,15
ink rgb(250,230,210),0
box 0,0,4,15
housetexture=free_image()
get image housetexture,0,0,5,15

endfunction

function make_door_texture

cls
colour=rgb(rnd(250),rnd(250),rnd(250))
ink colour,0
box 0,0,8,8
ink 0,0
box 1,1,3,3
box 5,1,7,3
ink colour-100,0
box 1,4,7,7
doortexture=free_image()
get image doortexture,0,0,8,8,1

endfunction


function check_free_image_number()

`this functionworks in the same way as the check_free_object function,
`except it works for images.

image=image_seed
repeat
inc image
until image exist(image)=0

endfunction image


function create_tree(number)

treeimage(number)=check_free_image_number()
bushiness=rnd(280)+60
droopiness#=(rnd(10)/10.0)+0.3
height#=rnd(5)/10.0
roundness=rnd(150)+50
fuzziness=rnd(2)
redness#=rnd(55)
density=rnd(4)+1


create bitmap 2,400,400
set current bitmap 2
cls
for l=1 to bushiness
if rnd(density)=0 then ink rgb(rnd(50)+200,rnd(20)+230,rnd(50)+200),0 else ink 0,0
for d=1 to bushiness
if rnd(density)=0 then dot d,l
next d
next l
get image treeimage(number),1,1,bushiness,bushiness
`set current bitmap 0
`delete bitmap 2

make object sphere number,0.01
`hide object number
limb=1
polarity=1
for a#=0.01 to 1.0 step 0.01*resolution
objectformesh=check_free_object_number()
make object sphere objectformesh,0.05+a#,5,5
make mesh from object limb,objectformesh
add limb number,limb,limb
delete object objectformesh
delete mesh limb
f#=rnd(fuzziness)/10.0
polarity=polarity*-1
offset limb number,limb,(f#*polarity),-(a#/(droopiness#/0.5)),(f#*polarity)
texture limb number,limb,treeimage(number)
inc limb
next a#

randomx#=rnd(1000)/10.0-40
randomz#=rnd(1000)/10.0-40
position object number,randomx#+50,get ground height(1,randomx#+50,randomz#+50)+1.2+height#,randomz#+50
scale object number,100-roundness#/2.0,roundness*a#,100-roundness#/2.0
set object transparency number,2
set object light number,0
make object cone 1000+number,1
scale object 1000+number,10+rnd(20),200+height#,10
position object 1000+number,randomx#+50,get ground height(1,randomx#+50,randomz#+50)+height#,randomz#+50
texture object 1000+number,bark

for n#=1.0 to 100.0/resolution
rotate limb number,n#,n#/50.0,0,0
next n#

endfunction

function delete_tree


for object=1 to numberoftrees
delete object 1000+object
delete object object
next object

endfunction

function move_trees()

for tree=1+treenumberseed to numberoftrees+treenumberseed
for n#=1.0 to 100.0/resolution
if object exist(tree)
if limb exist(tree,n#)=1 then scroll limb texture tree,n#,(((n#*resolution)/5.0)*sin(theta#+tree*10))*0.0001,(((n#*resolution)/3.0)*sin(theta#+tree*10))*0.00005
endif
inc theta#,0.01
next n#
next tree

endfunction

function create_bark

bark=check_free_image_number()
cls
box 0,0,500,500,rgb(100,80,40),rgb(70,30,20),rgb(150,120,80),rgb(80,60,20)

for x=1 to 2500
ink rgb(rnd(50)+50,40,20),0
dot rnd(500),rnd(500)
next x
for x=0 to 500
if rnd(3)=1
line x,0,x+rnd(100)-50,500
endif
next x
get image bark,0,0,500,500

endfunction

sync on
autocam off
sync rate 60
color backdrop rgb(10,20,40)
color ambient light rgb(200,200,255)
set ambient light 4

`make_specularmap()
`make_snowmap()
`make_shader_snow()
make_textures()

rotate light 0,140,0,-40
color light 0,rgb(100,100,128)

load effect "snowshader.fx",1,1
set effect constant integer 1,"SpecularPower",15


LightDir = 1
null = Make Vector4(LightDir)
SET VECTOR4 LightDir, light direction x(0), light direction y(0), light direction z(0), 0
set effect constant vector 1,"LightDir",LightDir

`Making our textures.&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
create bitmap 1,64,64
set current bitmap 1
ink rgb(5,5,5),0
CircleFill(32, 32, 30, rgb(5,5,5))
get image 1,0,0,64,64
ink 0,0
cls
ink rgb(128,0,0),0
box 0,0,50,64
box 0,0,64,5
box 0,20,64,25
box 0,40,64,45
box 0,60,64,64
get image 2,0,0,64,64
set current bitmap 0
delete bitmap 1

`&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

`********WORLD***********
make object plain 3,200,200
scale object texture 3,8,8
rotate object 3,-90,0,0
set object effect 3,1

`*******SNOWMAN************
make object sphere 2,4
set object effect 2,1
position object 2,0,1,20


` HEAD - Limb 1.
make object sphere 4,3
make mesh from object 1,4
delete object 4
add limb 2,1,1
link limb 2,0,1
offset limb 2,1,0,3,0
set limb effect 2,1,1
delete mesh 1

`COAL MOUTH - Limb 2.
make object sphere 11,0.4,4,4
make mesh from object 11,11
delete object 11
add limb 2,2,11
delete mesh 11
link limb 2,1,2
offset limb 2,2,0.2,-0.35,1.4
color limb 2,2,rgb(5,5,5)

`CARROT NOSE - Limb 3.
make object cone 7,1
scale object 7,50,130,50
make mesh from object 7,7
delete object 7
add limb 2,3,7
link limb 2,1,3
delete mesh 7
offset limb 2,3,0,0.15,1.8
rotate limb 2,3,95,0,0
color limb 2,3,rgb(255,175,0)

`RIGHT EYE - Limb 4.
make object sphere 9,0.45,4,4
make mesh from object 9,9
add limb 2,4,9
link limb 2,1,4
offset limb 2,4,-0.65,0.45,1.2
color limb 2,4,rgb(5,5,5)
delete object 9
delete mesh 9

`LEFT EYE - Limb 5.
make object sphere 10,0.45,4,4
make mesh from object 10,10
add limb 2,5,10
link limb 2,1,5
offset limb 2,5,0.65,0.45,1.2
color limb 2,5,rgb(5,5,5)
delete object 10
delete mesh 10

` HAT BRIM - Limb 6.
make object plain 5,4,4
set object cull 5,0
rotate object 5,-90,0,0
make mesh from object 5,5
add limb 2,6,5
link limb 2,1,6
offset limb 2,6,0,0.94,0
texture limb 2,6,1
delete object 5
delete mesh 5

`HAT PILLAR - Limb 7.
make object cylinder 6,2.25
make mesh from object 6,6
add limb 2,7,6
link limb 2,6,7
offset limb 2,7,0,0.8,0
color limb 2,7,rgb(5,5,5)
delete object 6
delete mesh 6

`HAT TOP - Limb 8.
make object plain 8,2.35,2.35
rotate object 8,-90,0,15
make mesh from object 8,8
add limb 2,8,8
link limb 2,7,8
texture limb 2,8,1
offset limb 2,8,0,1.29,0
delete object 8
delete mesh 8

`SCARF - Limb 9
make object cylinder 12,2.4
scale object 12,100,25,100
color object 12,rgb(128,0,0)
rotate object 12,0,0,5
make mesh from object 12,12
add limb 2,9,12
link limb 2,0,9
offset limb 2,9,0,1.75,0
color limb 2,9,rgb(128,0,0)
delete object 12
delete mesh 12


`SCARF TASSLES
make object plain 13,2,1
rotate object 13,0,40,90
texture object 13,2
set object transparency 13,1
scale object texture 13,1,4
make mesh from object 13,13
add limb 2,10,13
link limb 2,9,10
offset limb 2,10,0,-0.6,1.7
texture limb 2,10,2
delete object 13
delete mesh 13


`&&&&&&&&& MAKE THE SNOWMAN TRANSPARENT
set object transparency 2,4
set object cull 2,0


position object 2,40,1,0

PERFORM CHECKLIST FOR EFFECT VALUES 1

`set ambient light 4
`color light 0,rgb(255,255,255)

position camera 0,0,3.25,40
rotate camera 0,0,180,0




make_logcabin()









do



control camera using arrowkeys 0,1,1

`rotate limb 2,1,0,sin(timer()/10)*10,0
rotate limb 2,1,-abs(sin(timer()/6)*10)+10,0,0

`position object 2,object position x(2),abs(sin(timer()/6)*3)+1,object position z(2)

if ticker < 5
   ticker = ticker + 1
else
   color light 2,rgb(255,rnd(40)+150,50)
   ticker = 0
   for i = 0 to 15
      xpos# = (rnd(200)/100.0)-1.0
      ypos# = (rnd(200)/100.0)-1.0
      zpos# = (rnd(200)/100.0)-1.0
      position object 960+i,xpos#,2.0+ypos#,17.5+zpos#
   next i

   for i = 0 to 60
      emissiverand = rnd(255)
      set object emissive 980+i,rgb(emissiverand,emissiverand,emissiverand)
      scalerand = 100+(rnd(80)-25)
      scale object 980+i,scalerand,scalerand,scalerand
next i


endif

for i = 0 to 15
   emissiverand = rnd(255)
   set object emissive 960+i,rgb(emissiverand,emissiverand,emissiverand)
   scalerand = 100+(rnd(80)-25)
   scale object 960+i,scalerand,scalerand,scalerand
next i

for i = 0 to 60
   point object 980+i,camera position x(),camera position y(),camera position z()
next i

sync

loop







function CircleFill(x, y, radius, colour)
   ink colour, 0
   circle x, y, radius
   FloodFill(x, y, colour)
endfunction

function EllipseFill(x, y, radiusX, radiusY, colour)
   ink colour, 0
   ellipse x, y, radiusX, radiusY
   FloodFill(x, y, colour)
endfunction

function FloodFill(x, y, fillColour as dword)
   backgroundColour = point(x, y) : rem this should work in all bpp display modes
   if backgroundColour = fillColour then exitfunction
   ink fillColour, 0              : rem setup the fill colour as foreground, and background as black (this is not used)
   lock pixels

   __FloodFill(x, y, backgroundColour)

   unlock pixels
endfunction

function __FloodFill(x, y, backgroundColour as dword)
   BitmapWidth  = bitmap width()

   rem do current row as far as possible
   x1 = x - 1
   while (x1 >= 0) and (point(x1, y) = backgroundColour)
      dec x1
   endwhile
   rem from current point find righthand extent
   x2 = x + 1
   while (x2 < BitmapWidth) and (point(x2, y) = backgroundColour)
      inc x2
   endwhile
   inc x1
   if x2 - x1 > 0
      line x1, y, x2, y : rem draw a line between the extents

      for z = 1 to 2
         if z = 1
            y2 = y - 1 : rem process line of pixels above working along all breaks in the line
         else
            y2 = y + 1 : rem process line of pixels below working along all breaks in the line
         endif

         if (y > 0 and z = 1) or (y < bitmap height() - 1 and z = 2)
            x4 = x1
            while x4 > 0 and point(x4, y2) = backgroundColour
               dec x4
            endwhile
            x5 = x2 - 1
            while x5 < BitmapWidth - 1 and point(x5, y2) = backgroundColour
               inc x5
            endwhile
            newExtent = 1
            for x3 = x4 to x5 - 1
               if point(x3, y2) = backgroundColour
                  if newExtent = 1
                     newExtent = 0
                     xstart = x3
                  endif
               else
                  if newExtent = 0
                     __FloodFill(xstart, y2, backgroundColour)
                     newExtent = 1
                  endif
               endif
            next
            if newExtent = 0 then __FloodFill(xstart, y2, backgroundColour)
         endif
      next
   endif
endfunction





function make_shader_snow()

string1$ = "float4x4 matWorldViewProj : WorldViewProjection; float4x4 matWorld   : World; float3 vecEye : cameraposition;"
string2$ = "float4 LightDir : Direction < string Object = "+CHR$(34)+"DirectionalLight"+CHR$(34)+"; string Space = "+CHR$(34)+"World"+CHR$(34)+"; > = {-1.0f, 1.0f, -1.0f, 0.0f};"
string3$ = "int SpecularPower = 15;"
string4$ = "texture diffuseTexture : Diffuse < string name = "+CHR$(34)+"snow_texture.bmp"+CHR$(34)+"; >;"
string5$ = "texture specularTexture : Specular < string name = "+CHR$(34)+"snow_specular.bmp"+CHR$(34)+"; >;"
string6$ = "struct VS_OUTPUT { float4 Pos : POSITION; float2 Tex : TEXCOORD0; float3 Norm : TEXCOORD1; float3 View : TEXCOORD2; float3 Light : TEXCOORD3; };"
string7$ = "VS_OUTPUT VS(float4 Pos : POSITION, float3 Normal : NORMAL, float2 Tex : TEXCOORD) { VS_OUTPUT Out = (VS_OUTPUT)0; Out.Pos = mul(Pos, matWorldViewProj);  Out.Light = LightDir; float3 PosWorld = normalize(mul(Pos, matWorld)); Out.View = vecEye - PosWorld; Out.Norm = mul(Normal, matWorld); Out.Tex = Tex.xy; return Out; }"
string8$ = "sampler SpecularMapSampler = sampler_state { texture = <specularTexture>; AddressU  = CLAMP; AddressV  = CLAMP; AddressW  = CLAMP; MIPFILTER = LINEAR; MINFILTER = LINEAR; MAGFILTER = LINEAR; };"
string9$ = "sampler DiffuseMapSampler = sampler_state {texture = <diffuseTexture>; AddressU  = CLAMP; AddressV  = CLAMP; AddressW  = CLAMP; MIPFILTER = LINEAR; MINFILTER = LINEAR; MAGFILTER = LINEAR;};"
string10$ = "float4 PS(float2 Tex: TEXCOORD0, float3 Norm : TEXCOORD1, float3 View : TEXCOORD2, float3 Light: TEXCOORD3) : COLOR"
string11$ = "{ float4 psOut; float3 SpecLevel = tex2D(SpecularMapSampler, Tex).xyz; float4 diffuse = tex2D(DiffuseMapSampler, Tex); float4 ambient = {0.2, 0.25, 0.25, 1.0}; float3 Normal = normalize(Norm); float3 LightDir = -normalize(Light);"
string12$ = "float3 ViewDir = normalize(View); float4 diff = saturate(dot(Normal, LightDir)); float3 H = normalize(LightDir + ViewDir); float4 Specular = pow(saturate(dot(Normal, H)), SpecularPower); psOut.rgb = ambient + (diffuse * diff + Specular * SpecLevel); psOut.a = 1.0f; return(psOut);}"
string13$ = "technique textured { pass p0 { VertexShader = compile vs_1_1 VS(); PixelShader  = compile ps_2_0 PS(); } }"



if file exist("snowshader.fx") = 1
   delete file "snowshader.fx"
endif
   open to write 1,"snowshader.fx"

   write string 1,string1$: write string 1,string2$: write string 1,string3$: write string 1,string4$: write string 1,string5$
   write string 1,string6$: write string 1,string7$: write string 1,string8$: write string 1,string9$: write string 1,string10$
   write string 1,string11$: write string 1,string12$: write string 1,string13$
   close file 1

endfunction


function make_specularmap()

create bitmap 1,1024,1024
set current bitmap 1
ink rgb(255,255,255),0
for i = 0 to 4000
   dot rnd(1023),rnd(1023)
next i

get image 10,0,0,1024,1024
save image "snow_specular.bmp",10

set current bitmap 0
delete bitmap 1
delete image 10
endfunction



function make_snowmap()

create bitmap 1,1024,1024
set current bitmap 1
ink rgb(220-40,230-40,255-40),0
box 0,0,1024,1024
ink rgb(255-20,255-20,255-20),0
for i = 0 to 2000
   dot rnd(1023),rnd(1023)
next i

ink rgb(0,0,255-20),0
for i = 0 to 1000
   dot rnd(1023),rnd(1023)
next i

blur bitmap 1,4

get image 10,0,0,1024,1024
save image "snow_texture.bmp",10
set current bitmap 0
delete image 10,
delete bitmap 1

endfunction




function make_logcabin()

`biglog = free_object()
`make object cylinder biglog,4
`scale object biglog,100,1000,100
`rotate object biglog,90,0,0

for i = 0 to 3
   make object cylinder 900+i,4
   scale object 900+i,75,1000,75
   rotate object 900+i,90,0,0
   position object 900+i,-10,(i*3)+1,0
   `color object 900+i,rgb(128,64,0)
   set object effect 900+i,1
next i

for i = 0 to 2
   make object cylinder 910+i,4
   scale object 910+i,75,400,75
   rotate object 910+i,90,0,0
   position object 910+i,10,(i*3)+1,-12
   `color object 910+i,rgb(128,64,0)
   set object effect 910+i,1
next i

for i = 0 to 2
   make object cylinder 915+i,4
   scale object 915+i,75,400,75
   rotate object 915+i,90,0,0
   position object 915+i,10,(i*3)+1,12
   set object effect 915+i,1
   `color object 915+i,rgb(128,64,0)
next i

make object cylinder 919,4
scale object 919,75,1000,75
rotate object 919,90,0,0
position object 919,10,(3*3)+1,0
set object effect 919,1



make object box 920,20,0.5,40
position object 920,0,0,0
color object 920,rgb(128,64,0)


for i = 0 to 3
   make object cylinder 921+i,4
   scale object 921+i,75,500,75
   rotate object 921+i,90,90,0
   position object 921+i,0,(i*3)+1,-20
   set object effect 921+i,1

next i

for i = 0 to 3
   make object cylinder 925+i,4
   scale object 925+i,75,500,75
   rotate object 925+i,90,90,0
   position object 925+i,0,(i*3)+1,20
   set object effect 925+i,1

next i

make object box 929,20,0.5,48
position object 929,7.5,15,0
rotate object 929,0,0,-40
set object effect 929,1

make object box 930,20,0.5,48
position object 930,-7.5,15,0
rotate object 930,0,0,40
set object effect 930,1


make object cylinder 932,4
scale object 932,75,300,75
position object 932,10,5.25,20
set object effect 932,1


make object cylinder 933,4
scale object 933,75,300,75
position object 933,-10,5.25,20
set object effect 933,1


make object cylinder 934,4
scale object 934,75,300,75
position object 934,10,5.25,-20
set object effect 934,1


make object cylinder 935,4
scale object 935,75,300,75
position object 935,-10,5.25,-20
set object effect 935,1


`Gable Ends
make object triangle 936,11,11,20,-11,11,20,0,21,20
color object 936,rgb(128,64,0)
make object triangle 937,11,11,-20,-11,11,-20,0,21,-20

`Inner Walls
make object plain 938,20,40
rotate object 938,90,0,90
position object 938,-8.5,2,0
color object 938,rgb(128,64,0)

make object plain 939,20,15
rotate object 939,90,0,90
position object 939,8.5,2,-11.5
color object 939,rgb(128,64,0)

make object plain 940,20,15
rotate object 940,90,0,90
position object 940,8.5,2,11.5
color object 940,rgb(128,64,0)

make object plain 941,4,15
rotate object 941,90,0,90
position object 941,8.5,10,0
color object 941,rgb(128,64,0)

make object plain 942,20,17
rotate object 942,0,0,90
position object 942,0,2,-18.5
color object 942,rgb(128,64,0)

make object plain 943,20,17
rotate object 943,0,0,90
position object 943,0,2,18.5
color object 943,rgb(128,64,0)

`Doorframe
make object box 944,3.25,8,1
position object 944,10,4,4

make object box 945,3.25,8,1
position object 945,10,4,-4

make object box 946,4,1,10
position object 946,10,8.5,0

make object box 947,4,1,10
position object 947,10,0,0

`Fireplace
make object box 948,8,1,6
position object 948,0,0.25,18

make object box 949,1,3,4
position object 949,-2,2,18

make object box 950,1,3,4
position object 950,2,2,18

make object box 951,4,3,0.25
position object 951,0,2,18.5

make object box 952,5,1,4
position object 952,0,4,18

make object box 953,3.5,20,3
position object 953,0,14.5,18
`set object emissive 953,rgb(128,0,0)

make object box 954,4.5,2,4
position object 954,0,24,18

make object cylinder 955,2
position object 955,0,25,18

`Light?
make light 1
position light 1,0,2,17.5
color light 1,rgb(128,10,0)
set light range 1,40

make light 2
position light 2,0,8,0
color light 2,rgb(255,220,50)
set light range 2,30

`Presents!
make object cube 956,2
position object 956,5,1,13
rotate object 956,0,20,0
texture object 956,100
set object emissive 956,rgb(10,10,10)

make object cube 957,1.5
position object 957,6,0.75,11
rotate object 957,0,-15,0
texture object 957,101
set object emissive 957,rgb(10,10,10)

make object box 958,1.5,4,1.5
position object 958,6,2.25,17
rotate object 958,20,0,0
texture object 958,101
set object emissive 957,rgb(10,10,10)

`flickers

for i = 0 to 15
   make object plain 960+i,0.5,0.5
   xpos# = (rnd(200)/100.0)-1.0
   ypos# = (rnd(200)/100.0)-1.0
   zpos# = (rnd(200)/100.0)-1.0
   position object 960+i,xpos#,2.0+ypos#,17.5+zpos#
   texture object 960+i,200
   ghost object on 960+i
   set object emissive 960+i,rgb(255,255,255)
   rotate object 960+i,0,0,rnd(180)
next i

`stars

for i = 0 to 60
   make object plain 980+i,5,5
   xpos# = rnd(200)-100.0
   ypos# = rnd(200)-50.0
   zpos# = rnd(200)-100.0
   position object 980+i,xpos#,100+ypos#,zpos#
   texture object 980+i,201
   ghost object on 980+i
   set object emissive 980+i,rgb(255,255,255)
next i

endfunction





Function make_textures()

create bitmap 1,64,64
set current bitmap 1
ink rgb(128,0,0),0
box 0,0,64,64
ink rgb(128,128,0),0
box 28,0,36,64
box 0,28,64,36
get image 100,0,0,64,64

box 0,0,64,64
ink rgb(0,0,255),0
box 28,0,36,64
box 0,28,64,36
get image 101,0,0,64,64


ink 0,0
box 0,0,64,64
ink rgb(255,80,0),0
box 26,26,38,38
ink rgb(255,140,0),0
box 28,14,37,50
box 14,28,50,37
ink rgb(255,180,0),0
box 30,10,35,54
box 10,30,54,35
ink rgb(255,255,0),0
box 31,4,34,60
box 4,31,60,34
blur bitmap 1,5
get image 200,0,0,64,64,1

ink 0,0
box 0,0,64,64
ink rgb(80,80,80),0
box 26,26,38,38
ink rgb(140,140,140),0
box 28,14,37,50
box 14,28,50,37
ink rgb(200,200,200),0
box 30,10,35,54
box 10,30,54,35
ink rgb(255,255,255),0
box 31,4,34,60
box 4,31,60,34
blur bitmap 1,5
get image 201,0,0,64,64,1


set current bitmap 0
delete bitmap 1

endfunction












Function free_image()
   i=100
   Do
      If Image Exist(i)=0 then Exit
      inc i
   Loop
Endfunction i

Function free_object()
   i=100
   Do
      If Object Exist(i)=0 then Exit
      inc i
   Loop
Endfunction i


Function Get_Ground_Height_Not_Player(TerrainID,x#,z#)

   local_grounddistance# = intersect object (TerrainID,x#,500,z#,x#,-500,z#)
   local_height# = 500 - local_grounddistance#

EndFunction local_height#

`CODE BASED ON:
`   http://2dnow.zenzer.net/viewarticle.php?a=10
set display mode 1280, 1024, 32
sync on
sync rate 0

`Define the required constants for the fire
#constant MAX_CHANGES          6
#constant SECTOR_WIDTH         128
#constant SECTOR_HEIGHT        128
#constant COOLING_RATE         1
#constant NUM_COALS_PER_UPDATE 1
#constant UPDATE_RATE          20
global SPARK_HEAT = 192

#constant MEMBLOCK_ID   1
#constant IMAGE_ID      1


`Define image
dim FireData(SECTOR_WIDTH, SECTOR_HEIGHT)
for x = 0 to SECTOR_WIDTH-1
   for y = 0 to SECTOR_HEIGHT-1
      FireData(x, y) = 0
   next y
next x



`Create a memblock for it
make memblock MEMBLOCK_ID, 12 + (SECTOR_WIDTH * SECTOR_HEIGHT * 4)
write memblock dword 1, 0, SECTOR_WIDTH
write memblock dword 1, 4, SECTOR_HEIGHT
write memblock dword 1, 8, 32




`Define Flame Colors
Type FireColour
   Red
   Green
   Blue
   Alpha
   Temperature as Byte
EndType
Dim ColourChanges(MAX_CHANGES) as FireColour

ColourChanges(0).Red = 255
ColourChanges(0).Green = 255
ColourChanges(0).Blue = 255
ColourChanges(0).Alpha = 255
ColourChanges(0).Temperature = 255


ColourChanges(1).Red = 255
ColourChanges(1).Green = 255
ColourChanges(1).Blue = 0
ColourChanges(1).Alpha = 160
ColourChanges(1).Temperature = 64


ColourChanges(2).Red = 255
ColourChanges(2).Green = 128
ColourChanges(2).Blue = 0
ColourChanges(2).Alpha = 160
ColourChanges(2).Temperature = 48


ColourChanges(3).Red = 128
ColourChanges(3).Green = 64
ColourChanges(3).Blue = 64
ColourChanges(3).Alpha = 128
ColourChanges(3).Temperature = 32


ColourChanges(4).Red = 64
ColourChanges(4).Green = 32
ColourChanges(4).Blue = 0
ColourChanges(4).Alpha = 64
ColourChanges(4).Temperature = 16


ColourChanges(5).Red = 0
ColourChanges(5).Green = 0
ColourChanges(5).Blue = 0
ColourChanges(5).Alpha = 0
ColourChanges(5).Temperature = 0

`Create the fire color interpolation
currentC as FireColour
nextC as FireColour
CurrentEntry = 255
r as byte
g as byte
b as byte

Dim FireColours(255) as DWORD
for i = 0 to 4
   currentC = ColourChanges(i)
   nextC = ColourChanges(i+1)
   for j = currentC.Temperature to nextC.Temperature + 1 step -1
      interpFactor# = (currentC.Temperature - CurrentEntry) / (1.0 * (currentC.Temperature - nextC.Temperature))
      r = currentC.Red   + (nextC.Red   - currentC.Red)   * interpFactor#
      g = currentC.Green + (nextC.Green - currentC.Green) * interpFactor#
      b = currentC.Blue  + (nextC.Blue  - currentC.Blue)  * interpFactor#
      a = currentC.Alpha + (nextC.Alpha - currentC.Alpha) * interpFactor#
      FireColours(CurrentEntry) = rgba(r, g, b, a)
      dec CurrentEntry
   next j
next i




make object plain 1, 2, 1
position object 1, 0.0, 0.5, 0.0
point object    1, 0.0, 0.5, 1.0
set object transparency 1, 3
set object light 1, 0
UpdateFire()
texture object 1, 1



`Create a room
`left wall to fire
make object box 100,  3.0, 4.0, 1.0
position object 100, -2.5, 2.0, 0.0

`right wall to fire
make object box 101, 3.0, 4.0, 1.0
position object 101, 2.5, 2.0, 0.0

`top wall above fire
make object box 102, 2.0, 3.0, 1.0
position object 102, 0.0, 2.5, 0.0
`back of fire
make object box 103, 2.0, 1.0, 0.25
position object 103, 0.0, 0.5, -0.375


`make floor
make object plain 110, 8.0, 11.0
position object   110, 0.0, 0.0, 5.0
point object      110, 0.0, 1.0, 5.0


`make other walls
make object box 120, 10.0, 4.0, 1.0
position object 120, -3.5, 2.0, 5.0
point object    120,  0.0, 2.0, 5.0

make object box 121, 10.0, 4.0, 1.0
position object 121,  3.5, 2.0, 5.0
point object    121,  0.0, 2.0, 5.0






`Make a tree
#CONSTANT tX 256
#CONSTANT tY 256
make memblock 2, 12 + (tX * tY * 4)
write memblock dword 2, 0, tX
write memblock dword 2, 4, tY
write memblock dword 2, 8, 32
for x = 0 to tX-1
   for y = 0 to tY-1
      write memblock dword 2, 12 + ((x + (y*tX))*4), rgba(64,    192 + rnd(63),    64,   128 + rnd(96))
   next y
next x
make image from memblock 2, 2
delete memblock 2
make object cone 2, 1
scale object 2, 100, 200, 100
texture object 2, 2
set object transparency 2, 3
position object 2, 2, 1, 4










autocam off
CAM_D# = 10.0
CAM_A# = 0.0
CAM_Cx# = object size z(110) * 0.5
CAM_Cz# = object size y(110) * 0.5
gosub POSITION_CAMERA






set point light 0, 0, 1.0, 1.0
global LIGHT_COLOR as DWORD

`Start the firedrawing!!
frameTime# = 1.0
startTime = timer()
FLAME_UPDATE# = 0
do
   frameTime# = (frameTime# * 0.8) + ((timer() - startTime) * 0.2)
   startTime = timer()

   CAM_A# = sin(timer() * 0.0225) * 30.0
   gosub POSITION_CAMERA


   text 0, 0, "FPS: " + str$(screen fps())
   text 0, 10, "Flame heat: " + str$(SPARK_HEAT)

   y = SECTOR_HEIGHT - ((SPARK_HEAT * SECTOR_HEIGHT) / 756)
   text 0, 20, "Y: " + str$(y)
   LIGHT_COLOR = FireColours(FireData(SECTOR_WIDTH / 2, y))
   color light 0, LIGHT_COLOR




   z = mousemovez()
   if SPARK_HEAT < 250 AND z > 0 then inc SPARK_HEAT, 5
   if SPARK_HEAT > 5   AND z < 0 then dec SPARK_HEAT, 5

   if FLAME_UPDATE# >= UPDATE_RATE
      UpdateFire()
      FLAME_UPDATE# = 0
   else
      inc FLAME_UPDATE#, frameTime#
   endif
   sync
loop



POSITION_CAMERA:
   position camera CAM_Cx# + (sin(CAM_A#) * CAM_D#),      8,      CAM_Cz# + (cos(CAM_A#) * CAM_D#)
   point camera CAM_Cx#, 0, CAM_Cz#
return











function UpdateFire()
   Dim FireDataCopy(SECTOR_WIDTH, SECTOR_HEIGHT)
`   clr as byte

   for x = 0 to SECTOR_WIDTH - 2
      for y = 0 to SECTOR_HEIGHT - 2
         clr = FireData(x, y)
         write memblock dword 1, 12 + ((y * SECTOR_WIDTH) + x) * 4, FireColours(clr)
         FireDataCopy(x, y) = clr
      next y
   next x
   make image from memblock 1, 1


   `Scroll the flame
   for x = 0 to SECTOR_WIDTH - 1
      for y = 0 to SECTOR_HEIGHT - 2
         FireDataCopy(x, y) = FireDataCopy(x, y + 1)
      next y
   next x


   `Create sparks
   for y = SECTOR_HEIGHT - 4 to SECTOR_HEIGHT -2
      for x = 1 to SECTOR_WIDTH - 2
         FireDataCopy(x, y) = rand() * SPARK_HEAT
      next x
   next y


   `Create coals
   y = SECTOR_HEIGHT -2
   For i = 0 to NUM_COALS_PER_UPDATE -1
      x = rand() * (SECTOR_WIDTH - 2)

      FireDataCopy(x - 1, y - 1) = 255
      FireDataCopy(x - 1, y    ) = 255
      FireDataCopy(x - 1, y + 1) = 255
      FireDataCopy(x    , y - 1) = 255
      FireDataCopy(x    , y    ) = 255
      FireDataCopy(x    , y + 1) = 255
      FireDataCopy(x + 1, y - 1) = 255
      FireDataCopy(x + 1, y    ) = 255
      FireDataCopy(x + 1, y + 1) = 255
   next i



   `Blur the image
   for x = 1 to SECTOR_WIDTH - 1
      for y = 1 to SECTOR_HEIGHT -1
         clr = (_
                  FireDataCopy(x - 1, y    ) +_
                  FireDataCopy(x + 1, y    ) +_
                  FireDataCopy(x    , y - 1) +_
                  FireDataCopy(x    , y + 1) +_
                  FireDataCopy(x - 1, y - 1) +_
                  FireDataCopy(x - 1, y + 1) +_
                  FireDataCopy(x + 1, y - 1) +_
                  FireDataCopy(x + 1, y + 1)  _
                ) / 8.0

         if clr >= COOLING_RATE then dec clr, COOLING_RATE

         FireData(x, y) = clr
      next y
   next x
endfunction


function rand()
   rndVal# = rnd(1000000) / 1000000.0
endfunction rndVal#

function rgba(r as integer,g as integer,b as integer,a as integer)
  colour as dword
  colour = (b)+(g*256)+(r*65536)+(a*16777216)
endfunction colour

`CODE BASED ON:
`   http://2dnow.zenzer.net/viewarticle.php?a=10
set display mode 1280, 1024, 32
sync on
sync rate 0
color backdrop 0
set ambient light 0


`Define the required constants for the fire
#constant MAX_CHANGES          6
#constant SECTOR_WIDTH         128
#constant SECTOR_HEIGHT        128
#constant COOLING_RATE         1
#constant NUM_COALS_PER_UPDATE 1
#constant UPDATE_RATE          20
global SPARK_HEAT = 132

#constant MEMBLOCK_ID   1
#constant IMAGE_ID      1


`Define image
dim FireData(SECTOR_WIDTH, SECTOR_HEIGHT)
for x = 0 to SECTOR_WIDTH-1
   for y = 0 to SECTOR_HEIGHT-1
      FireData(x, y) = 0
   next y
next x



`Create a memblock for it
make memblock MEMBLOCK_ID, 12 + (SECTOR_WIDTH * SECTOR_HEIGHT * 4)
write memblock dword 1, 0, SECTOR_WIDTH
write memblock dword 1, 4, SECTOR_HEIGHT
write memblock dword 1, 8, 32




`Define Flame Colors
Type FireColour
   Red
   Green
   Blue
   Alpha
   Temperature as Byte
EndType
Dim ColourChanges(MAX_CHANGES) as FireColour

ColourChanges(0).Red = 255
ColourChanges(0).Green = 255
ColourChanges(0).Blue = 255
ColourChanges(0).Alpha = 255
ColourChanges(0).Temperature = 255


ColourChanges(1).Red = 255
ColourChanges(1).Green = 255
ColourChanges(1).Blue = 0
ColourChanges(1).Alpha = 160
ColourChanges(1).Temperature = 64


ColourChanges(2).Red = 255
ColourChanges(2).Green = 128
ColourChanges(2).Blue = 0
ColourChanges(2).Alpha = 160
ColourChanges(2).Temperature = 48


ColourChanges(3).Red = 128
ColourChanges(3).Green = 64
ColourChanges(3).Blue = 64
ColourChanges(3).Alpha = 128
ColourChanges(3).Temperature = 32


ColourChanges(4).Red = 64
ColourChanges(4).Green = 32
ColourChanges(4).Blue = 0
ColourChanges(4).Alpha = 64
ColourChanges(4).Temperature = 16


ColourChanges(5).Red = 0
ColourChanges(5).Green = 0
ColourChanges(5).Blue = 0
ColourChanges(5).Alpha = 0
ColourChanges(5).Temperature = 0

`Create the fire color interpolation
currentC as FireColour
nextC as FireColour
CurrentEntry = 255
r as byte
g as byte
b as byte

Dim FireColours(255) as DWORD
for i = 0 to 4
   currentC = ColourChanges(i)
   nextC = ColourChanges(i+1)
   for j = currentC.Temperature to nextC.Temperature + 1 step -1
      interpFactor# = (currentC.Temperature - CurrentEntry) / (1.0 * (currentC.Temperature - nextC.Temperature))
      r = currentC.Red   + (nextC.Red   - currentC.Red)   * interpFactor#
      g = currentC.Green + (nextC.Green - currentC.Green) * interpFactor#
      b = currentC.Blue  + (nextC.Blue  - currentC.Blue)  * interpFactor#
      a = currentC.Alpha + (nextC.Alpha - currentC.Alpha) * interpFactor#
      FireColours(CurrentEntry) = rgba(r, g, b, a)
      dec CurrentEntry
   next j
next i




make object plain 1, 2, 1
position object 1, 0.0, 0.5, 0.0
point object    1, 0.0, 0.5, 1.0
set object transparency 1, 3
set object light 1, 0
UpdateFire()
texture object 1, 1



`Create a room
`left wall to fire
make object box 100,  3.0, 4.0, 1.0
position object 100, -2.5, 2.0, 0.0

`right wall to fire
make object box 101, 3.0, 4.0, 1.0
position object 101, 2.5, 2.0, 0.0

`top wall above fire
make object box 102, 2.0, 3.0, 1.0
position object 102, 0.0, 2.5, 0.0
`back of fire
make object box 103, 2.0, 1.0, 0.25
position object 103, 0.0, 0.5, -0.375


`make floor
make object plain 110, 8.0, 11.0
position object   110, 0.0, 0.0, 5.0
point object      110, 0.0, 1.0, 5.0


`make other walls
make object box 120, 10.0, 4.0, 1.0
position object 120, -3.5, 2.0, 5.0
point object    120,  0.0, 2.0, 5.0

make object box 121, 10.0, 4.0, 1.0
position object 121,  3.5, 2.0, 5.0
point object    121,  0.0, 2.0, 5.0






`Make a tree
#CONSTANT tX 256
#CONSTANT tY 256
make memblock 2, 12 + (tX * tY * 4)
write memblock dword 2, 0, tX
write memblock dword 2, 4, tY
write memblock dword 2, 8, 32
for x = 0 to tX-1
   for y = 0 to tY-1
      write memblock dword 2, 12 + ((x + (y*tX))*4), rgba(64,    192 + rnd(63),    64,   128 + rnd(96))
   next y
next x
make image from memblock 2, 2
delete memblock 2
make object cone 2, 1
scale object 2, 100, 200, 100
texture object 2, 2
set object transparency 2, 3
position object 2, 2, 1, 4










autocam off
CAM_D# = 10.0
CAM_A# = 0.0
CAM_Cx# = object size z(110) * 0.5
CAM_Cz# = object size y(110) * 0.5
gosub POSITION_CAMERA






set point light 0, 0, 1.0, 1.0
global LIGHT_COLOR as DWORD

`Start the firedrawing!!
frameTime# = 1.0
startTime = timer()
FLAME_UPDATE# = 0
do
   frameTime# = (frameTime# * 0.8) + ((timer() - startTime) * 0.2)
   startTime = timer()

   CAM_A# = sin(timer() * 0.0225) * 30.0
   gosub POSITION_CAMERA


   text 0, 0, "FPS: " + str$(screen fps())
   text 0, 10, "Flame heat: " + str$(SPARK_HEAT)

   y = SECTOR_HEIGHT - ((SPARK_HEAT * SECTOR_HEIGHT) / 756)
   text 0, 20, "Y: " + str$(y)
   LIGHT_COLOR = FireColours(FireData(SECTOR_WIDTH / 2, y))
   color light 0, LIGHT_COLOR




   z = mousemovez()
   if SPARK_HEAT < 250 AND z > 0 then inc SPARK_HEAT, 5
   if SPARK_HEAT > 5   AND z < 0 then dec SPARK_HEAT, 5

   if FLAME_UPDATE# >= UPDATE_RATE
      UpdateFire()
      FLAME_UPDATE# = 0
   else
      inc FLAME_UPDATE#, frameTime#
   endif
   sync
loop



POSITION_CAMERA:
   position camera CAM_Cx# + (sin(CAM_A#) * CAM_D#),      8,      CAM_Cz# + (cos(CAM_A#) * CAM_D#)
   point camera CAM_Cx#, 0, CAM_Cz#
return











function UpdateFire()
   Dim FireDataCopy(SECTOR_WIDTH, SECTOR_HEIGHT)
`   clr as byte

   for x = 0 to SECTOR_WIDTH - 2
      for y = 0 to SECTOR_HEIGHT - 2
         clr = FireData(x, y)
         write memblock dword 1, 12 + ((y * SECTOR_WIDTH) + x) * 4, FireColours(clr)
         FireDataCopy(x, y) = clr
      next y
   next x
   make image from memblock 1, 1


   `Scroll the flame
   for x = 0 to SECTOR_WIDTH - 1
      for y = 0 to SECTOR_HEIGHT - 2
         FireDataCopy(x, y) = FireDataCopy(x, y + 1)
      next y
   next x


   `Create sparks
   for y = SECTOR_HEIGHT - 4 to SECTOR_HEIGHT -2
      for x = 1 to SECTOR_WIDTH - 2
         FireDataCopy(x, y) = rand() * SPARK_HEAT
      next x
   next y


   `Create coals
   y = SECTOR_HEIGHT -2
   For i = 0 to NUM_COALS_PER_UPDATE -1
      x = rand() * (SECTOR_WIDTH - 2)

      FireDataCopy(x - 1, y - 1) = 255
      FireDataCopy(x - 1, y    ) = 255
      FireDataCopy(x - 1, y + 1) = 255
      FireDataCopy(x    , y - 1) = 255
      FireDataCopy(x    , y    ) = 255
      FireDataCopy(x    , y + 1) = 255
      FireDataCopy(x + 1, y - 1) = 255
      FireDataCopy(x + 1, y    ) = 255
      FireDataCopy(x + 1, y + 1) = 255
   next i



   `Blur the image
   for x = 1 to SECTOR_WIDTH - 1
      for y = 1 to SECTOR_HEIGHT -1
         clr = (_
                  FireDataCopy(x - 1, y    ) +_
                  FireDataCopy(x + 1, y    ) +_
                  FireDataCopy(x    , y - 1) +_
                  FireDataCopy(x    , y + 1) +_
                  FireDataCopy(x - 1, y - 1) +_
                  FireDataCopy(x - 1, y + 1) +_
                  FireDataCopy(x + 1, y - 1) +_
                  FireDataCopy(x + 1, y + 1)  _
                ) / 8.0

         if clr >= COOLING_RATE then dec clr, COOLING_RATE

         FireData(x, y) = clr
      next y
   next x
endfunction


function rand()
   rndVal# = rnd(1000000) / 1000000.0
endfunction rndVal#

function rgba(r as integer,g as integer,b as integer,a as integer)
  colour as dword
  colour = (b)+(g*256)+(r*65536)+(a*16777216)
endfunction colour

`CODE BASED ON:
`   http://2dnow.zenzer.net/viewarticle.php?a=10
set display mode 1280, 1024, 32
sync on
sync rate 0
color backdrop 0
set ambient light 0


`Define the required constants for the fire
#constant MAX_CHANGES          6
#constant SECTOR_WIDTH         128
#constant SECTOR_HEIGHT        128
#constant COOLING_RATE         1
#constant NUM_COALS_PER_UPDATE 1
#constant UPDATE_RATE          20
global SPARK_HEAT = 132

#constant MEMBLOCK_ID   1
#constant IMAGE_ID      1


`Define image
dim FireData(SECTOR_WIDTH, SECTOR_HEIGHT)
for x = 0 to SECTOR_WIDTH-1
   for y = 0 to SECTOR_HEIGHT-1
      FireData(x, y) = 0
   next y
next x



`Create a memblock for it
make memblock MEMBLOCK_ID, 12 + (SECTOR_WIDTH * SECTOR_HEIGHT * 4)
write memblock dword 1, 0, SECTOR_WIDTH
write memblock dword 1, 4, SECTOR_HEIGHT
write memblock dword 1, 8, 32




`Define Flame Colors
Type FireColour
   Red
   Green
   Blue
   Alpha
   Temperature as Byte
EndType
Dim ColourChanges(MAX_CHANGES) as FireColour

ColourChanges(0).Red = 255
ColourChanges(0).Green = 255
ColourChanges(0).Blue = 255
ColourChanges(0).Alpha = 255
ColourChanges(0).Temperature = 255


ColourChanges(1).Red = 255
ColourChanges(1).Green = 255
ColourChanges(1).Blue = 0
ColourChanges(1).Alpha = 160
ColourChanges(1).Temperature = 64


ColourChanges(2).Red = 255
ColourChanges(2).Green = 128
ColourChanges(2).Blue = 0
ColourChanges(2).Alpha = 160
ColourChanges(2).Temperature = 48


ColourChanges(3).Red = 128
ColourChanges(3).Green = 64
ColourChanges(3).Blue = 64
ColourChanges(3).Alpha = 128
ColourChanges(3).Temperature = 32


ColourChanges(4).Red = 64
ColourChanges(4).Green = 32
ColourChanges(4).Blue = 0
ColourChanges(4).Alpha = 64
ColourChanges(4).Temperature = 16


ColourChanges(5).Red = 0
ColourChanges(5).Green = 0
ColourChanges(5).Blue = 0
ColourChanges(5).Alpha = 0
ColourChanges(5).Temperature = 0

`Create the fire color interpolation
currentC as FireColour
nextC as FireColour
CurrentEntry = 255
r as byte
g as byte
b as byte

Dim FireColours(255) as DWORD
for i = 0 to 4
   currentC = ColourChanges(i)
   nextC = ColourChanges(i+1)
   for j = currentC.Temperature to nextC.Temperature + 1 step -1
      interpFactor# = (currentC.Temperature - CurrentEntry) / (1.0 * (currentC.Temperature - nextC.Temperature))
      r = currentC.Red   + (nextC.Red   - currentC.Red)   * interpFactor#
      g = currentC.Green + (nextC.Green - currentC.Green) * interpFactor#
      b = currentC.Blue  + (nextC.Blue  - currentC.Blue)  * interpFactor#
      a = currentC.Alpha + (nextC.Alpha - currentC.Alpha) * interpFactor#
      FireColours(CurrentEntry) = rgba(r, g, b, a)
      dec CurrentEntry
   next j
next i




make object plain 1, 2, 1
position object 1, 0.0, 0.5, 0.0
point object    1, 0.0, 0.5, 1.0
set object transparency 1, 3
set object light 1, 0
UpdateFire()
texture object 1, 1



`Create a room
`left wall to fire
make object box 100,  3.0, 4.0, 1.0
position object 100, -2.5, 2.0, 0.0

`right wall to fire
make object box 101, 3.0, 4.0, 1.0
position object 101, 2.5, 2.0, 0.0

`top wall above fire
make object box 102, 2.0, 3.0, 1.0
position object 102, 0.0, 2.5, 0.0
`back of fire
make object box 103, 2.0, 1.0, 0.25
position object 103, 0.0, 0.5, -0.375


`make floor
make object plain 110, 8.0, 11.0
position object   110, 0.0, 0.0, 5.0
point object      110, 0.0, 1.0, 5.0


`make other walls
make object box 120, 10.0, 4.0, 1.0
position object 120, -3.5, 2.0, 5.0
point object    120,  0.0, 2.0, 5.0

make object box 121, 10.0, 4.0, 1.0
position object 121,  3.5, 2.0, 5.0
point object    121,  0.0, 2.0, 5.0






`Make a tree
#CONSTANT tX 256
#CONSTANT tY 256
make memblock 2, 12 + (tX * tY * 4)
write memblock dword 2, 0, tX
write memblock dword 2, 4, tY
write memblock dword 2, 8, 32
for x = 0 to tX-1
   for y = 0 to tY-1
      write memblock dword 2, 12 + ((x + (y*tX))*4), rgba(64,    192 + rnd(63),    64,   128 + rnd(96))
   next y
next x
make image from memblock 2, 2
delete memblock 2
make object cone 2, 1
scale object 2, 100, 200, 100
texture object 2, 2
set object transparency 2, 3
position object 2, 2, 1, 4










autocam off
CAM_D# = 5.0
CAM_A# = 0.0
CAM_Cx# = object size z(110) * 0.5
CAM_Cz# = object size y(110) * 0.5
gosub POSITION_CAMERA






set point light 0, 0, 1.0, 1.0
global LIGHT_COLOR as DWORD

`Start the firedrawing!!
frameTime# = 1.0
startTime = timer()
FLAME_UPDATE# = 0
do
   frameTime# = (frameTime# * 0.8) + ((timer() - startTime) * 0.2)
   startTime = timer()

   CAM_A# = sin(timer() * 0.0225) * 20.0
   gosub POSITION_CAMERA


   text 0, 0, "FPS: " + str$(screen fps())
   text 0, 10, "Flame heat: " + str$(SPARK_HEAT)

   y = SECTOR_HEIGHT - ((SPARK_HEAT * SECTOR_HEIGHT) / 756)
   text 0, 20, "Y: " + str$(y)
   LIGHT_COLOR = FireColours(FireData(SECTOR_WIDTH / 2, y))
   color light 0, LIGHT_COLOR




   z = mousemovez()
   if SPARK_HEAT < 250 AND z > 0 then inc SPARK_HEAT, 5
   if SPARK_HEAT > 5   AND z < 0 then dec SPARK_HEAT, 5

   if FLAME_UPDATE# >= UPDATE_RATE
      UpdateFire()
      FLAME_UPDATE# = 0
   else
      inc FLAME_UPDATE#, frameTime#
   endif
   sync
loop



POSITION_CAMERA:
   position camera CAM_Cx# + (sin(CAM_A#) * CAM_D#),      2,      CAM_Cz# + (cos(CAM_A#) * CAM_D#)
   point camera CAM_Cx#, 0, CAM_Cz#
return











function UpdateFire()
   Dim FireDataCopy(SECTOR_WIDTH, SECTOR_HEIGHT)
`   clr as byte

   for x = 0 to SECTOR_WIDTH - 2
      for y = 0 to SECTOR_HEIGHT - 2
         clr = FireData(x, y)
         write memblock dword 1, 12 + ((y * SECTOR_WIDTH) + x) * 4, FireColours(clr)
         FireDataCopy(x, y) = clr
      next y
   next x
   make image from memblock 1, 1


   `Scroll the flame
   for x = 0 to SECTOR_WIDTH - 1
      for y = 0 to SECTOR_HEIGHT - 2
         FireDataCopy(x, y) = FireDataCopy(x, y + 1)
      next y
   next x


   `Create sparks
   for y = SECTOR_HEIGHT - 4 to SECTOR_HEIGHT -2
      for x = 1 to SECTOR_WIDTH - 2
         FireDataCopy(x, y) = rand() * SPARK_HEAT
      next x
   next y


   `Create coals
   y = SECTOR_HEIGHT -2
   For i = 0 to NUM_COALS_PER_UPDATE -1
      x = rand() * (SECTOR_WIDTH - 2)

      FireDataCopy(x - 1, y - 1) = 255
      FireDataCopy(x - 1, y    ) = 255
      FireDataCopy(x - 1, y + 1) = 255
      FireDataCopy(x    , y - 1) = 255
      FireDataCopy(x    , y    ) = 255
      FireDataCopy(x    , y + 1) = 255
      FireDataCopy(x + 1, y - 1) = 255
      FireDataCopy(x + 1, y    ) = 255
      FireDataCopy(x + 1, y + 1) = 255
   next i



   `Blur the image
   for x = 1 to SECTOR_WIDTH - 1
      for y = 1 to SECTOR_HEIGHT -1
         clr = (_
                  FireDataCopy(x - 1, y    ) +_
                  FireDataCopy(x + 1, y    ) +_
                  FireDataCopy(x    , y - 1) +_
                  FireDataCopy(x    , y + 1) +_
                  FireDataCopy(x - 1, y - 1) +_
                  FireDataCopy(x - 1, y + 1) +_
                  FireDataCopy(x + 1, y - 1) +_
                  FireDataCopy(x + 1, y + 1)  _
                ) / 8.0

         if clr >= COOLING_RATE then dec clr, COOLING_RATE

         FireData(x, y) = clr
      next y
   next x
endfunction


function rand()
   rndVal# = rnd(1000000) / 1000000.0
endfunction rndVal#

function rgba(r as integer,g as integer,b as integer,a as integer)
  colour as dword
  colour = (b)+(g*256)+(r*65536)+(a*16777216)
endfunction colour

Ric (No really Christmasssy or a screensaver, but a damn good bit of coding!)

Tinkergirl (Christmassy - but not a screensaver) 

Nicholas Thompson (Both a screensaver and a bit of Christmas)