Sorry your browser is not supported!

set text font "Wingdings"

perform checklist for fonts

q = checklist quantity()
for a = 1 to q
    print checklist string$(a)
next a

suspend for key
end

rem Load original present image
load image "Gift01.jpg",1,1

rem Create a memblock from it
make memblock from image 1,1

rem Detel the image
delete image 1

rem Loop through all image co-ordinates
for x=0 to 256
   for y=0 to 192

      rem Find the color at this point
      c=ReadFromImageMemblock(1,256,192,x,y)

      rem Check that it is red
      if rgbg(c)<72
         if rgbb(c)<64

            rem Avoid holly berries
            if x>79
               if x<90
                  if y>101
                     if y<115
                        DONTDOIT=1
                     endif
                  endif
               endif
            endif

            rem Make it green
            if DONTDOIT=0
               r=0
               g=rgbr(c)
               b=0
               WriteToImageMemblock(1,256,192,x,y,r,g,b)
            else
               DONTDOIT=0
            endif

         endif
      endif

   next y
next x

rem Convert back to an image
make image from memblock 1,1

rem Delete the memblock
delete memblock 1

rem Save the image
save image "Gift02.jpg",1

rem Delete the image
delete image 1

rem Exit
end

rem ============================================================================================
rem === WriteToImageMemblock()                                                               ===
rem ============================================================================================
function WriteToImageMemblock(MemblockID,ImageWidth,ImageHeight,X,Y,RedValue,GreenValue,BlueValue)

rem Find relative position in memblock
MemblockPosition=X+(Y*ImageWidth)

rem Check the position is in the memblock range
if MemblockPosition>=0
   if MemblockPosition<(ImageWidth*ImageHeight)

      rem Adjust the memblock accordingly
      write memblock dword MemblockID,12+(MemblockPosition*4),rgb(RedValue,GreenValue,BlueValue)

   endif
endif

rem End the function
endfunction

rem ============================================================================================
rem === ReadFromImageMemblock()                                                              ===
rem ============================================================================================
function ReadFromImageMemblock(MemblockID,ImageWidth,ImageHeight,X,Y)

rem Find relative position in memblock
MemblockPosition=X+(Y*ImageWidth)

rem Check the position is in the memblock range
if MemblockPosition>=0
   if MemblockPosition<(ImageWidth*ImageHeight)

      rem Adjust the memblock accordingly
      ColorValue=memblock dword(MemblockID,12+(MemblockPosition*4))

   endif
endif

rem End the function
endfunction ColorValue

REM Project: Santa's sorting suite
REM Created: 16/12/2007 17:05:28
REM
REM ***** Main Source File *****

autocam off : sync off : hide mouse

set text size 14
set text font "Arial"
`remstart
text 20,10,"Welcome to Santa's Sorting Suite!"
wait 2000
text 20,40,"Around this time of year, everything gets hectic in Saint Nick's workshop, so why not lend him a hand?"
wait 5000
text 20,70,"Use Santa's categorizing machine to help organize his presents, so that he doesn't get into a mess!"
wait 5000
text 20,80,"But the machine is rather outdated, so there are some little problems with it..."
wait 5000
text 20,110,"And make sure you don't lose any presents in the machine, or organize the presents wrongly..."
text 20,120,"'cause you don't want to see Santa when he is angry."
wait 6000
text 20,150,"Good luck!"
wait 2000
`remend
text 20,200,"Any key to continue >>>"

wait key

sync on

backdrop on
color backdrop rgb(0,0,0)

set ambient light 65

dim active(100)
dim presentpos(100)
makelevel(1)
movement=0

position camera 200,220,-405
point camera 200,220,0

do

gosub cameracontrol
gosub physics

fastsync
loop

cameracontrol:
for x=1 to 100
if active(x)=1
   if presentpos(x)<>object position x(x)+object position y(x) then return
endif
next
   if leftkey()=1
      camz1=camera angle z()
      camz2=camera angle z()-90
      while camz1<>camz2
         zrotate camera camera angle z()-1
         if camz2=camera angle z() then exit
         fastsync
      endwhile
   endif
   if rightkey()=1
      camz1=camera angle z()
      camz2=camera angle z()+90
      while camz1<>camz2
         zrotate camera camera angle z()+1
         if camz2=camera angle z() then exit
         fastsync
      endwhile
   endif

   return

physics:
for y=101 to 200
   if object exist(y)=1
      if camera angle z()=0 or camera angle z()=360 then position object y,object position x(y-100),object position y(y-100)-15,object position z(y-100)
      if camera angle z()=90 then position object y,object position x(y-100)+15,object position y(y-100),object position z(y-100)
      if camera angle z()=180 then position object y,object position x(y-100),object position y(y-100)+15,object position z(y-100)
      if camera angle z()=270 then position object y,object position x(y-100)-15,object position y(y-100),object position z(y-100)
   endif
next y
for x=1 to 100
   if active(x)=1
      presentpos(x)=object position x(x)+object position y(x)
      if (camera angle z()=0 or camera angle z()=360) and object collision(x+100,0)<1
         position object x,object position x(x),object position y(x)-1,object position z(x)
      endif
      if camera angle z()=90 and object collision(x+100,0)<1
         position object x,object position x(x)+1,object position y(x),object position z(x)
      endif
      if camera angle z()=180 and object collision(x+100,0)<1
         position object x,object position x(x),object position y(x)+1,object position z(x)
      endif
      if camera angle z()=270 and object collision(x+100,0)<1
         position object x,object position x(x)-1,object position y(x),object position z(x)
      endif
   endif
next x
if camera angle z()=450 then zrotate camera 90
if camera angle z()=-90 then zrotate camera 270
return

function makelevel(level)
obj=1
for y= 10 to 1 step -1
   for x=1 to 10
      read level
      if level=1
         make object cube obj,30
         position object obj,x*30,y*30,0
         color object obj,rgb(255,255,255)
      endif
      if level=2
         make object cube obj,30
         position object obj,x*30,y*30,0
         ghost object on obj
         color object obj,rgb(0,255,0)
      endif
      if level=3
         make object cube obj,30
         position object obj,x*30,y*30,0
         ghost object on obj
         color object obj,rgb(255,255,255)
      endif
      if level=4
         load object "gift01.x",obj
         scale object obj,25,25,25
         position object obj,x*30,y*30,0
         rndnr=rnd(3)
         yrotate object obj,rndnr*90
         active(obj)=1
         make object cube obj+100,5
         hide object obj+100
      endif
      inc obj
   next y
