Sorry your browser is not supported!

`  *** N.B. This program requires DBPro5.8 because of the memblock format

global dirset

` N.B. there is no need to rem out the following lines - just done for illustration,
`      try remming out a different set and see what happens

`createsound("laser",1,1500,700,8000,0.01,0.2,0,0,0,0)
`createsound("explosion",2,6200,700,2000,20,0.2,0,0,0,0)
`createsound("explosion2",3,1200,1400,3000,10,0.1,0,0,0,0)
createsound("powerup",4,800,700,8000,-0.02,0.2,0,0,0,0)
createsound("warning",5,800,1000,6000,0.5,0.1,0,0,0,0)
`createsound("vibrato1",6,500,2000,8000,0,0.1,0.05,0.2,0,0)
`createsound("vibrato2",7,400,2000,8000,0,0.1,0.05,0.2,0,0)
`createsound("vibrato3",8,600,2000,8000,0,0.1,0.05,0.2,0,0)
`createsound("bass hit",9,20,200,14000,0.00,1.2,.0,0,0,0)
`createsound("hihat",10,800,200,5000,60.06,2.2,.1,0,0,0)
`createsound("door knock",11,200,200,8000,.1,4.0,2.1,10,9.2,9.2)
createsound("vinyl scratch",12,500,200,8000,0.06,0.2,.1,0,0,0)
`createsound("cb1",13,250,500,2500,0.00001,0.2,4.0,0.4,0,0)
`createsound("cb2",14,500,500,2500,0.00001,0.2,4.0,0.4,0,0)
`createsound("cb3",15,437.5,1500,1500,0.0001,0.2,0.0,4.0,0.4,0)
`createsound("cb4",16,573.75,1500,1500,0.0,0.2,4.0,0.4,0,0)
`createsound("bubble burst",17,100,800,6000,-.4,2.0,0.1,10,1.2,0.2)

set text font "arial"
set text size 16
do
text 0,0,"Press keys 1 upwards:"
text 0,20,"1: laser"
text 0,40,"2: explosion1"
text 0,60,"3: explosion2"
text 0,80,"4: powerup"
text 0,100,"5: warning"
text 0,120,"6: vibrato"
text 0,140,"7: bass hit"
text 0,160,"8: hihat"
text 0,180,"9: door knock"
text 0,200,"0: vinyl scratch"
text 0,220,"-: cowbell"
text 0,240,"+: bubble burst"

if inkey$()="1"  then if sound exist(1) then play sound 1:wait 300
if inkey$()="2"  then if sound exist(2) then play sound 2:wait 300
if inkey$()="3"  then if sound exist(3) then play sound 3:wait 300
if inkey$()="4"  then if sound exist(4) then play sound 4:wait 300
if inkey$()="5"  then if sound exist(5) then play sound 5:wait 300
if inkey$()="6"  then if sound exist(6) then play sound 6:play sound 7:play sound 8:wait 300
if inkey$()="7"  then if sound exist(9) then play sound 9:wait 300
if inkey$()="8"  then if sound exist(10) then play sound 10:wait 300
if inkey$()="9"  then if sound exist(11) then play sound 11:wait 300
if inkey$()="0"  then if sound exist(12) then play sound 12:wait 300
if inkey$()="-"  then if sound exist(13) then play sound 13:play sound 14:play sound 15:play sound 16:wait 300
if inkey$()="+"  then if sound exist(17) then play sound 17:wait 300
loop


function createsound(name$,soundnumber,frequency#,length#,loudness#,bend#,decay#,vibratospeed#,vibratodepth#,tremelospeed#,tremelodepth#)

local outWord as word
local dword1 as dword
local dword2 as dword
local dword3 as dword
local dword4 as dword
local dword5 as dword
local dword6 as dword
local dword7 as dword

samples=int((length#/1000)*44100)

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

` write 28 memblock header bytes
dword1=1      ` gg query: is this the number of channels?
dword2=2      ` gg query: is this the number of bytes per sample?
dword3=22050  ` gg query: seems to be half the number of samples per second - why?
dword4=88200  ` gg query: is this the number of bytes per second?
dword5=4      ` gg query: what does this represent?
dword6=16     ` gg query:     (ditto)            ?
dword7=0      ` gg query:     (ditto)            ?

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

rem generate and write wave
for x=1 to samples
  ` gg output#=int(sin((x/122.5)*(frequency#+vibratodepth#*sin(theta#)))*(loudness#+tremelodepth#*sin(phi#)))*3.0
  outInteger=int(sin((x/122.5)*(frequency#+vibratodepth#*sin(theta#)))*(loudness#+tremelodepth#*sin(phi#)))*3.0 ` gg
  if outInteger <-32767 then outInteger=-32767  ` gg query: is this the valid range?
  if outInteger>32767 then outInteger=32767     ` gg query:       (ditto)          ?
  outWord=outInteger
  inc theta#,vibratospeed#
  inc phi#,tremelospeed#
  dec frequency#,bend#
  if loudness#>0 then dec loudness#,decay#
  write memblock word soundnumber, position, outWord : inc position,2
next x

make sound from memblock soundnumber, soundnumber

` save memblock data as txt file for manual checking

if dirset=0
  dirset=1
  set dir "media"
endif

blockSize=get memblock size(soundnumber)
fileName$="Sound"+str$(soundnumber)+".txt"
if file exist(fileName$) then delete file fileName$
open to write soundnumber,"Sound"+str$(soundnumber)+".txt"

` first print some summary data
write string soundnumber, "memblock size = "+str$(blockSize)
` now print the memblock, four bytes per line
block4=0: lineOut$=""
for i=0 to blockSize-1
  newByteString$=str$(memblock byte(soundnumber,i))
  newString$=space$(4-len(newByteString$))+newByteString$
  lineOut$=lineOut$+newString$
  inc block4
  if block4=4
    write string soundnumber, lineOut$
    lineOut$=""
    block4=0
  endif
next i
` print final incomplete line if necessary
if block4>0 then write string soundnumber, lineOut$

` now test the sound
play sound soundnumber
wait key

endfunction

`  *** N.B. This program requires DBPro5.8 because of the memblock format

`  produces sounds from memblocks - i.e. no need for .wav files, etc
`  based on Ric's original code and modified to use memblocks by Green Gandalf

createsound("laser",1,1500,700,8000,0.01,0.2,0,0,0,0)
createsound("explosion",2,6200,700,2000,20,0.2,0,0,0,0)
createsound("explosion2",3,1200,1400,3000,10,0.1,0,0,0,0)
createsound("powerup",4,800,700,8000,-0.02,0.2,0,0,0,0)
createsound("warning",5,800,1000,6000,0.5,0.1,0,0,0,0)
createsound("vibrato1",6,500,2000,8000,0,0.1,0.05,0.2,0,0)
createsound("vibrato2",7,400,2000,8000,0,0.1,0.05,0.2,0,0)
createsound("vibrato3",8,600,2000,8000,0,0.1,0.05,0.2,0,0)
createsound("bass hit",9,20,200,14000,0.00,1.2,.0,0,0,0)
createsound("hihat",10,800,200,5000,60.06,2.2,.1,0,0,0)
createsound("door knock",11,200,200,8000,.1,4.0,2.1,10,9.2,9.2)
createsound("vinyl scratch",12,500,200,8000,0.06,0.2,.1,0,0,0)
createsound("cb1",13,250,500,2500,0.00001,0.2,4.0,0.4,0,0)
createsound("cb2",14,500,500,2500,0.00001,0.2,4.0,0.4,0,0)
createsound("cb3",15,437.5,1500,1500,0.0001,0.2,0.0,4.0,0.4,0)
createsound("cb4",16,573.75,1500,1500,0.0,0.2,4.0,0.4,0,0)
createsound("bubble burst",17,100,800,6000,-.4,2.0,0.1,10,1.2,0.2)

set text font "arial"
set text size 16
do
text 0,0,"Press keys 1 upwards:"
text 0,20,"1: laser"
text 0,40,"2: explosion1"
text 0,60,"3: explosion2"
text 0,80,"4: powerup"
text 0,100,"5: warning"
text 0,120,"6: vibrato"
text 0,140,"7: bass hit"
text 0,160,"8: hihat"
text 0,180,"9: door knock"
text 0,200,"0: vinyl scratch"
text 0,220,"-: cowbell"
text 0,240,"+: bubble burst"

if inkey$()="1" then play sound 1:wait 300
if inkey$()="2" then play sound 2:wait 300
if inkey$()="3" then play sound 3:wait 300
if inkey$()="4" then play sound 4:wait 300
if inkey$()="5" then play sound 5:wait 300
if inkey$()="6" then play sound 6:play sound 7:play sound 8:wait 300
if inkey$()="7" then play sound 9:wait 300
if inkey$()="8" then play sound 10:wait 300
if inkey$()="9" then play sound 11:wait 300
if inkey$()="0" then play sound 12:wait 300
if inkey$()="-" then play sound 13:play sound 14:play sound 15:play sound 16:wait 300
if inkey$()="+" then play sound 17:wait 300
loop


function createsound(name$,soundnumber,frequency#,length#,loudness#,bend#,decay#,vibratospeed#,vibratodepth#,tremelospeed#,tremelodepth#)

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((length#/1000)*44100)

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 number of channels?
dword2=2      ` gg query: is this the number of bytes per sample?
dword3=22050  ` gg query: seems to be half the number of samples per second - why?
dword4=88200  ` gg query: is this the number of bytes per second?
dword5=4      ` gg query: what does this represent?
dword6=16     ` gg query:     (ditto)            ?
dword7=0      ` gg query:     (ditto)            ?

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

rem generate and write wave
for x=1 to samples
  outInteger=int(sin((x/122.5)*(frequency#+vibratodepth#*sin(theta#)))*(loudness#+tremelodepth#*sin(phi#)))*3.0
  if outInteger <-32767 then outInteger=-32767  ` gg query: is this the valid range?
  if outInteger>32767 then outInteger=32767     ` gg query:       (ditto)          ?
  outWord=outInteger
  inc theta#,vibratospeed#
  inc phi#,tremelospeed#
  dec frequency#,bend#
  if loudness#>0 then dec loudness#,decay#
  write memblock word 1, position, outWord : inc position,2
next x

make sound from memblock 999, 1 ` assumes you won't need sound number 999!
clone sound soundnumber, 999
delete sound 999

` memblock no longer required
delete memblock 1

endfunction

Rem Project: SoundWithNoMedia
Rem Created: 11/06/2005 11:31:38

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

`  *** N.B. This program requires DBPro5.8 because of the memblock format

`  produces sounds from memblocks - i.e. no need for .wav files, etc
`  based on Ric's original code and modified to use memblocks by Green Gandalf
`  Lampton Worm edits..
`   - basic real time edit mode
`   - one key to create/plan
`   - put param data into a typed array
`  Lampton Worm suggests..
`   - add a save to file option
`   - add a load option
`   - add a BlueGUI interface
`   - add some safety in the code, e.g. currently lets you enter a negative length but this obviously breaks the createsound function

set text font "arial"
set text size 16

frequency=1
length=2
loudness=3
bend=4
decay=5
vibratospeed=6
vibratodepth=7
tremelospeed=8
tremelodepth=9
`-------------
total_params=9

type param_info
  value as float
  name$ as string
  stepamount as float
endtype

dim param(total_params) as param_info

`defaults (lazer)
param(frequency).value=1500 : param(frequency).name$="Frequency"       : param(frequency).stepamount=10
param(length).value=700     : param(length).name$="Length"             : param(length).stepamount=5
param(loudness).value=8000  : param(loudness).name$="Loudness"         : param(loudness).stepamount=20
param(bend).value=0.01      : param(bend).name$="Bend"                 : param(bend).stepamount=0.01
param(decay).value=0.2      : param(decay).name$="Decay"               : param(decay).stepamount=0.01
param(vibratospeed).value=0 : param(vibratospeed).name$="Vibratospeed" : param(vibratospeed).stepamount=0.1
param(vibratodepth).value=0 : param(vibratodepth).name$="Vibratodepth" : param(vibratodepth).stepamount=0.1
param(tremelospeed).value=0 : param(tremelospeed).name$="Tremelospeed" : param(tremelospeed).stepamount=0.1
param(tremelodepth).value=0 : param(tremelodepth).name$="Tremelodepth" : param(tremelodepth).stepamount=0.1

current_param=1

do

cls

for i=1 to total_params
  text 20,i*10,param(i).name$
  text 100,i*10,str$(param(i).value)
  if i=current_param then text 0,i*10,">"
next i

if downkey()=1
  inc current_param
  if current_param>total_params then current_param=1
  wait 75
endif
if upkey()=1
  dec current_param
  if current_param<1 then current_param=total_params
  wait 75
endif
if rightkey()=1 then inc param(current_param).value,param(current_param).stepamount
if leftkey()=1 then dec param(current_param).value,param(current_param).stepamount

if spacekey()=1
  createsound("custom",1,param(frequency).value,param(length).value,param(loudness).value,param(bend).value,param(decay).value,param(vibratospeed).value,param(vibratodepth).value,param(tremelospeed).value,param(tremelodepth).value)
  play sound 1
  wait 100
endif

loop


function createsound(name$,soundnumber,frequency#,length#,loudness#,bend#,decay#,vibratospeed#,vibratodepth#,tremelospeed#,tremelodepth#)

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((length#/1000)*44100)

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 number of channels?
dword2=2      ` gg query: is this the number of bytes per sample?
dword3=22050  ` gg query: seems to be half the number of samples per second - why?
dword4=88200  ` gg query: is this the number of bytes per second?
dword5=4      ` gg query: what does this represent?
dword6=16     ` gg query:     (ditto)            ?
dword7=0      ` gg query:     (ditto)            ?

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

rem generate and write wave
for x=1 to samples
  outInteger=int(sin((x/122.5)*(frequency#+vibratodepth#*sin(theta#)))*(loudness#+tremelodepth#*sin(phi#)))*3.0
  if outInteger <-32767 then outInteger=-32767  ` gg query: is this the valid range?
  if outInteger>32767 then outInteger=32767     ` gg query:       (ditto)          ?
  outWord=outInteger
  inc theta#,vibratospeed#
  inc phi#,tremelospeed#
  dec frequency#,bend#
  if loudness#>0 then dec loudness#,decay#
  write memblock word 1, position, outWord : inc position,2
next x

if sound exist(soundnumber)=1 then delete sound soundnumber

make sound from memblock 999, 1 ` assumes you won't need sound number 999!
clone sound soundnumber, 999
delete sound 999

` memblock no longer required
delete memblock 1

endfunction

`Save
if returnkey()=1
  wait 175
  input "Save Filename?",name$
  if file exist(name$) then delete file name$
  open to write 1,name$
  for i=1 to total_params
    write string 1,param(i).name$
    write float 1,param(i).value
    write float 1,param(i).stepamount
  next i
  close file 1
  if file exist(name$+".code") then delete file name$+".code"
  open to write 1,name$+".code"
  write string 1,"createsound("custom",1,"+str$(param(frequency).value)+","+str$(param(length).value)+","+str$(param(loudness).value)+","+str$(param(bend).value)+","+str$(param(decay).value)+","+str$(param(vibratospeed).value)+","+str$(param(vibratodepth).value)+","+str$(param(tremelospeed).value)+","+str$(param(tremelodepth).value)+")"
  close file 1
  wait 175
endif
`Load
if shiftkey()=1
  wait 175
  input "Load Filename?",name$
  open to read 1,name$
  for i=1 to total_params
    read string 1,param(i).name$
    read float 1,param(i).value
    read float 1,param(i).stepamount
  next i
  close file 1
  wait 175
endif

Rem Project: SoundWithNoMedia
Rem Created: 11/06/2005 11:31:38

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

`  *** N.B. This program requires DBPro5.8 because of the memblock format

`  produces sounds from memblocks - i.e. no need for .wav files, etc
`  based on Ric's original code and modified to use memblocks by Green Gandalf
`  Lampton Worm edits..
`   - basic real time edit mode
`   - one key to create/plan
`   - put param data into a typed array
`  Lampton Worm suggests..
`   - add a save to file option
`   - add a load option
`   - add a BlueGUI interface
`   - add some safety in the code, e.g. currently lets you enter a negative length but this obviously breaks the createsound function

set text font "arial"
set text size 16
ink rgb(80,80,250),0

frequency=1
length=2
loudness=3
bend=4
decay=5
vibratospeed=6
vibratodepth=7
tremelospeed=8
tremelodepth=9
`-------------
total_params=9

type param_info
  value as float
  name$ as string
  stepamount as float
endtype

dim param(total_params) as param_info

`defaults (lazer)
param(frequency).value=1500 : param(frequency).name$="Frequency"       : param(frequency).stepamount=10
param(length).value=700     : param(length).name$="Length"             : param(length).stepamount=5
param(loudness).value=8000  : param(loudness).name$="Loudness"         : param(loudness).stepamount=20
param(bend).value=0.01      : param(bend).name$="Bend"                 : param(bend).stepamount=0.01
param(decay).value=0.2      : param(decay).name$="Decay"               : param(decay).stepamount=0.01
param(vibratospeed).value=0 : param(vibratospeed).name$="Vibratospeed" : param(vibratospeed).stepamount=0.1
param(vibratodepth).value=0 : param(vibratodepth).name$="Vibratodepth" : param(vibratodepth).stepamount=0.1
param(tremelospeed).value=0 : param(tremelospeed).name$="Tremelospeed" : param(tremelospeed).stepamount=0.1
param(tremelodepth).value=0 : param(tremelodepth).name$="Tremelodepth" : param(tremelodepth).stepamount=0.1

current_param=1

do

cls

for i=1 to total_params
  text 20,i*10,param(i).name$
  text 100,i*10,str$(param(i).value)
  if i=current_param then text 0,i*10,">"
next i

if downkey()=1
  inc current_param
  if current_param>total_params then current_param=1
  wait 75
endif
if upkey()=1
  dec current_param
  if current_param<1 then current_param=total_params
  wait 75
endif
if rightkey()=1 then inc param(current_param).value,param(current_param).stepamount
if leftkey()=1 then dec param(current_param).value,param(current_param).stepamount

if spacekey()=1
  createsound("custom",1,param(frequency).value,param(length).value,param(loudness).value,param(bend).value,param(decay).value,param(vibratospeed).value,param(vibratodepth).value,param(tremelospeed).value,param(tremelodepth).value)
  play sound 1
  wait 100
endif

loop


function createsound(name$,soundnumber,frequency#,length#,loudness#,bend#,decay#,vibratospeed#,vibratodepth#,tremelospeed#,tremelodepth#)

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((length#/1000)*44100)

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 number of channels?
dword2=2      ` gg query: is this the number of bytes per sample?
dword3=22050  ` gg query: seems to be half the number of samples per second - why?
dword4=88200  ` gg query: is this the number of bytes per second?
dword5=4      ` gg query: what does this represent?
dword6=16     ` gg query:     (ditto)            ?
dword7=0      ` gg query:     (ditto)            ?

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

rem generate and write wave
dotx#=0
for x=1 to samples
  outInteger=int(sin((x/122.5)*(frequency#+vibratodepth#*sin(theta#)))*(loudness#+tremelodepth#*sin(phi#)))*3.0
  if count=0 and dotx#<screen width()then dot dotx#,(outInteger/300)+screen height()/2
  inc dotx#,.1
  inc count
  if count=3 then count=0
  if outInteger <-32767 then outInteger=-32767  ` gg query: is this the valid range?
  if outInteger>32767 then outInteger=32767     ` gg query:       (ditto)          ?
  outWord=outInteger
  inc theta#,vibratospeed#
  inc phi#,tremelospeed#
  dec frequency#,bend#
  if loudness#>0 then dec loudness#,decay#
  write memblock word 1, position, outWord : inc position,2
next x

if sound exist(soundnumber)=1 then delete sound soundnumber

make sound from memblock 999, 1 ` assumes you won't need sound number 999!
clone sound soundnumber, 999
delete sound 999

` memblock no longer required
delete memblock 1

endfunction

createsound("laser",1,rnd(1500)+500,rnd(700)+100,rnd(8000)+100,0.01,0.2,0,0,0,0)
createsound("explosion",2,6200,700,2000,20,0.2,0,0,0,0)
createsound("explosion2",3,1200,1400,3000,10,0.1,0,0,0,0)
createsound("powerup",4,800,700,8000,-0.02,0.2,0,0,0,0)
createsound("warning",5,800,1000,6000,0.5,0.1,0,0,0,0)
createsound("vibrato1",6,500,2000,8000,0,0.1,0.05,0.2,0,0)
createsound("vibrato2",7,400,2000,8000,0,0.1,0.05,0.2,0,0)
createsound("vibrato3",8,600,2000,8000,0,0.1,0.05,0.2,0,0)
createsound("bass hit",9,20,200,14000,0.00,1.2,.0,0,0,0)
createsound("hihat",10,800,200,5000,60.06,2.2,.1,0,0,0)
createsound("door knock",11,200,200,8000,.1,4.0,2.1,10,9.2,9.2)
createsound("vinyl scratch",12,500,200,8000,0.06,0.2,.1,0,0,0)
createsound("cb1",13,250,500,2500,0.00001,0.2,4.0,0.4,0,0)
createsound("cb2",14,500,500,2500,0.00001,0.2,4.0,0.4,0,0)
createsound("cb3",15,437.5,1500,1500,0.0001,0.2,0.0,4.0,0.4,0)
createsound("cb4",16,573.75,1500,1500,0.0,0.2,4.0,0.4,0,0)
createsound("bubble burst",17,100,800,6000,-.4,2.0,0.1,10,1.2,0.2)

set text font "arial"
set text size 16
do
text 0,0,"Press keys 1 upwards:"
text 0,20,"1: laser"
text 0,40,"2: explosion1"
text 0,60,"3: explosion2"
text 0,80,"4: powerup"
text 0,100,"5: warning"
text 0,120,"6: vibrato"
text 0,140,"7: bass hit"
text 0,160,"8: hihat"
text 0,180,"9: door knock"
text 0,200,"0: vinyl scratch"
text 0,220,"-: cowbell"
text 0,240,"+: bubble burst"

if keystate(2)=1  then play sound 1:wait 300
if keystate(3)=1  then play sound 2:wait 300
if keystate(4)=1  then play sound 3:wait 300
if keystate(5)=1  then play sound 4:wait 300
if keystate(6)=1  then play sound 5:wait 300
if keystate(7)=1  then play sound 6:play sound 7:play sound 8:wait 300
if keystate(8)=1  then play sound 9:wait 300
if keystate(9)=1  then play sound 10:wait 300
if keystate(10)=1  then play sound 11:wait 300
if keystate(11)=1  then play sound 12:wait 300
if keystate(12)=1  then play sound 13:play sound 14:play sound 15:play sound 16:wait 300
if keystate(13)=1  then play sound 17:wait 300
loop


function createsound(name$,soundnumber,frequency#,length#,loudness#,bend#,decay#,vibratospeed#,vibratodepth#,tremelospeed#,tremelodepth#)

if file exist(name$+".wav")=1 then delete file name$+".wav"
open to write 1,name$+".wav"
chunk=int(((length#/1000)*44100*16)/8) `sample size (no of samples * bitrate * channels / 8)
samples=int((length#/1000)*44100) `length *44100
restore
for x=1 to 40
   read byte2
   write byte 1, byte2
next x
write long 1,chunk
rem generate and write wave
for x=1 to samples
  output#=int(sin((x/122.5)*(frequency#+vibratodepth#*sin(theta#)))*(loudness#+tremelodepth#*sin(phi#)))*3.0
  inc theta#,vibratospeed#
  inc phi#,tremelospeed#
  dec frequency#,bend#
  if loudness#>0 then dec loudness#,decay#
  write word 1,output#
next x
close file 1

load sound name$+".wav",soundnumber

data 82:data 73:data 70:data 70:data 208:data 59:data 1:data 0:data 87
data 65:data 86:data 69:data 102:data 109:data 116:data 32:data 16
data 0:data 0:data 0:data 1:data 0:data 2:data 0:data 34:data 86:data 0
data 0:data 136:data 88:data 1:data 0:data 4:data 0:data 16:data 0
data 100:data 97:data 116:data 97

endfunction

Rem Project: SoundWithNoMedia
Rem Created: 11/06/2005 11:31:38

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

`  *** N.B. This program requires DBPro5.8 because of the memblock format

`  produces sounds from memblocks - i.e. no need for .wav files, etc
`  based on Ric's original code and modified to use memblocks by Green Gandalf
`  Lampton Worm edits..
`   - basic real time edit mode
`   - one key to create/plan
`   - put param data into a typed array
`  Lampton Worm suggests..
`   - add a save to file option
`   - add a load option
`   - add a BlueGUI interface
`   - add some safety in the code, e.g. currently lets you enter a negative length but this obviously breaks the createsound function

set text font "Tahoma"
set text size 20
sync on : sync rate 60
backdrop on : color backdrop 0xffffff
ink 0x000000,0x000000

frequency=1
length=2
loudness=3
bend=4
decay=5
vibratospeed=6
vibratodepth=7
tremelospeed=8
tremelodepth=9
`-------------
total_params=9

type param_info
  value as float
  name$ as string
  stepamount as float
endtype

dim param(total_params) as param_info

param(frequency).value=1000 : param(frequency).name$="Frequency"       : param(frequency).stepamount = 25
param(length).value=1000    : param(length).name$="Length"             : param(length).stepamount = 50
param(loudness).value=2500  : param(loudness).name$="Loudness"         : param(loudness).stepamount = 125
param(bend).value=0.0       : param(bend).name$="Bend"                 : param(bend).stepamount = 0.005
param(decay).value=0.0      : param(decay).name$="Decay"               : param(decay).stepamount = 0.005
param(vibratospeed).value=0 : param(vibratospeed).name$="Vibratospeed" : param(vibratospeed).stepamount = 0.5
param(vibratodepth).value=0 : param(vibratodepth).name$="Vibratodepth" : param(vibratodepth).stepamount = 0.5
param(tremelospeed).value=0 : param(tremelospeed).name$="Tremelospeed" : param(tremelospeed).stepamount = 0.5
param(tremelodepth).value=0 : param(tremelodepth).name$="Tremelodepth" : param(tremelodepth).stepamount = 0.5

current_param=1

type timetype
  old as integer
  new as integer
  dur as integer
  elapse as integer
  reset as boolean
endtype

global time as timetype

for i = 1 to total_params
  buffer = text width(param(i).name$)
  if buffer > twidth then twidth = buffer
next
inc twidth, text width("W")

do

updatetime()

for i=1 to total_params
  Height = 10 + ((i - 1) * text height("A"))
  text 20,Height,param(i).name$
  param$ = str$(param(i).value)
  text twidth + 20,Height, param$
  if i=current_param then text 0,Height,"<" : text twidth + text width(param$) + text width("W") + 20, height, ">"
next i

if time.elapse >= 80
  time.reset = 1
  if downkey()=1
    inc current_param
    if current_param>total_params then current_param=1
    wait 75
  endif
  if upkey()=1
    dec current_param
    if current_param<1 then current_param=total_params
    wait 75
  endif
  if rightkey()=1 then inc param(current_param).value,param(current_param).stepamount
  if leftkey()=1 then dec param(current_param).value,param(current_param).stepamount

  if spacekey()=1
    createsound("custom",1,param(frequency).value,param(length).value,param(loudness).value,param(bend).value,param(decay).value,param(vibratospeed).value,param(vibratodepth).value,param(tremelospeed).value,param(tremelodepth).value)
    play sound 1
    wait 100
  endif
endif

sync

loop

function updatetime()
  time.new = timer()
  time.dur = time.new - time.old
  time.old = time.new
  if time.reset
    time.elapse = time.dur
  else
    inc time.elapse, time.dur
  endif
  time.reset = time.reset ~~ time.reset
endfunction

function createsound(name$,soundnumber,frequency#,length#,loudness#,bend#,decay#,vibratospeed#,vibratodepth#,tremelospeed#,tremelodepth#)

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((length#/1000)*44100)

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 number of channels?
dword2=2      ` gg query: is this the number of bytes per sample?
dword3=22050  ` gg query: seems to be half the number of samples per second - why?
dword4=88200  ` gg query: is this the number of bytes per second?
dword5=4      ` gg query: what does this represent?
dword6=16     ` gg query:     (ditto)            ?
dword7=0      ` gg query:     (ditto)            ?

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

rem generate and write wave
dotx#=0
for x=1 to samples
  outInteger=int(sin((x/122.5)*(frequency#+vibratodepth#*sin(theta#)))*(loudness#+tremelodepth#*sin(phi#)))*3.0
  if count=0 and dotx#<screen width()then dot dotx#,(outInteger/300)+screen height()/2
  inc dotx#,.1
  inc count
  if count=3 then count=0
  if outInteger <-32767 then outInteger=-32767  ` gg query: is this the valid range?
  if outInteger>32767 then outInteger=32767     ` gg query:       (ditto)          ?
  outWord=outInteger
  inc theta#,vibratospeed#
  inc phi#,tremelospeed#
  dec frequency#,bend#
  if loudness#>0 then dec loudness#,decay#
  write memblock word 1, position, outWord : inc position,2
next x

if sound exist(soundnumber)=1 then delete sound soundnumber

make sound from memblock 999, 1 ` assumes you won't need sound number 999!
clone sound soundnumber, 999
delete sound 999

` memblock no longer required
delete memblock 1

endfunction

Rem Project: SoundWithNoMedia
Rem Created: 11/06/2005 11:31:38

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

`  *** N.B. This program requires DBPro5.8 because of the memblock format

`  produces sounds from memblocks - i.e. no need for .wav files, etc
`  based on Ric's original code and modified to use memblocks by Green Gandalf
`  Lampton Worm edits..
`   - basic real time edit mode
`   - one key to create/plan
`   - put param data into a typed array
`  Lampton Worm suggests..
`   - add a save to file option
`   - add a load option
`   - add a BlueGUI interface
`   - add some safety in the code, e.g. currently lets you enter a negative length but this obviously breaks the createsound function

set text font "Tahoma"
set text size 20
sync on : sync rate 60
backdrop on : color backdrop 0xffffff
ink 0x000000,0x000000

frequency=1
length=2
loudness=3
bend=4
decay=5
vibratospeed=6
vibratodepth=7
tremelospeed=8
tremelodepth=9
attack=10

`-------------
total_params=10

type param_info
  value as float
  name$ as string
  stepamount as float
endtype

dim param(total_params) as param_info

param(frequency).value=1000 : param(frequency).name$="Frequency"       : param(frequency).stepamount = 25
param(length).value=1000    : param(length).name$="Length"             : param(length).stepamount = 50
param(loudness).value=2500  : param(loudness).name$="Loudness"         : param(loudness).stepamount = 125
param(bend).value=0.0       : param(bend).name$="Bend"                 : param(bend).stepamount = 0.005
param(decay).value=0.0      : param(decay).name$="Decay"               : param(decay).stepamount = 0.005
param(vibratospeed).value=0 : param(vibratospeed).name$="Vibratospeed" : param(vibratospeed).stepamount = 0.5
param(vibratodepth).value=0 : param(vibratodepth).name$="Vibratodepth" : param(vibratodepth).stepamount = 0.5
param(tremelospeed).value=0 : param(tremelospeed).name$="Tremelospeed" : param(tremelospeed).stepamount = 0.5
param(tremelodepth).value=0 : param(tremelodepth).name$="Tremelodepth" : param(tremelodepth).stepamount = 0.5
param(attack).value=5.0 : param(attack).name$="attack": param(attack).stepamount = 0.1

current_param=1

type timetype
  old as integer
  new as integer
  dur as integer
  elapse as integer
  reset as boolean
endtype

global time as timetype

for i = 1 to total_params
  buffer = text width(param(i).name$)
  if buffer > twidth then twidth = buffer
next
inc twidth, text width("W")

do

updatetime()

for i=1 to total_params
  Height = 10 + ((i - 1) * text height("A"))
  text 20,Height,param(i).name$
  param$ = str$(param(i).value)
  text twidth + 20,Height, param$
  if i=current_param then text 0,Height,"<" : text twidth + text width(param$) + text width("W") + 20, height, ">"
next i

if time.elapse >= 80
  time.reset = 1
  if downkey()=1
    inc current_param
    if current_param>total_params then current_param=1
    wait 75
  endif
  if upkey()=1
    dec current_param
    if current_param<1 then current_param=total_params
    wait 75
  endif
  if rightkey()=1 then inc param(current_param).value,param(current_param).stepamount
  if leftkey()=1 then dec param(current_param).value,param(current_param).stepamount

  if spacekey()=1
    createsound("custom",1,param(frequency).value,param(length).value,param(loudness).value,param(bend).value,param(decay).value,param(vibratospeed).value,param(vibratodepth).value,param(tremelospeed).value,param(tremelodepth).value,param(attack).value)
    play sound 1
    wait 100
  endif
endif

sync

loop

function updatetime()
  time.new = timer()
  time.dur = time.new - time.old
  time.old = time.new
  if time.reset
    time.elapse = time.dur
  else
    inc time.elapse, time.dur
  endif
  time.reset = time.reset ~~ time.reset
endfunction

function createsound(name$,soundnumber,frequency#,length#,loudness#,bend#,decay#,vibratospeed#,vibratodepth#,tremelospeed#,tremelodepth#,attack#)

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((length#/1000)*44100)

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 number of channels?
dword2=2      ` gg query: is this the number of bytes per sample?
dword3=22050  ` gg query: seems to be half the number of samples per second - why?
dword4=88200  ` gg query: is this the number of bytes per second?
dword5=4      ` gg query: what does this represent?
dword6=16     ` gg query:     (ditto)            ?
dword7=0      ` gg query:     (ditto)            ?

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

rem generate and write wave
dotx#=0
`inc attackamount#,0.0001
riseinloudness#=loudness#
for x=1 to samples
  outInteger=int(sin((x/122.5)*(frequency#+vibratodepth#*sin(theta#)))*(loudness#-fallinloudness#-riseinloudness#+tremelodepth#*sin(phi#)))*3.0
  if count=0 and dotx#<screen width()then dot dotx#,(outInteger/300)+screen height()/2
  inc dotx#,.1
  inc count
  if count=3 then count=0
  if outInteger <-32767 then outInteger=-32767  ` gg query: is this the valid range?
  if outInteger>32767 then outInteger=32767     ` gg query:       (ditto)          ?
  outWord=outInteger
  inc theta#,vibratospeed#
  inc phi#,tremelospeed#
  dec frequency#,bend#

  if fallinloudness#<loudness#
    inc fallinloudness#,decay#
  endif

  if riseinloudness#>0
    dec riseinloudness#,attack#
  endif

  write memblock word 1, position, outWord : inc position,2
next x

if sound exist(soundnumber)=1 then delete sound soundnumber

make sound from memblock 999, 1 ` assumes you won't need sound number 999!
clone sound soundnumber, 999
delete sound 999

` memblock no longer required
delete memblock 1

endfunction

#Constant SoundStereo = 0x02
#Constant SoundMono = 0x01

Type SoundMemblockType
  FormatTag As Integer
  Channels As Integer
  SamplesPerSec As Integer
  BytesPerSec As Integer
  BlockAlign As Integer
  BitsPerSample As Integer
  ExtendedSize As Integer
EndType

Type SoundSubDataType
  Speed As Float
  Depth As Float
EndType

Type SoundDataType
  Frequency As Float
  Duration AS Float
  Volume As Float
  Decay As Float
  Variation As Float
  Vibration As SoundSubDataType
  Treme As SoundSubDataType
EndType

Type SoundWaveType
  Header As SoundMemblockType
  Sample As SoundDataType
EndType

Global Dim SoundWave(void) As SoundWaveType

Gunshot = NewSound(SoundMono, 16, 950.0, 50.0, 2500.0, 0.2, 0.2, 2.0, 5.0, 10.0, 5.0)
Buffer As SoundWaveType ; Buffer.Header = SoundWave(Gunshot).Header : Buffer.Sample = SoundWave(Gunshot).Sample
BasicSound = CreateSound(Buffer.Header, Buffer.Sample, 44100)

Play Sound BasicSound
Wait Key

Function NewSound( Channels As Integer, BPS As Integer, Freq As Float, Dur As Float, Vol As Float, Var As Float, Decay As Float, VSpeed As Float, VDepth As Float, TSpeed As Float, TDepth As Float )
  Local This As Integer

  Array Insert At Bottom SoundWave(void)
  This = Array Count(SoundWave(void))

  SoundWave(This).Header.Channels = Channels
  SoundWave(This).Header.BitsPerSample = BPS
  SoundWave(This).Sample.Frequency = Freq
  SoundWave(This).Sample.Duration = Dur
  SoundWave(This).Sample.Volume = Vol
  SoundWave(This).Sample.Variation = Var
  SoundWave(This).Sample.Decay = Decay
  SoundWave(This).Sample.Vibration.Speed = VSpeed
  SoundWave(This).Sample.Vibration.Depth = VDepth
  SoundWave(This).Sample.Treme.Speed = TSpeed
  SoundWave(This).Sample.Treme.Depth = TDepth
EndFunction This

Function CreateSound( Header As SoundMemblockType, Sample As SoundDataType, MHz As Integer )
  Local Available As Integer

  Header.SamplesPerSec = Int((Sample.Duration / 1000) * MHz)
  Header.BlockAlign = (Header.Channels * Header.BitsPerSample) / 8
  Header.BytesPerSec = Header.SamplesPerSec * Header.BlockAlign

  For Available = 1 To 255
    If Memblock Exist(Available) = 0 Then SoundBuffer = Available
  Next

  Make Memblock SoundBuffer, 28 + (Header.SamplesPerSec * (Header.BitsPerSample / 8))
    Local Position As Integer = 0
    Write Memblock Dword SoundBuffer, Position, Header.FormatTag      : Inc Position, 4
    Write Memblock Dword SoundBuffer, Position, Header.Channels       : Inc Position, 4
    Write Memblock Dword SoundBuffer, Position, Header.SamplesPerSec  : Inc Position, 4
    Write Memblock Dword SoundBuffer, Position, Header.BytesPerSec    : Inc Position, 4
    Write Memblock Dword SoundBuffer, Position, Header.BlockAlign     : Inc Position, 4
    Write Memblock Dword SoundBuffer, Position, Header.BitsPerSample  : Inc Position, 4
    Write Memblock Dword SoundBuffer, Position, Header.ExtendedSize   : Inc Position, 4

    Local Output As Word
    Local Buffer, CurrentSample As Integer
    Local Theta As Float
    Local Phi As Float
    Local Frequency As Float
    Frequency = Sample.Frequency
    For CurrentSample = 1 To Header.SamplesPerSec
      Buffer = Int(Sin((CurrentSample / 122.5) * (Frequency + Sample.Vibration.Depth * Sin(Theta))) * (Sample.Volume + Sample.Treme.Depth * Sin(Phi))) * 3.0
      Output = Buffer
      Inc Theta, Sample.Vibration.Speed
      Inc Phi, Sample.Treme.Speed
      Dec Frequency, Sample.Variation
      If Volume > 0 Then Dec Volume, Decay
      Write Memblock Word SoundBuffer, Position, Output : Inc Position, Header.BitsPerSample / 8
    Next

    Local SoundWave As Integer
    For Available = 1 To 65535
      If Sound Exist(Available) = 0 Then SoundWave = Available
    Next
    Make Sound From Memblock SoundWave, SoundBuffer
  Delete Memblock SoundBuffer
EndFunction SoundWave

Sound(950, 250, 500, 750, 3000, 5000, 0.1, 0.0, 2, 2)
Print "..Now Playing Sound.."
Wait 3000
Sound(250, 950, 750, 500, 3000, 5000, 0.1, 0.0, 2, 2)
Wait Key

Function Sound(FreqS1#, FreqE1#, FreqS2#, FreqE2#, Length#, Volume#, Decay#, Reverb#, VibroS#, VibroD#)
  Local Out As Word
  Samples = Int((Length# / 1000) * 44100)
  If Memblock Exist(1) = 1
    Delete Memblock 1
  EndIf
  Make Memblock 1, 28 + (Samples * 2)
    Data 1, 2, 22050, 88200, 4, 16, 0
    For Index = 0 To 27 Step 4
      Read Buffer
      Write Memblock Dword 1, Index, Buffer
    Next
    Freq1# = FreqS1#
    Freq2# = FreqS2#
    For S = 1 To Samples
      Out = (Int((Sin((S / 122.5) * (Freq1# + VibroD# * Sin(T#))) * Volume#) * 3.0)) + (Int((Sin((S / 122.5) * (Freq2# + VibroD# * Sin(T#))) * Volume#) * 3.0)) / 2
      Inc T#, VibroS#
      Dec Freq1#, (((FreqS1# - FreqE1#) / 100.0) / Length#) + Reverb#
      Dec Freq2#, (((FreqS2# - FreqE2#) / 100.0) / Length#) + Reverb#
      If Volume# > 0
        Dec Volume#, Decay#
      EndIf
      Write Memblock Word 1, 28 + (2 * (S - 1)), Out
    Next
    If Sound Exist(1) = 1
      Delete Sound 1
    EndIf
    Make Sound From Memblock 1, 1
    Play Sound 1
  Delete Memblock 1
EndFunction

Type Vector4
  X As Float
  Y As Float
  Z As Float
  W As Float
EndType

RemStart
  Vector.X = Height(X - 2, Y - 2)
  Vector.Y = Height(X - 1, Y - 1)
  Vector.Z = Height(X + 1, Y + 1)
  Vector.W = Height(X + 2, X + 2)
  Depth = Absolute Distance Between Vector.Y and Vector.Z
RemEnd

Function CubicInterpolate( Vector As Vector4, Depth As Float )
  Local Buffer As Vector4
  Local Result As Float
  Buffer.X = (Vector.Z - Vector.W) - (Vector.X - Vector.Y)
  Buffer.Y = (Vector.X - Vector.Y) - Buffer.X
  Buffer.Z = Vector.Z - Vector.X
  Result = (Buffer.X * (Depth ^ 3)) + (Buffer.Y * (Depth ^ 2)) + (Buffer.Z * Depth) + Vector.W
EndFunction Result

RemStart
  X = Point A, Y = Point B, Depth = Distance
RemEnd

Function CosineInterpolate( X As Float, Y As Float, Depth As Float )
  Local Radius As Float
  Local Interpol As Float
  Local Result As Float

  Radius = Depth * 3.1415927
  Interpol = (1 - Cos(Radius)) * 0.5

  Result = X * (1 - Interpol) + Y * Interpol
EndFunction Result

function createsound(soundnumber,frequency#,length#,loudness#,bend#,decay#,vibratospeed#,vibratodepth#,tremelospeed#,tremelodepth#,attack#,noise,vol)

mb=soundnumber

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((length#/1000)*44100)

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

` write 28 memblock header bytes
dword1=1      ` gg query: is this the number of channels?
dword2=2      ` gg query: is this the number of bytes per sample?
dword3=22050  ` gg query: seems to be half the number of samples per second - why?
dword4=88200  ` gg query: is this the number of bytes per second?
dword5=4      ` gg query: what does this represent?
dword6=16     ` gg query:     (ditto)            ?
dword7=0      ` gg query:     (ditto)            ?

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

`inc attackamount#,0.0001
riseinloudness#=loudness#
for x=1 to samples
rem outInteger=int(sin((x/122.5)*(frequency#+vibratodepth#*sin(theta#)))*(loudness#-fallinloudness#-riseinloudness#+tremelodepth#*sin(phi#)))*3.0
  outInteger=int(sin((x/122.5)*(frequency#+vibratodepth#*sin(theta#)))*(loudness#-fallinloudness#-riseinloudness#+tremelodepth#*sin(phi#)))*3.0
  if outInteger <-32767 then outInteger=-32767  ` gg query: is this the valid range?
  if outInteger>32767 then outInteger=32767     ` gg query:       (ditto)          ?
  outWord=outInteger
  inc theta#,vibratospeed#
  inc phi#,tremelospeed#
  dec frequency#,bend#

  if fallinloudness#<loudness#
    inc fallinloudness#,decay#
  endif

  if riseinloudness#>0
    dec riseinloudness#,attack#
  endif

  write memblock word mb, position, outWord : inc position,2
next x

if sound exist(soundnumber)=1 then delete sound soundnumber

make sound from memblock soundnumber, mb
if vol<0 then vol=0
if vol>15 then vol=15
if frequency#>0 then set sound volume soundnumber,(vol*90/15)+10 : play sound soundnumber
delete memblock mb
if frequency#>0 then set sound speed 999,(frequency#*10)
if noise>0 and frequency#>0 then play sound 999
endfunction