next x
endfunction

level:
data 1,1,1,1,3,1,1,2,1,1
data 1,0,0,0,4,0,0,0,0,1
data 1,0,1,1,1,1,1,0,1,1
data 1,0,1,4,0,0,0,0,4,1
data 1,0,1,0,0,0,0,0,0,1
data 1,0,1,0,0,0,0,0,0,1
data 1,0,1,0,0,0,0,0,0,1
data 1,0,1,1,1,0,0,0,0,1
data 1,0,0,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1,1

` Screen settings
sync on : sync rate 60
backdrop on : color backdrop rgb(0, 32, 128)
autocam off
set image colorkey 255, 0, 255


` Make the player sleigh
player = BuildSleigh()
position object player, 0, 0, 0
set object transparency player, 4

` Position the camera
position camera 0, 0, -50
point camera 0, 0, 0


` Main loop
do
   set cursor 0, 0
   print screen fps()
   
   yrotate object player, wrapvalue(object angle y(player) + 0.5)

   sync
loop


` ***********************
` *** Sleigh Creation ***
` ***********************

` Build the player sleigh object
function BuildSleigh()

   ` Find object index that sleigh will use
   obj = FreeObject()
   
   ` ** Sleigh Bottom (Root) **
   ` Make floor
   make object plain obj, 30, 20, 1
   rotate object obj, 270, 0, 0
   fix object pivot obj
   ` Push floor down
   offset limb obj, sleighBottom, 0, 0, -10
   
   ` ** Prepare to add limbs **
   temp = FreeObject()
   mesh = FreeMesh()
   
   ` ** Sleigh Left Side **
   ` Make side
   make object plain temp, 30, 20, 1
   rotate object temp, 270, 180, 0
   fix object pivot temp
   ` Push to the left
   offset limb temp, 0, 0, 8.9, -10
   ` Add limb
   make mesh from object mesh, temp
   add limb obj, sleighSideL, mesh
   link limb obj, sleighBottom, sleighSideL
   ` Cleanup
   delete object temp
   delete mesh mesh
   
   ` ** Sleigh Right Side **
   ` Make side
   make object plain temp, 30, 20, 1
   rotate object temp, 90, 0, 0
   fix object pivot temp
   ` Push to the right
   offset limb temp, 0, 0, 8.9, -10
   ` Add limb
   make mesh from object mesh, temp
   add limb obj, sleighSideR, mesh
   link limb obj, sleighBottom, sleighSideR
   ` Cleanup
   delete object temp
   delete mesh mesh
   
   ` ** Sleigh Back **
   ` Make back
   make object plain temp, 20, 20
   rotate object temp, 90, 0, 90
   fix object pivot temp
   ` Push to the back
   offset limb temp, 0, 0, 8.9, -14.9
   ` Add limb
   make mesh from object mesh, temp
   add limb obj, sleighBack, mesh
   link limb obj, sleighBottom, sleighBack
   ` Cleanup
   delete object temp
   delete mesh mesh
   
   ` ** Sleigh Front **
   ` Make front
   make object plain temp, 20, 20
   rotate object temp, 90, 0, 270
   fix object pivot temp
   ` Push to the front
   `offset limb temp, 0, 0, 0, -14.9
   offset limb temp, 0, 0, 8.9, -14.9
   ` Add limb
   make mesh from object mesh, temp
   add limb obj, sleighFront, mesh
   link limb obj, sleighBottom, sleighFront
   ` Cleanup
   delete object temp
   delete mesh mesh
   
   ` ** Left Blade **
   ` Make blade
   make object plain temp, 50, 5, 1
   rotate object temp, 270, 180, 0
   fix object pivot temp
   ` Push to the left
   offset limb temp, 0, 5, -2.5, -10.1
   ` Add limb
   make mesh from object mesh, temp
   add limb obj, sleighBladeL, mesh
   link limb obj, sleighBottom, sleighBladeL
   ` Cleanup
   delete object temp
   delete mesh mesh
   
   ` ** Right Blade **
   ` Make blade
   make object plain temp, 50, 5, 1
   rotate object temp, 90, 0, 0
   fix object pivot temp
   ` Push to the right
   offset limb temp, 0, -5, -2.5, -10.1
   ` Add limb
   make mesh from object mesh, temp
   add limb obj, sleighBladeR, mesh
   link limb obj, sleighBottom, sleighBladeR
   ` Cleanup
   delete object temp
   delete mesh mesh
   
   ` ** Toy Sack **
   ` Make sack
   make object sphere temp, 20, 10, 10
   scale object temp, 70, 95, 120
   rotate object temp, 350, 345, 0
   ` Push to the back and into the sleigh
   offset limb temp, 0, -5, -2, 10
   ` Add limb
   make mesh from object mesh, temp
   add limb obj, sleighSack, mesh
   link limb obj, sleighBottom, sleighSack
   ` Cleanup
   delete object temp
   delete mesh mesh
   
   ` ** Toy Sack Top **
   ` Make cone
   make object cone temp, 10
   scale object temp, 50, 100, 50
   rotate object temp, 250, 320, 0
   ` Push to the top of the sack
   offset limb temp, 0, 10, -23, -7
   ` Add limb
   make mesh from object mesh, temp
   add limb obj, sleighSackTop, mesh
   link limb obj, sleighSack, sleighSackTop
   ` Cleanup
   delete object temp
   delete mesh mesh
   
   ` ** Textures **
   gosub MakeSleighTextures
   texture limb obj, sleighBottom, sleighFloorImg
   texture limb obj, sleighSideL, sleighLeftImg
   texture limb obj, sleighSideR, sleighRightImg
   texture limb obj, sleighBack, sleighBackImg
   texture limb obj, sleighFront, sleighFrontImg
   texture limb obj, sleighBladeL, sleighBladeLImg
   texture limb obj, sleighBladeR, sleighBladeRImg
   texture limb obj, sleighSack, sleighSackImg
   texture limb obj, sleighSackTop, sleighSackImg
   
   set object cull obj, 0
endfunction obj

` Generate the textures to use for player sleigh
MakeSleighTextures:
   ` ** Floor texture **
   create bitmap 1, 2, 2
   ` Red background
   ink rgb(200, 0, 0), 0
   box 0, 0, 2, 2
   ` Store image
   global sleighFloorImg : sleighFloorImg = FreeImage()
   get image sleighFloorImg, 0, 0, 2, 2
   delete bitmap 1

   ` ** Right texture **
   create bitmap 1, 150, 100
   ` Red background
   ink rgb(200, 0, 0), 0
   box 0, 0, 150, 100
   ` Use a sine wave to add detail
   for x = 0 to 150
      y = (sin((x*1.7)-80)*40)+40
      ` Add a white stripe along the wave
      ink rgb(255, 255, 255), 0
      line x, y, x, y+10
      line x, y+13, x, y+14
      ` Fill in the area above the stripe with pink (transparent)
      ink rgb(255, 0, 255), 0
      line x, 0, x, y
      ` Make the bottom edge of the sleigh rounded
      y = (sin(x*1.2)*6)+95
      line x, y, x, 100
   next x
   ` Store image
   global sleighRightImg : sleighRightImg = FreeImage()
   get image sleighRightImg, 0, 0, 150, 100
   
   ` ** Left texture **
   create bitmap 2, 150, 100
   ` (Mirror image of right side texture)
   copy bitmap 1, 2
   mirror bitmap 2
   set current bitmap 2
   ` Store image
   global sleighLeftImg : sleighLeftImg = FreeImage()
   get image sleighLeftImg, 0, 0, 150, 100
   delete bitmap 2
   delete bitmap 1
   
   ` ** Back texture **
   create bitmap 1, 100, 100
   ` Red background
   ink rgb(200, 0, 0), 0
   box 0, 0, 100, 100
   ` Add a white stripe along the top
   ink rgb(255, 255, 255), 0
   box 0, 0, 100, 10
   box 0, 13, 100, 15
   ` Make the bottom edge pink (transparent)
   ink rgb(255, 0, 255), 0
   box 0, 95, 100, 100
   ` Store image
   global sleighBackImg : sleighBackImg = FreeImage()
   get image sleighBackImg, 0, 0, 100, 100
   delete bitmap 1
   
   ` ** Front texture **
   create bitmap 1, 100, 100
   ` Red background
   ink rgb(200, 0, 0), 0
   box 0, 0, 100, 100
   ` Add a white stripe along the middle
   ink rgb(255, 255, 255), 0
   box 0, 45, 100, 55
   box 0, 57, 100, 59
   ` Make the top half pink (transparent)
   ink rgb(255, 0, 255), 0
   box 0, 0, 100, 45
   ` Make the bottom edge transparent
   box 0, 95, 100, 100
   ` Store image
   global sleighFrontImg : sleighFrontImg = FreeImage()
   get image sleighFrontImg, 0, 0, 100, 100
   delete bitmap 1
   
   ` ** Left blade texture **
   create bitmap 1, 250, 25
   ` Pink (transparent) background
   ink rgb(255, 0, 255), 0
   box 0, 0, 250, 25
   ` Add track along the bottom
   ink rgb(160, 160, 160), 0
   box 12, 20, 212, 25
   ` Add front curve
   for a = 90 to 270
      x = (cos(a)*10)+12 : y = (sin(a)*10)+12
      box x, y, x+5, y+5
   next a
   ` Add back curve
   for a = -90 to 90
      x = (cos(a)*10)+205 : y = (sin(a)*10)+12
      box x, y, x+5, y+5
   next a
   ` Add vertical bars along the track
   for i = 1 to 5
      box i*30, 0, (i*30)+5, 25
   next i
   ` Store image
   global sleighBladeLImg : sleighBladeLImg = FreeImage()
   get image sleighBladeLImg, 0, 0, 250, 25
   
   ` ** Right blade texture **
   create bitmap 2, 250, 25
   ` (Mirror image of left blade texture)
   copy bitmap 1, 2
   mirror bitmap 2
   set current bitmap 2
   ` Store image
   global sleighBladeRImg : sleighBladeRImg = FreeImage()
   get image sleighBladeRImg, 0, 0, 250, 25
   delete bitmap 2
   delete bitmap 1
   
   ` ** Sack texture **
   create bitmap 1, 2, 2
   ` Gray-green background
   ink rgb(80, 100, 80), 0
   box 0, 0, 2, 2
   ` Store image
   global sleighSackImg : sleighSackImg = FreeImage()
   get image sleighSackImg, 0, 0, 2, 2
   delete bitmap 1
return



` ***********************
` *** Misc. functions ***
` ***********************

` Find a free image index
function FreeImage()
   repeat
      inc n
   until image exist(n) = 0
endfunction n

` Find a free object index
function FreeObject()
   repeat
      inc n
   until object exist(n) = 0
endfunction n

` Find a free mesh index
function FreeMesh()
   repeat
      inc n
   until mesh exist(n) = 0
endfunction n


` *****************
` *** Constants ***
` *****************

` Sleigh object limb numbers
#constant sleighFloor      0
#constant sleighSideL      1
#constant sleighSideR      2
#constant sleighBack       3
#constant sleighFront      4
#constant sleighBladeL     5
#constant sleighBladeR     6
#constant sleighSack       7
#constant sleighSackTop    8

set text font "Wingdings",1

`Snowman (Start Coding: 20.12.2007 | 12:24 Uhr)
set display mode 1280,1024,32
color backdrop 0

`Variables
global vx as float   `\
global vy as float   ` > Temporary Coordinate Storing
global vz as float   `/
global ang as float

`Vector for Distance
null=make vector2(1)

`-------------------------------------------------------------------------------------------------->
`                                                                                                Hat
`Hat Specific Variables
innerrad     as float = 40.
outerrad     as float = 50.
billrad      as float = 120.
billirad     as float = 0.
crumble      as float = 1.
height       as float = 120.
capheight    as float = 110.
sideheight   as float = 10.
billheight   as float = 0.
billiheight  as float = 8.

make object sphere 1,100,36,50
`set object wireframe 1,1
`set object light 1,0

lock vertexdata for limb 1,0
vertind=0
for i=0 to 36
   for j=0 to 50
   
      `Calculate Angle to the Center
      ang=(360./51.)*j
      
      `Find out Vertex Position
      vx=get vertexdata position x(vertind)
      vy=get vertexdata position y(vertind)
      vz=get vertexdata position z(vertind)

      `"Sculpt" the Model
      if i=0              `Highest Point
         vx=0
         vy=height
         vz=0
      endif
         
      if i=>1 and i<=5      `Cap
         calc_spline(0,height,innerrad/2,height,innerrad,capheight+((height-capheight)/2),innerrad,capheight,i,6)
         vx=sin(ang)*s_x+rfac()*crumble
         vy=s_y
         vz=cos(ang)*s_x+rfac()*crumble
      endif

      if i=>6 and i<=20     `Side
         calc_spline(innerrad,capheight,innerrad+(outerrad-innerrad)/2,capheight-(capheight-sideheight)/4,outerrad,sideheight+(capheight-sideheight)/2,outerrad,sideheight,i-6,15)
         vx=sin(ang)*s_x+rfac()*crumble
         vy=s_y
         vz=cos(ang)*s_x+rfac()*crumble
      endif
      
      if i=>21 and i<= 28   `Bill (Top Side)
         calc_spline(outerrad,sideheight,outerrad+(billrad-outerrad)/2,sideheight,billrad,billheight-(billheight-sideheight)/4,billrad,billheight,i-21,8)
         vx=sin(ang)*s_x+rfac()*crumble
         vy=s_y
         vz=cos(ang)*s_x+rfac()*crumble
      endif
      
      if i=>29 and i<=36    `Bill (Bottom Side)
         calc_spline(billrad,billheight,billrad,billheight-(billheight-sideheight)/4,billirad+(billrad-billirad)/2,billiheight,billirad,billiheight,i-29,7)
         vx=sin(ang)*s_x+rfac()*crumble
         vy=s_y
         vz=cos(ang)*s_x+rfac()*crumble
      endif
      
      if i=36                `Last Loop
         vx=0
         vy=billiheight
         vz=0
      endif

      `Position Vertex
      set vertexdata position vertind,vx,vy,vz
      
      `Skip to next Vertex
      inc vertind
      
   next j
next i

`Create some Dents
for i=0 to 20
   create_dent(7+rnd(12),rnd(50),rnd(20)+5,rfac()*4+1)
next i

`Create big Dent at the Beginning
`of the red Part.
create_dent(17,0,50,6)

`Fray out the Bill
levels as float = 7.
for j=0 to 50
   if rnd(3)=0
      dep=rnd(30)+20
      ind=rnd(50)
      length=rnd(1)+1
      strength as float
      for cur=int(28-levels) to int(28+levels)
         strength=(levels-abs(28-cur))/levels
         create_dent(cur,ind,length,dep*strength)
      next cur

   endif
next j

`Prepare Texture Creation
tsx=1024
tsy=1024

`Create Memblock
base = make_image_memblock(1,tsx,tsy)

`Create Basic Color
type _col
   pos as integer
   r as float
   g as float
   b as float
endtype

cc as _col
nextc as _col
cstep as _col

restore

read cc.pos
read cc.r
read cc.g
read cc.b

read nextc.pos
read nextc.r
read nextc.g
read nextc.b

cstep.r = (nextc.r-cc.r)/(nextc.pos-cc.pos)
cstep.g = (nextc.g-cc.g)/(nextc.pos-cc.pos)
cstep.b = (nextc.b-cc.b)/(nextc.pos-cc.pos)

for sy=0 to 1023

   `Make Line
   for x=0 to 1023
      mdot(base,x,sy,int(cc.r),int(cc.g),int(cc.b),255)
   next x
   
   `Alter Current Color
   inc cc.r,cstep.r
   inc cc.g,cstep.g
   inc cc.b,cstep.b
   
   `Skip to next Color if necessary
   if nextc.pos=sy
      cc=nextc
      
      read nextc.pos
      read nextc.r
      read nextc.g
      read nextc.b

      cstep.r = (nextc.r-cc.r)/(nextc.pos-cc.pos)
      cstep.g = (nextc.g-cc.g)/(nextc.pos-cc.pos)
      cstep.b = (nextc.b-cc.b)/(nextc.pos-cc.pos)

   endif
next sy

`End of Vertex Editing
unlock vertexdata
calculate object bounds 1
set object normals 1

`Object Options
make image from memblock 1,base
texture object 1,1

set object specular 1,rgb(200,200,200)
set object emissive 1,rgb(10,10,10)
set object ambience 1,rgb(10,10,10)
set object diffuse 1,rgb(150,150,160)

`-------------------------------------------------------------------------------------------------->
`                                                                                          Main Loop
sync on : sync rate 100
while returnkey()=0

rotate camera camera angle x()+mousemovey(),camera angle y()+mousemovex(),0
move camera ((mouseclick()=1)-(mouseclick()=2))

if controlkey()=1 then paste image 1,0,0

sync
endwhile
end
            
`-------------------------------------------------------------------------------------------------->
`                                                                                      Random Factor
function rfac()
`Gives out a Random Factor between
`0 and 1, could be replaced by IanM's
`random() Function.

fac as float
fac=rnd(1000)/1000.

endfunction fac

`-------------------------------------------------------------------------------------------------->
`                                                                                        Create Dent
function create_dent(yloop,xfrom,xlength,depth as float)
`This Function will create a Dent on the specified
`Y Loop and with a specified Length & Depth. Works
`on locked Vertexdata, but is pretty much optimized
`for the Snowman so it's quite useless for other
`Stuff.

`Local Variables
local rad      as float
local curdepth as float

for j=xfrom to xfrom+xlength
   `Wrap Index if he's too Low or High
   cx=wrap_val(j,0,50)
   
   `Calculate Angle to the Center
   ang=360./50.*cx
   
   `Find out Vertex Position
   vind=(yloop+1)*51+cx
   vx=get vertexdata position x(vind)
   vy=get vertexdata position y(vind)
   vz=get vertexdata position z(vind)

   `Calculate Distance to Center
   rad=distance(vx,vz,0,0)

   `Find out Dent Depth
   calc_spline(0,0,0,depth,xlength,depth,xlength,0,j-xfrom,xlength)
   curdepth=s_y
   
   `Calculate new Position
   vx=sin(ang)*(rad-curdepth)
   vy=vy
   vz=cos(ang)*(rad-curdepth)

   `Position Vertex
   set vertexdata position vind,vx,vy,vz
next j

endfunction

`-------------------------------------------------------------------------------------------------->
`                                                                                           Distance
function distance(x1 as float,y1 as float,x2 as float,y2 as float)

set vector2 1,x1-x2,y1-y2
dist as float
dist = length vector2(1)

endfunction dist
   
`-------------------------------------------------------------------------------------------------->
`                                                                                               Wrap
function wrap_val(cur,mini,maxi)
`Will wrap a Value, similar to "wrapvalue()" Function.
`Can be replaced with IanM's "wrap()" Function.

if cur<mini then cur=maxi+cur+1
if cur>maxi then cur=mini+cur-maxi-1

endfunction cur

`-------------------------------------------------------------------------------------------------->
`                                                                                             Spline
function calc_spline(s_1x,s_1y,s_2x,s_2y,s_3x,s_3y,s_4x,s_4y,cstep,mstep as float)

s_a=   s_4x - 3*s_3x + 3*s_2x - s_1x
s_b= 3*s_3x - 6*s_2x + 3*s_1x
s_c= 3*s_2x - 3*s_1x
s_d=   s_1x

s_e=   s_4y - 3*s_3y + 3*s_2y - s_1y
s_f= 3*s_3y - 6*s_2y + 3*s_1y
s_g= 3*s_2y - 3*s_1y
s_h=   s_1y

       s_t  as float
global s_x  as float
global s_y  as float

s_t=1./mstep*cstep

s_x=s_a*s_t^3+s_b*s_t^2+s_c*s_t+s_d
s_y=s_e*s_t^3+s_f*s_t^2+s_g*s_t+s_h

endfunction

`-------------------------------------------------------------------------------------------------->
`                                                                                Make Image Memblock
function make_image_memblock(mem,dimx,dimy)
`This Function will create a Memblock which suits
`all needs to use it as an Image.

`Create a new Memblock
make memblock mem,12+dimx*dimy*4

`Write Data
write memblock dword mem,0,dimx
write memblock dword mem,4,dimy
write memblock byte  mem,8,32

endfunction mem

`-------------------------------------------------------------------------------------------------->
`                                                                                           Make Dot
function mdot(mem,posx,posy,red,green,blue,alpha)
`This Function will make a Dot at the specified Position.

`Find out Image Dimensions
dimx=memblock dword(mem,0)
base=12+posx*4+posy*dimx*4

`Write Data to Memblock
write memblock byte mem,base  ,blue
write memblock byte mem,base+1,green
write memblock byte mem,base+2,red
write memblock byte mem,base+3,alpha

endfunction

`-------------------------------------------------------------------------------------------------->
`                                                                                               Data
data    0, 80, 80, 90
data   50,110,110,115
data  100,150,150,155
data  200,150,150,150
data  500,100,100,105
data  512, 95, 53, 57
data  590,106, 80, 81
data  595,130,130,130
data  800,100,100,105
data 1023,150,150,160

` Green Gandalf's basic music note maker with keyboard

`  uses code snippets from Ric's "create sound no media" thread:

`  http://forum.thegamecreators.com/?m=forum_view&t=49008&b=6

` Created 4 March 2007, edited 20 December 2007

set display mode 800, 600, 32

autocam off
position camera 0, 0, -600
point camera 0, 0, 0

position light 0, 0, 50, -500
point light 0, 0, 0, 0

` magic numbers
a# = 0.057762265  ` = (ln 2)/12
b# = 4.1588831    ` = (ln 256) - 24*(ln 2)/12

color backdrop rgb(5,5,5)

type note
  name as string
  sound
endtype

dim rawNotes(11,5,5) as note
` this array points to basic notes stored as DBP sounds
` the first index represents one of the 12 notes
`   C, C#, D, D#, E, F, F#, G, G#, A, A#, B
` the second represents the octave, e.g.
`   2 represents the octave starting with middle C (256 Hz in this program)
` the third represents the duration in seconds: (not fully implemented yet)
`   0.25, 0.5, 1.0, 2.0, 4.0, 8.0
`
` the notes are created as they are needed - a value of zero in this
` array indicates the note has not been created yet, otherwise the value
` represents the stored sound number

` initialise rawNotes array
for note=0 to 11
  read s$
  data "C", "C#", "D", "D#", "E", "F", "F#", "G", "G#", "A", "A#", "B"
  for octave=0 to 5
    for duration=0 to 5
      rawNotes(note,octave,duration).name = s$+str$(octave)
      rawNotes(note,octave,duration).sound = 0
    next duration
  next octave
next note

dim whiteNotes(72)
` a value of 1 indicates a white note on a standard piano style keyboard
`            2 indicates a black note
` initialise whiteNotes array - this could be shortened (exercise for the reader)
data 1,2,1,2,1,1,2,1,2,1,2,1
data 1,2,1,2,1,1,2,1,2,1,2,1
data 1,2,1,2,1,1,2,1,2,1,2,1
data 1,2,1,2,1,1,2,1,2,1,2,1
data 1,2,1,2,1,1,2,1,2,1,2,1
data 1,2,1,2,1,1,2,1,2,1,2,1
for w=1 to 72
  read v
  whiteNotes(w)=v
next w

` make keyboard
k=1
for octave=0 to 5
  xpos = -86
  for note=0 to 11
    make object plain k, 30/whiteNotes(k), 80/whiteNotes(k)
    colour = 255 * (2 - whiteNotes(k))
    color object k, rgb(colour,colour*(k<>25),colour*(k<>25))
    ` picks out middle C in red
    position object k, xpos, octave*90 - 225, 1 - whiteNotes(k)
    inc xpos, 17 + (note=4)*17
    inc k
  next note
next octave

` make wave file header
dim wavHeader(39) as byte
for h=0 to 39
  read v
  wavHeader(h) = v
next h
data 82, 73, 70, 70,    0,   0,   0,  0 ` i.e. RIFF????# ????=file size in bytes - 8 to complete later
data 87, 65, 86, 69,  102, 109, 116, 32 `      WAVEfmt #
data 16,  0,  0,  0,    1,   0,   1,  0 `      ????**--# ????=subchunk size=16,**=audioformat,--=nChannels
data 34, 86,  0,  0,  68,  172,   0,  0 `      ????****# ????=samples per sec,****=bytes per sec
data  2,  0, 16,  0,  100,  97, 116, 97 `      ??**data# ??=bytes per block,**=bits per sample

` make song array
dim song(1000)

soundNum=1
previousSound=1
songCounter=1

repeat
  noteNum = -1
  text 20, 20, "FPS = "+str$(screen fps())
  if mouseclick() then noteNum=pick object(mousex(), mousey(), 1, 72) - 1
  if noteNum>-1
    frequency# = exp(noteNum * a# + b#) ` probably not standard frequencies
    text 20, 50, "noteNum "+str$(noteNum)
    note = noteNum MOD 12
    octave = (noteNum + 0.5)/12.0
    duration = 0: duration# = 2^duration/4.0
    name$ = rawNotes(note, octave, duration).name
    text 20, 70, "name "+name$
    text 20, 90, "octave = "+str$(octave)
    text 20, 110, "duration = "+str$(duration#)+" secs"
    text 20, 130, "Sound "+str$(rawNotes(note, octave, duration).sound)
    text 20, 150, "Frequency = "+str$(frequency#,2)
    if rawNotes(note, octave, duration).sound = 0
      makeRawNote(soundNum, name$, duration#, frequency#)
      rawNotes(note, octave, duration).sound = soundNum
      inc soundNum
    endif
    soundNow = rawNotes(note, octave, duration).sound
    if sound playing(previousSound) = 0
      play sound soundNow
      previousSound = soundNow
      song(songCounter)=soundNow
      inc songCounter
    endif
  endif
  if inkey$()="s" and songCounter>1

    songPlaying=1
    nextTime=timer()+300
    play sound song(songPlaying)
    inc songPlaying
    while songPlaying<songCounter
      nowTime=timer()
      if nowTime>nextTime
        play sound song(songPlaying)
        inc songPlaying
        nextTime=nowTime+300
      endif
    endwhile
  endif

until spacekey()

end

function makeRawNote(soundNum, name$, duration#, frequency#)
  outWord as word
  dword1 as dword: dword2 as dword: dword3 as dword: dword4 as dword
  dword5 as dword: dword6 as dword: dword7 as dword

  samples = int(duration#*22050+0.5)
`  balance# = 32767.0*64.0/frequency# ` quick fix to make low notes relatively more audible
  balance# = 32767.0

  if memblock exist(1) then delete memblock 1
  make memblock 1, samples*2+28

  ` write 28 memblock header bytes
  dword1=1      ` gg query: is this the sound format   ?
  dword2=1      ` gg query: is this the number of channels   ?
  dword3=22050  ` gg query: seems to be the number of samples per second   ?
  dword4=44100  ` gg query: the number of bytes per second   ?
  dword5=2      ` gg query: bytes per block, i.e. sample   ?
  dword6=16     ` gg query: bits per sample   ?
  dword7=0      ` gg query: not used          ?

  position=0
  write memblock dword 1, position, dword1 : inc position,4
  write memblock dword 1, position, dword2 : inc position,4
  write memblock dword 1, position, dword3 : inc position,4
  write memblock dword 1, position, dword4 : inc position,4
  write memblock dword 1, position, dword5 : inc position,4
  write memblock dword 1, position, dword6 : inc position,4
  write memblock dword 1, position, dword7 : inc position,4

  ` write sound info
  fadeRange# = 1000.0
  for x=1 to samples
    if x<fadeRange#
      fade# = (x - 1.0)/fadeRange#
    else
      if x>samples-fadeRange#
        fade# = (samples - x)/fadeRange#
      else
        fade# = 1.0
      endif
    endif
    outInteger=(sin((x/61.25) * frequency#) * balance# * fade#)
    if outInteger < -32767 then outInteger = -32767
    if outInteger >  32767 then outInteger =  32767
    outWord = outInteger
    write memblock word 1, position, outWord : inc position,2
  next x

  make sound from memblock soundNum, 1

  ` now save the sound
  fileName$=name$+"D"+str$(duration#*4,0)+".wav"
  if file exist(fileName$)=1 then delete file fileName$
  open to write 1,fileName$
  chunk=samples*2  `sample size in bytes
  chunk2=chunk+36  `sample bytes plus remaining header bytes
  for x=0 to 3
    write byte 1, wavHeader(x)
  next x
  ` fill in missing bytes here
  write long 1, chunk2
  for x=8 to 39
    write byte 1, wavHeader(x)
  next x
  write long 1,chunk ` this completes the header info
  ` write wave data from memblock data
  for x=1 to samples
    write word 1, memblock word(1,26+x*2)
  next x
  close file 1

  delete memblock 1

endfunction

`Snowman (Start Coding: 20.12.2007 | 12:24 Uhr)
set display mode 1280,1024,32
randomize timer()
color backdrop 0

`Variables
global vx as float   `\
global vy as float   ` > Temporary Coordinate Storing
global vz as float   `/
global ang as float

`Vector for Distance
null=make vector2(1)

`-------------------------------------------------------------------------------------------------->
`                                                                                                Hat
`Hat Specific Variables
innerrad     as float = 40.
outerrad     as float = 50.
billrad      as float = 120.
billirad     as float = 0.
crumble      as float = 1.
height       as float = 130.
capheight    as float = 120.
sideheight   as float = 10.
billheight   as float = 0.
billiheight  as float = 8.

make object sphere 1,150,36,50
`set object wireframe 1,1
`set object light 1,0

lock vertexdata for limb 1,0
vertind=0
for i=0 to 36
   for j=0 to 50
   
      `Calculate Angle to the Center
      ang=(360./51.)*j
      
      `Find out Vertex Position
      vx=get vertexdata position x(vertind)
      vy=get vertexdata position y(vertind)
      vz=get vertexdata position z(vertind)

      `"Sculpt" the Model
      if i=0              `Highest Point
         vx=0
         vy=height
         vz=0
      endif
         
      if i=>1 and i<=5      `Cap
         calc_spline(0,height,innerrad/2,height,innerrad,capheight+((height-capheight)/2),innerrad,capheight,i,6)
         vx=sin(ang)*s_x+rfac()*crumble
         vy=s_y
         vz=cos(ang)*s_x+rfac()*crumble
      endif

      if i=>6 and i<=20     `Side
         calc_spline(innerrad,capheight,innerrad+(outerrad-innerrad)/2,capheight-(capheight-sideheight)/4,outerrad,sideheight+(capheight-sideheight)/2,outerrad,sideheight,i-6,15)
         vx=sin(ang)*s_x+rfac()*crumble
         vy=s_y
         vz=cos(ang)*s_x+rfac()*crumble
      endif
      
      if i=>21 and i<= 28   `Bill (Top Side)
         calc_spline(outerrad,sideheight,outerrad+(billrad-outerrad)/2,sideheight,billrad,billheight-(billheight-sideheight)/4,billrad,billheight,i-21,8)
         vx=sin(ang)*s_x+rfac()*crumble
         vy=s_y
         vz=cos(ang)*s_x+rfac()*crumble
      endif
      
      if i=>29 and i<=36    `Bill (Bottom Side)
         calc_spline(billrad,billheight,billrad,billheight-(billheight-sideheight)/4,billirad+(billrad-billirad)/2,billiheight,billirad,billiheight,i-29,7)
         vx=sin(ang)*s_x+rfac()*crumble
         vy=s_y
         vz=cos(ang)*s_x+rfac()*crumble
      endif
      
      if i=36                `Last Loop
         vx=0
         vy=billiheight
         vz=0
      endif

      `Position Vertex
      set vertexdata position vertind,vx,vy,vz
      
      `Skip to next Vertex
      inc vertind
      
   next j
next i

`Prepare Texture Creation
tsx=1024
tsy=1024

`Create Memblock
base = make_image_memblock(1,tsx,tsy)

`Create Basic Color
type _col
   pos as integer
   r as float
   g as float
   b as float
endtype

cc as _col
nextc as _col
cstep as _col

restore

read cc.pos
read cc.r
read cc.g
read cc.b

read nextc.pos
read nextc.r
read nextc.g
read nextc.b

cstep.r = (nextc.r-cc.r)/(nextc.pos-cc.pos)
cstep.g = (nextc.g-cc.g)/(nextc.pos-cc.pos)
cstep.b = (nextc.b-cc.b)/(nextc.pos-cc.pos)

for sy=0 to 1023

   `Make Line
   for x=0 to 1023
      mdot(base,x,sy,int(cc.r),int(cc.g),int(cc.b),255)
   next x
   
   `Alter Current Color
   inc cc.r,cstep.r
   inc cc.g,cstep.g
   inc cc.b,cstep.b
   
   `Skip to next Color if necessary
   if nextc.pos=sy
      cc=nextc
      
      read nextc.pos
      read nextc.r
      read nextc.g
      read nextc.b

      cstep.r = (nextc.r-cc.r)/(nextc.pos-cc.pos)
      cstep.g = (nextc.g-cc.g)/(nextc.pos-cc.pos)
      cstep.b = (nextc.b-cc.b)/(nextc.pos-cc.pos)

   endif
next sy

`Create some Dents
depth as float
for i=0 to 20
   depth=rfac()*2+1
   create_dent(base,1,0.5*depth/3,7+rnd(12),rnd(50),rnd(20)+10,depth)
next i

`Create some "negative" Dents
depth as float
for i=0 to 10
   depth=rfac()*3+1
   create_dent(base,1,-(0.5*depth/4),7+rnd(12),rnd(50),rnd(20)+10,-depth)
next i

`Create some Dents on the Bill (mainly for Color Reasons)
for i=0 to 5
   create_dent(base,1,0.1,21+rnd(3),rnd(50),rnd(30),rfac()*2)
   create_dent(base,1,-0.1,21+rnd(3),rnd(50),rnd(30),-(rfac()*2))
next i

`Create big Dent at the Beginning
`of the red Part.
create_dent(base,1,1,17,0,50,6)

`Fray out the Bill
levels as float = 5.
for j=0 to 50
   if rnd(3)=0
      dep=rnd(30)+20
      ind=rnd(50)
      length=rnd(1)+1
      strength as float
      for cur=int(28-levels) to int(28+levels)
         strength=(levels-abs(28-cur))/levels
         create_dent(base,0,0,cur,ind,length,dep*strength)
      next cur

   endif
next j

`End of Vertex Editing
unlock vertexdata
calculate object bounds 1
set object normals 1

`Object Options
make image from memblock 1,base
delete memblock 1
texture object 1,1

set object specular 1,rgb(200,200,200)
set object emissive 1,rgb(100,100,100)
set object ambience 1,rgb(10,10,10)
set object diffuse 1,rgb(200,200,210)

`-------------------------------------------------------------------------------------------------->
`                                                                                          Main Loop
sync on : sync rate 100
while returnkey()=0

rotate camera camera angle x()+mousemovey(),camera angle y()+mousemovex(),0
move camera ((mouseclick()=1)-(mouseclick()=2))

if controlkey()=1 then paste image 1,0,0

sync
endwhile
end
            
`-------------------------------------------------------------------------------------------------->
`                                                                                      Random Factor
function rfac()
`Gives out a Random Factor between
`0 and 1, could be replaced by IanM's
`random() Function.

fac as float
fac=rnd(1000)/1000.

endfunction fac

`-------------------------------------------------------------------------------------------------->
`                                                                                        Create Dent
function create_dent(mem,useam,intens as float,yloop,xfrom,xlength,depth as float)
`This Function will create a Dent on the specified
`Y Loop and with a specified Length & Depth. Works
`on locked Vertexdata, but is pretty much optimized
`for the Snowman so it's quite useless for other
`Stuff.

`Local Variables
local rad      as float
local curdepth as float

for j=xfrom to xfrom+xlength
   `Wrap Index if he's too Low or High
   cx=wrap_val(j,0,50)
   
   `Calculate Angle to the Center
   ang=360./50.*cx
   
   `Find out Vertex Position
   vind=(yloop+1)*51+cx
   vx=get vertexdata position x(vind)
   vy=get vertexdata position y(vind)
   vz=get vertexdata position z(vind)

   `Calculate Distance to Center
   rad=distance(vx,vz,0,0)

   `Find out Dent Depth
   calc_spline(0,0,0,depth,xlength,depth,xlength,0,j-xfrom,xlength)
   curdepth=s_y
   
   `Calculate new Position
   vx=sin(ang)*(rad-curdepth)
   vy=vy
   vz=cos(ang)*(rad-curdepth)

   `Position Vertex
   set vertexdata position vind,vx,vy,vz
   
next j

`Fake Ambient Occlusion
if useam=1
   beginx as float
   endx   as float
   ypos   as float

   beginx = 1024*get vertexdata u((yloop+1)*51+xfrom)
   endx   = 1024*get vertexdata u((yloop+1)*51+wrap_val(xfrom+xlength,0,50))
   ypos   = 1024*get vertexdata v((yloop+1)*51+xfrom)

   if beginx>endx
      endx=1024+endx
   endif

   draw_gradient_scratch(mem,beginx,endx,ypos,1024./51.,-255*intens,-255*intens,-255*intens)
endif

endfunction

`-------------------------------------------------------------------------------------------------->
`                                                                              Draw Gradient Scratch
function draw_gradient_scratch(mem,bx as float,ex as float,y as float,amp,br,bg,bb)
`Draws a Scratch like Gradient from bx,y to ex,y.
`The Height is specified by the amp(litude). The
`Base Color (which is only fully seen right in the
`Middle of the Gradient) is specified by br, bg, bb.

`Variables
angstep    as float
angstep             = 180./(ex-bx)
angle      as float = 0.
colangstep as float = 0.
colangle   as float = 0.
fromy      as float = 0.
toy        as float = 0.
curx       as float = 0.
cury       as float = 0.
curr       as float = 0.
curg       as float = 0.
curb       as float = 0.
er         as float = 0.
eg         as float = 0.
eb         as float = 0.
xfactor    as float = 0.
yfactor    as float = 0.

`Loop through all X Coordinates
for curx=bx to ex

   `Calculate some Variables
   fromy      = y - sin(angle)*amp
   toy        = y + sin(angle)*amp
   colangstep = 180./(toy-fromy)
   colangle   = 0.

   `Loop through all Y Coordinates
   for cury=fromy to toy
      if cury=>0 and cury<=1023

         `Calculate Color
         xfactor = sin(angle)/2.
         yfactor = sin(colangle)/2.
         curr    = br*xfactor*yfactor
         curg    = bg*xfactor*yfactor
         curb    = bb*xfactor*yfactor

         `Get exisisting Color of current Pixel
         er=gdot(mem,wrap_val(curx,1,1024),cury,0)
         eg=gdot(mem,wrap_val(curx,1,1024),cury,1)
         eb=gdot(mem,wrap_val(curx,1,1024),cury,2)

         `"Blend" them Together
         curr=er+curr
         curg=eg+curg
         curb=eb+curb

         `"Troubleshooting"
         if curr<0 : curr=0 : else : if curr>255 : curr=255 : endif : endif
         if curg<0 : curg=0 : else : if curg>255 : curg=255 : endif : endif
         if curb<0 : curb=0 : else : if curb>255 : curb=255 : endif : endif

         `Make Dot
         mdot(mem,wrap_val(curx,1,1024),cury,curr,curg,curb,255)

         `Increase Color Angle
         inc colangle,colangstep

      endif
   next cury

   `Increase X Angle
   inc angle,angstep

next curx

endfunction

`-------------------------------------------------------------------------------------------------->
`                                                                                           Distance
function distance(x1 as float,y1 as float,x2 as float,y2 as float)

set vector2 1,x1-x2,y1-y2
dist as float
dist = length vector2(1)

endfunction dist
   
`-------------------------------------------------------------------------------------------------->
`                                                                                               Wrap
function wrap_val(cur,mini,maxi)
`Will wrap a Value, similar to "wrapvalue()" Function.
`Can be replaced with IanM's "wrap()" Function.

if cur<mini then cur=maxi+cur+1
if cur>maxi then cur=mini+cur-maxi-1

endfunction cur

`-------------------------------------------------------------------------------------------------->
`                                                                                             Spline
function calc_spline(s_1x,s_1y,s_2x,s_2y,s_3x,s_3y,s_4x,s_4y,cstep,mstep as float)

s_a=   s_4x - 3*s_3x + 3*s_2x - s_1x
s_b= 3*s_3x - 6*s_2x + 3*s_1x
s_c= 3*s_2x - 3*s_1x
s_d=   s_1x

s_e=   s_4y - 3*s_3y + 3*s_2y - s_1y
s_f= 3*s_3y - 6*s_2y + 3*s_1y
s_g= 3*s_2y - 3*s_1y
s_h=   s_1y

       s_t  as float
global s_x  as float
global s_y  as float

s_t=1./mstep*cstep

s_x=s_a*s_t^3+s_b*s_t^2+s_c*s_t+s_d
s_y=s_e*s_t^3+s_f*s_t^2+s_g*s_t+s_h

endfunction

`-------------------------------------------------------------------------------------------------->
`                                                                                Make Image Memblock
function make_image_memblock(mem,dimx,dimy)
`This Function will create a Memblock which suits
`all needs to use it as an Image.

`Create a new Memblock
make memblock mem,12+dimx*dimy*4

`Write Data
write memblock dword mem,0,dimx
write memblock dword mem,4,dimy
write memblock byte  mem,8,32

endfunction mem

`------------------------------------------------------------------------------------------------->
`                                                                                           Get Dot
function gdot(mem,posx,posy,rgbmode)
`This Function will return the RGB Information of
`the specified Pixel in the Memblock.

`Find out Image Dimensions
dimx=memblock dword(mem,0)
base=12+posx*4+posy*dimx*4

`Return the Right Values
if rgbmode=0 then exitfunction memblock byte(mem,base+2) `Red
if rgbmode=1 then exitfunction memblock byte(mem,base+1) `Green
if rgbmode=2 then exitfunction memblock byte(mem,base)   `Blue
if rgbmode=3 then exitfunction memblock byte(mem,base+3) `Alpha

endfunction 0

`-------------------------------------------------------------------------------------------------->
`                                                                                           Make Dot
function mdot(mem,posx,posy,red,green,blue,alpha)
`This Function will make a Dot at the specified Position.

`Find out Image Dimensions
dimx=memblock dword(mem,0)
base=12+posx*4+posy*dimx*4

`Write Data to Memblock
write memblock byte mem,base  ,blue
write memblock byte mem,base+1,green
write memblock byte mem,base+2,red
write memblock byte mem,base+3,alpha

endfunction

`-------------------------------------------------------------------------------------------------->
`                                                                                               Data
data    0, 80, 80, 90
data   50,110,110,115
data  100,150,150,155
data  200,150,150,150
data  500,100,100,105
data  512, 95, 53, 57
data  550,100, 50, 60
data  590, 56, 30, 31
data  595, 50, 50, 50
data  630,150,150,140
data  800,100,100,105
data 1023,150,150,160