Community Function Libraries V. 1 Beta

Author

Message

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 29th May 2008 07:26 Edited at: 30th May 2008 08:01

Link

Ok, here are the initial set of libraries. These functions were all submitted on the thread a while back and have been sorted through. Currently they are untested. What I need are for people to download them and try them out and make sure they work. email your findings to
[email protected]. Please only send feedback for one library at a time.

Format the email like so:
Subject: LIBRARY NAME Evaluation
1.FUNCTION NAME
-Did it work?
-Syntax required
-Short description of the function
-general evaluation (problems and if it should be included at all)

Here is an example of an email for the math library:

+ Code Snippet

Subject: Math Library Evaluation
1. Get Distance
    -Worked
    -get distance(POINT 1 X#, POINT 1 Y#, POINT 1 Z#,POINT 2 X#, POINT 2 Y#, POINT 2 Z#)
    -Finds the distance between two points in 3D space
    -No problems. Keep it in.
2. Round
    -Worked
    -round(VALUE#)
    -rounds VALUE# to the nearest integer
    -No problems. Keep it in.

When I get feedback on the different functions I will begin to compile the help files to go with the new functions.

Also if you have any functions to donate to the community function database, email them to [email protected]. Be sure to put in the subject that it is a function. Please include a short description of the function and the syntax for the function.

Here are the links to the libraries
Camera library
http://www.fileden.com/files/2007/7/27/1301559/Camera.dba
GUI Library
http://www.fileden.com/files/2007/7/27/1301559/Gui.dba
Math Library
http://www.fileden.com/files/2007/7/27/1301559/Math.dba
Object Library
http://www.fileden.com/files/2007/7/27/1301559/Object.dba

[EDIT]
Go ahead and post new functions here if you don't want to email them to me. I will leave no function left un-checked!

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

NanoGamez guy

18

Years of Service

User Offline

Joined: 13th Jan 2007

Location: Closer than you think...

Posted: 29th May 2008 12:55

Link

Great idea, but I think that the problem with this thread is that if people only email functions to you, not many people will post here and so it won't stay at the top. Because of this, nobody will be able to see it and so post functions to you.

What are the chemical formulae of:
Sodium Nitrate, Gallium, Manganese and Einsteinium

Back to top

Profile PM Email Website

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 30th May 2008 08:00

Link

Thats how it originally was, as a thread. However it started to get messy and community members were suggesting that I just set up an email address for people to send it to. I will not pass up a posted function though. If someone posts it, I will add it into the next batch of functions.

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

TDK

Retired Moderator

22

Years of Service

User Offline

Joined: 19th Nov 2002

Location: UK

Posted: 31st May 2008 09:31

Link

Posting on multiple boards is classed as spamming. Do you want this thread to continue or the one on Code Snippets?

TDK_Man

* TDK's Game Programming Forums - Open To All - DB & Team Request Boards *

Back to top

Profile PM Email Website

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 1st Jun 2008 09:47

Link

Sorry, keep this one, the other one was just to try to get more functions.

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

Ed222

17

Years of Service

User Offline

Joined: 3rd Nov 2007

Location: Calgary

Posted: 13th Jun 2008 00:38 Edited at: 18th Jun 2008 00:18

Link

here's a simple windows message box

+ Code Snippet

remstart
message$ controls the message you want windows to say in the message box.

Icobut controls the buttons shown the numbers for it are below.

synico controls the symbol beside the message numbers are also below.

boxtitle$ controls the title of the message box.
Note: all things with $ a at the end must have a quotation aka ""

TO CHANGE THE OK, CANCEL BUTTONS (icobut)
0 - ok button only
1 - ok and cancel 
2 - abort, retry and ignore
3 - yes no and cancel
4 - yes and no
5 - retry and cancel
TO CHANGE THE SYMBOL (symico)
16 - critical message icon
32 - warning icon
48 - warning message
64 - info message
remend
function mb(message$,icobut,symico,boxtitle$)

if file exist("messagebox.vbs")
delete file "messagebox.vbs"
endif

open to write 1,"messagebox.vbs"
write string 1,"X = MsgBox("+chr$(34)+message$+chr$(34)+","+str$(icobut)+"+"+str$(symico)+","+chr$(34)+boxtitle$+chr$(34)+")"
close file 1

execute file "messagebox.vbs","",""

endfunction

to change the buttons and icon look at the code below

message$ controls the message you want windows to say in the message box.

Icobut controls the buttons shown the numbers for it are below.

synico controls the symbol beside the message numbers are also below.

boxtitle$ controls the title of the message box.
Note: all things with $ a at the end must have a quotation aka ""

TO CHANGE THE OK, CANCEL BUTTONS (icobut)
0 - ok button only
1 - ok and cancel
2 - abort, retry and ignore
3 - yes no and cancel
4 - yes and no
5 - retry and cancel
TO CHANGE THE SYMBOL (symico)
16 - critical message icon
32 - warning icon
48 - warning message
64 - info message

example

+ Code Snippet

cls
mb("this is where the message goes",0,64,"The title goes here")

suspend for key
end




function mb(message$,icobut,symico,boxtitle$)

if file exist("messagebox.vbs")
delete file "messagebox.vbs"
endif

open to write 1,"messagebox.vbs"
write string 1,"X = MsgBox("+chr$(34)+message$+chr$(34)+","+str$(icobut)+"+"+str$(symico)+","+chr$(34)+boxtitle$+chr$(34)+")"
close file 1

execute file "messagebox.vbs","",""

endfunction

Back to top

Profile PM Email

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 17th Jun 2008 12:48

Link

Has anyone tested these yet? I really could use some help here.

@ed
Cool, thanks! I will add it to the libraries. Could you post an explanation of what each of the parameters controls?

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

Latch

18

Years of Service

User Offline

Joined: 23rd Jul 2006

Location:

Posted: 17th Jun 2008 22:55

Link

@BN2 Productions

This is quite a task to take on! I commend you on the effort. I've looked at all of the links to the functions and there are a few things that should be avoided:

* Function names should not have spaces in their names. If individual words need to be separated use an underscore _ .
* Function names should avoid using DarkBASIC keywords.

I actually might have a bit of time to give you some help with organizing this a bit. I'll email you at that point.

Enjoy your day.

Back to top

Profile PM

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 17th Jun 2008 23:07 Edited at: 18th Jun 2008 01:22

Link

thanks for the advice, I will change the names and update the files asap! Now that I have some time on my hands I will begin to work on testing the functions as well once I get the help files ready.

[EDIT]
Links have been updated!

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

Ed222

17

Years of Service

User Offline

Joined: 3rd Nov 2007

Location: Calgary

Posted: 18th Jun 2008 00:15

Link

Quote: "Could you post an explanation of what each of the parameters controls?"

done i edited the post above

Back to top

Profile PM Email

Latch

18

Years of Service

User Offline

Joined: 23rd Jul 2006

Location:

Posted: 26th Jul 2008 22:27

Link

@BN2
Are you still working on this? I had a little time so I worked on the math library a little bit. I'm not sure how much real interest there is in this... but anyway, is the submission criteria and email the same? I still have to come up with some syntax and descriptions so it may be another couple of days.

Enjoy your day.

Back to top

Profile PM

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 26th Jul 2008 23:06 Edited at: 26th Jul 2008 23:12

Link

yeah, still interested, just trying to get some of them finished up, mostly trying to get all of the help files created and ready to go. Thanks for the help though. Also had a little set back when I had to format my computer, fortunately had most of the work uploaded online.

Yeah submission criteria and such are the same.

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

Dark Dragon

17

Years of Service

User Offline

Joined: 22nd Jun 2007

Location: In the ring, Kickin\' *donkeybutt*.

Posted: 27th Jul 2008 02:38

Link

Pretty cool colection of functions....

JOIN THE WAVE. THE PIVO WAVE. http://pivo.proboards104.com

Back to top

Profile PM

Attila

FPSC Reloaded TGC Backer

20

Years of Service

User Offline

Joined: 17th Aug 2004

Location:

Posted: 29th Jul 2008 19:49

Link

Function to set best available screen solution

The function uses DBs checklist for display modes to determinate the 'best' available screen resolution (Where 'best' is the resolution with the most pixels). It works in DBC & DBP and can be used in the init-part of any program to overwrite the display mode set by DB.

It allows to adapt your application to any available screen format (which can be helpfull when you develop on a 4:3 screen and the user uses a 16:9 display).

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

+ Code Snippet

function SetBestScreen()
remstart
         -----------------------------------------------------------------------------

         (c) 2008 Attila

         The function will look for the highest available reolution on the system
         and set it. Highest is defined as highest number of pixels, ignoring the
         color-depth.

         the function will work in DBclassic and DBpro

         -----------------------------------------------------------------------------
remend
perform checklist for display modes
mwi=640:mhi=480:mde=16
for t=1 to checklist quantity()
   wi=checklist value a(t) :` Width
   hi=checklist value b(t) :` Height
   de=checklist value c(t) :` Depth
   if (wi*hi) > (mwi*mhi)
      mwi=wi
      mhi=hi
      mde=de
   endif
next t

set display mode mwi,mhi,mde
endfunction

Back to top

Profile PM

Latch

18

Years of Service

User Offline

Joined: 23rd Jul 2006

Location:

Posted: 18th Aug 2008 02:51

Link

@BN2

I nearly forgot about the math updates.
sent you an email

Enjoy your day.

Back to top

Profile PM

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 18th Aug 2008 02:54

Link

Thanks! I will get that one together and post it up! Thanks for the contribution too! Always appreciated!

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

NanoGamez guy

18

Years of Service

User Offline

Joined: 13th Jan 2007

Location: Closer than you think...

Posted: 18th Aug 2008 17:46 Edited at: 18th Aug 2008 20:10

Link

Here's some functions to add to your library

GUI

Dot Line

Description: This function will create a grey dotted line in between two points. You can also specify the grey you want to start with so that you can create a line that appears to be moving.

Peramiters:x1,y1,x2,y2,Grey 1[0-255],Grey 2[0-255],Start Grey[1-2]

Code:

+ Code Snippet

function DotLine(x1,y1,x2,y2,grey1,grey2,g12)

   angle#=atanfull((x2-x1),(y2-y1))
   angle#=wrapvalue((360-angle#)-270)
   d#=0
   x=x1
   y=y1

   repeat
      if g12=1 then g12=2 : ink rgb(grey1,grey1,grey1),0 else g12=1 : ink rgb(grey2,grey2,grey2),0
      d#=d#+1
      tx=cos(angle#)*d#
      ty=sin(angle#)*d#
      x=x1+tx
      y=y1+ty
      dot x,y
   until x>x2-2 and y>y2-2 and x<x2+2 and y<y2+2

endfunction

Part Cirlce

Description: This will draw part of a circle with a given start and end angle.

Peramiters: x,y,Radius,Start Angle,End Angle

Code:

+ Code Snippet

function PartCircle(x,y,radius,startc,endc)

   endc=wrapvalue(endc)
   startc=wrapvalue(startc)
   crcmfrnc=wrapvalue(endc-startc)
   if endc=startc then crcmfrnc=360

   repeat

      sofar#=sofar#+0.1

      do#=wrapvalue(do#+0.1)
      dx#=cos(do#)*radius
      dy#=sin(do#)*radius
      bx=x+dx#
      by=y+dy#

      dot bx,by

   until sofar#>=crcmfrnc

endfunction

Box Ellipse

Description: This will draw an ellipse to the screen inside a box. The standard ellipse command will take the center position and the x and y radiuses. This function takes the top left corner and bottom right corner of a box in which the ellipse will be drawn.

Peramiters: x1,y1,x2,y2

Code:

+ Code Snippet

function BoxEllipse(x1,y1,x2,y2)

   x=(x2-x1)/2+x1
   y=(y2-y1)/2+y1
   xradius=(x2-x1)/2
   yradius=(y2-y1)/2

   do#=0

   repeat

      do#=do#+0.1
      dx#=cos(do#)*xradius
      dy#=sin(do#)*yradius

      bx=x+dx#
      by=y+dy#

      dot bx,by

   until do#>=360

endfunction

Filled Box Ellipse

Description: This is the same as 'Box ellipse' but filled.

Peramiters: x1,y1,x2,y2

Code:

+ Code Snippet

function BoxEllipseFill(x1,y1,x2,y2)

   x=(x2-x1)/2+x1
   y=(y2-y1)/2+y1
   xradius=(x2-x1)/2
   yradius=(y2-y1)/2

   d#=360

   repeat

      d#=d#-0.5
      xc=cos(d#)*xradius
      ys=sin(d#)*yradius
      box x-xc,y-ys,x+xc,y+ys

   until d#<=0

endfunction

String

Shorten String

Description: This function will shorten a string to a requiered length in pixels, adding "..." after it where nessicary.

Peramiters String$,length[pixels]

Code:

+ Code Snippet

function ShortenString(string$,maxlength)

   stringlen=len(string$)
   for i=1 to stringlen
      if text width(left$(string$,i))>maxlength
         characters=i-1
         exit
      endif
   next i
   if i=stringlen
      characters=stringlen
      endstring$=left$(string$,characters)
   else
      for i=stringlen to 1 step -1
         if text width(left$(string$,i)+"...")<maxlength
            endstring$=left$(string$,i)+"..."
            exit
         endif
      next i
      if text width(string$)<maxlength
         endstring$=string$
      endif
   endif

endfunction endstring$

Highest String

Description: This will find the highest string if it were a number. This can be usefull if you are working with very long numbers and are using strings to store them. A return value of 0 means that the value of the strings are equal. A return value of 1 means that the first string is the highest and a return value of 2 means that the second string is the highest.

Peramiters: String1$,String2$

Code:

function highest(string1$,string2$)

if string1$=string2$

high=0

else

strlen1=len(string1$)
      strlen2=len(string2$)

dotplace1=0
      dotplace2=0
      for i=1 to strlen1
         if mid$(string1$,i)="."
            dotplace1=i
            exit
         endif
      next i
      for i=1 to strlen2
         if mid$(string2$,i)="."
            dotplace2=i
            exit
         endif
      next i
      if dotplace1=0
         dotplace1=strlen1+1
         string1$=string1$+".0"
      endif
      if dotplace2=0
         dotplace2=strlen2+1
         string2$=string2$+".0"
      endif
      if dotplace1<dotplace2
         for i=1 to dotplace2-dotplace1
            string1$="0"+string1$
         next i
      endif
      if dotplace2<dotplace1
         for i=1 to dotplace1-dotplace2
            string2$="0"+string2$
         next i
      endif

strlen1=len(string1$)
      strlen2=len(string2$)

if strlen1>strlen2 then highestlen=strlen1 else highestlen=strlen2

for i=1 to highestlen
         num1=val(mid$(string1$,i))
         num2=val(mid$(string2$,i))
         if num1>num2
            high=1
            exit
         endif
         if num2>num1
            high=2
            exit
         endif
      next i

endif

endfunction high

+ Code Snippet

function highest(string1$,string2$)

   if string1$=string2$

      high=0

   else

      strlen1=len(string1$)
      strlen2=len(string2$)

      dotplace1=0
      dotplace2=0
      for i=1 to strlen1
         if mid$(string1$,i)="."
            dotplace1=i
            exit
         endif
      next i
      for i=1 to strlen2
         if mid$(string2$,i)="."
            dotplace2=i
            exit
         endif
      next i
      if dotplace1=0
         dotplace1=strlen1+1
         string1$=string1$+".0"
      endif
      if dotplace2=0
         dotplace2=strlen2+1
         string2$=string2$+".0"
      endif
      if dotplace1<dotplace2
         for i=1 to dotplace2-dotplace1
            string1$="0"+string1$
         next i
      endif
      if dotplace2<dotplace1
         for i=1 to dotplace1-dotplace2
            string2$="0"+string2$
         next i
      endif

      strlen1=len(string1$)
      strlen2=len(string2$)

      if strlen1>strlen2 then highestlen=strlen1 else highestlen=strlen2

      for i=1 to highestlen
         num1=val(mid$(string1$,i))
         num2=val(mid$(string2$,i))
         if num1>num2
            high=1
            exit
         endif
         if num2>num1
            high=2
            exit
         endif
      next i

   endif

endfunction high

Day of week

Desciption: This will return the day of the week based on the day, month and year for a 2000 date.

Peramiters: Day, Month, Year

Code:

function DayofWeek(day,month,year)

if d>31 or day<1 or month>12 or month<1
      dayofweek$=""
   else
      yearnum#=val(right$(str$(year),2))
      yearnum#=yearnum#+yearnum#/4
      yearnum$=str$(yearnum#)
      for i=1 to len(yearnum$)
         if mid$(yearnum$,i)="." then exit
      next i
      if i<len(yearnum$)
         yearnum$=left$(yearnum$,i-1)
      endif
      yearnum=val(yearnum$)
      if month=5 then monthcode=0
      if month=8 then monthcode=1
      if month=2 or month=3 or month=11 then monthcode=2
      if month=6 then monthcode=3
      if month=9 or month=12 then monthcode=4
      if month=4 or month=7 then monthcode=5
      if month=1 or month=10 then monthcode=6
      total=yearnum+monthcode+day
      if total<1 or total>7
         repeat
            if total<1 then total=total+7
            if total>7 then total=total-7
         until total>=1 and total<=7
      endif
      if total=1 then dayofweek$="Monday"
      if total=2 then dayofweek$="Tuesday"
      if total=3 then dayofweek$="Wednesday"
      if total=4 then dayofweek$="Thursday"
      if total=5 then dayofweek$="Friday"
      if total=6 then dayofweek$="Saturday"
      if total=7 then dayofweek$="Sunday"
   endif

endfunction dayofweek$

+ Code Snippet

function DayofWeek(day,month,year)

   if d>31 or day<1 or month>12 or month<1
      dayofweek$=""
   else
      yearnum#=val(right$(str$(year),2))
      yearnum#=yearnum#+yearnum#/4
      yearnum$=str$(yearnum#)
      for i=1 to len(yearnum$)
         if mid$(yearnum$,i)="." then exit
      next i
      if i<len(yearnum$)
         yearnum$=left$(yearnum$,i-1)
      endif
      yearnum=val(yearnum$)
      if month=5 then monthcode=0
      if month=8 then monthcode=1
      if month=2 or month=3 or month=11 then monthcode=2
      if month=6 then monthcode=3
      if month=9 or month=12 then monthcode=4
      if month=4 or month=7 then monthcode=5
      if month=1 or month=10 then monthcode=6
      total=yearnum+monthcode+day
      if total<1 or total>7
         repeat
            if total<1 then total=total+7
            if total>7 then total=total-7
         until total>=1 and total<=7
      endif
      if total=1 then dayofweek$="Monday"
      if total=2 then dayofweek$="Tuesday"
      if total=3 then dayofweek$="Wednesday"
      if total=4 then dayofweek$="Thursday"
      if total=5 then dayofweek$="Friday"
      if total=6 then dayofweek$="Saturday"
      if total=7 then dayofweek$="Sunday"
   endif

endfunction dayofweek$

Miscellaneous

Alphabetically Sort

Description: This function will alphabetically sort an array. It requires you to create two arrays. A 'ToSort' array and a 'Sorted' array. It uses two other functions: contoalphasort$(string$), which converts a string into a number based on each character's place in the alphabet (or, if not a letter, it's ascii code), and highest(string1$,string2$), as covered in the highest string section. Because of the way the function works each entry will only be sorted to the 84th character.

Peramiters: Entries

Code:

entries=100

dim ToSort$(entries)
dim Sorted$(entries)

function Alphabetically Sort(entries)

dim converted$(entries+1)
   converted$(1)="999.999"
   for i=1 to entries
      string$=ToSort$(i)
      converted$=contoalphasort$(string$)
      foundplace=0
      for j=1 to i
         string2$=converted$(j)
         high=highest(converted$,string2$)
         if high=2
            for k=i to j+1 step-1
               Sorted$(k)=Sorted$(k-1)
               converted$(k)=converted$(k-1)
            next k
            Sorted$(j)=ToSort$(i)
            converted$(j)=converted$
            foundplace=1
            exit
         endif
      next j
      if foundplace=0
         Sorted$(j)=ToSort$(i)
         converted$(i)=converted$
      endif
   next i
   undim converted$(entries+1)

endfunction

function contoalphasort$(string$)

converted$=""

if len(string$)>84 then maxlen=84 else maxlen=len(string$)
   for i=1 to maxlen
      char$=upper$(mid$(string$,i))
      ascii=asc(char$)
      if ascii>=48 and ascii<=57 or ascii>=65 and ascii<=90 then ascii=ascii+300
      sasc$=str$(ascii)
      if len(sasc$)=1 then sasc$="00"+sasc$
      if len(sasc$)=2 then sasc$="0"+sasc$
      converted$=converted$+sasc$
   next i

if len(converted$)>3 then converted$=left$(converted$,3)+"."+right$(converted$,len(converted$)-3)

endfunction converted$

function highest(string1$,string2$)

if string1$=string2$

high=0

else

strlen1=len(string1$)
      strlen2=len(string2$)

dotplace1=0
      dotplace2=0
      for i=1 to strlen1
         if mid$(string1$,i)="."
            dotplace1=i
            exit
         endif
      next i
      for i=1 to strlen2
         if mid$(string2$,i)="."
            dotplace2=i
            exit
         endif
      next i
      if dotplace1=0
         dotplace1=strlen1+1
         string1$=string1$+".0"
      endif
      if dotplace2=0
         dotplace2=strlen2+1
         string2$=string2$+".0"
      endif
      if dotplace1<dotplace2
         for i=1 to dotplace2-dotplace1
            string1$="0"+string1$
         next i
      endif
      if dotplace2<dotplace1
         for i=1 to dotplace1-dotplace2
            string2$="0"+string2$
         next i
      endif

strlen1=len(string1$)
      strlen2=len(string2$)

if strlen1>strlen2 then highestlen=strlen1 else highestlen=strlen2

for i=1 to highestlen
         num1=val(mid$(string1$,i))
         num2=val(mid$(string2$,i))
         if num1>num2
            high=1
            exit
         endif
         if num2>num1
            high=2
            exit
         endif
      next i

endif

endfunction high

+ Code Snippet

entries=100

dim ToSort$(entries)
dim Sorted$(entries)

function Alphabetically Sort(entries)

   dim converted$(entries+1)
   converted$(1)="999.999"
   for i=1 to entries
      string$=ToSort$(i)
      converted$=contoalphasort$(string$)
      foundplace=0
      for j=1 to i
         string2$=converted$(j)
         high=highest(converted$,string2$)
         if high=2
            for k=i to j+1 step-1
               Sorted$(k)=Sorted$(k-1)
               converted$(k)=converted$(k-1)
            next k
            Sorted$(j)=ToSort$(i)
            converted$(j)=converted$
            foundplace=1
            exit
         endif
      next j
      if foundplace=0
         Sorted$(j)=ToSort$(i)
         converted$(i)=converted$
      endif
   next i
   undim converted$(entries+1)

endfunction

function contoalphasort$(string$)

   converted$=""

   if len(string$)>84 then maxlen=84 else maxlen=len(string$)
   for i=1 to maxlen
      char$=upper$(mid$(string$,i))
      ascii=asc(char$)
      if ascii>=48 and ascii<=57 or ascii>=65 and ascii<=90 then ascii=ascii+300
      sasc$=str$(ascii)
      if len(sasc$)=1 then sasc$="00"+sasc$
      if len(sasc$)=2 then sasc$="0"+sasc$
      converted$=converted$+sasc$
   next i

   if len(converted$)>3 then converted$=left$(converted$,3)+"."+right$(converted$,len(converted$)-3)

endfunction converted$

function highest(string1$,string2$)

   if string1$=string2$

      high=0

   else

      strlen1=len(string1$)
      strlen2=len(string2$)

      dotplace1=0
      dotplace2=0
      for i=1 to strlen1
         if mid$(string1$,i)="."
            dotplace1=i
            exit
         endif
      next i
      for i=1 to strlen2
         if mid$(string2$,i)="."
            dotplace2=i
            exit
         endif
      next i
      if dotplace1=0
         dotplace1=strlen1+1
         string1$=string1$+".0"
      endif
      if dotplace2=0
         dotplace2=strlen2+1
         string2$=string2$+".0"
      endif
      if dotplace1<dotplace2
         for i=1 to dotplace2-dotplace1
            string1$="0"+string1$
         next i
      endif
      if dotplace2<dotplace1
         for i=1 to dotplace1-dotplace2
            string2$="0"+string2$
         next i
      endif

      strlen1=len(string1$)
      strlen2=len(string2$)

      if strlen1>strlen2 then highestlen=strlen1 else highestlen=strlen2

      for i=1 to highestlen
         num1=val(mid$(string1$,i))
         num2=val(mid$(string2$,i))
         if num1>num2
            high=1
            exit
         endif
         if num2>num1
            high=2
            exit
         endif
      next i

   endif

endfunction high

Flood Fill

Description: This function will flood fill an array, like in 'MS Paint' with the 'Fill with Colour' function. It requires you to create an array called 'Area(width,height)'

Peramiters: Array Width,Array Height,Start x,Start y,New Value[to fill array with]

Code:

dim area(width,height)

function floodfill(width,height,x,y,newtype)

currtype=area(x,y)

dim fillx(width*height)
   dim filly(width*height)
   dim fill(width,height)

fills=1
   fillx(1)=x
   filly(1)=y
   fill(x,y)=1
   endfill=0

while endfill=0

endfill=1

fill2=fills
      for i=1 to fills
         fillx=fillx(i)
         filly=filly(i)

if fillx<width
            if fill(fillx+1,filly)=0 : rem Right
               if area(fillx+1,filly)=currtype
                  fill2=fill2+1
                  fillx(fill2)=fillx+1
                  filly(fill2)=filly
                  fill(fillx+1,filly)=1
                  endfill=0
               endif
            endif
         endif

if fillx>1
            if fill(fillx-1,filly)=0 : rem Left
               if area(fillx-1,filly)=currtype
                  fill2=fill2+1
                  fillx(fill2)=fillx-1
                  filly(fill2)=filly
                  fill(fillx-1,filly)=1
                  endfill=0
               endif
            endif
         endif

if filly>1
            if fill(fillx,filly-1)=0 : rem Up
               if area(fillx,filly-1)=currtype
                  fill2=fill2+1
                  fillx(fill2)=fillx
                  filly(fill2)=filly-1
                  fill(fillx,filly-1)=1
                  endfill=0
               endif
            endif
         endif

if filly<height
            if fill(fillx,filly+1)=0 : rem Down
               if area(fillx,filly+1)=currtype
                  fill2=fill2+1
                  fillx(fill2)=fillx
                  filly(fill2)=filly+1
                  fill(fillx,filly+1)=1
                  endfill=0
               endif
            endif
         endif
      next i
      fills=fill2

if fills>=width*height then endfill=1

endwhile

for i=1 to fills
      fillx=fillx(i)
      filly=filly(i)
      area(fillx,filly)=newtype
   next i

undim fillx(width*height)
   undim filly(width*height)
   undim fill(width,height)

endfunction

+ Code Snippet

dim area(width,height)

function floodfill(width,height,x,y,newtype)

   currtype=area(x,y)

   dim fillx(width*height)
   dim filly(width*height)
   dim fill(width,height)

   fills=1
   fillx(1)=x
   filly(1)=y
   fill(x,y)=1
   endfill=0

   while endfill=0

      endfill=1

      fill2=fills
      for i=1 to fills
         fillx=fillx(i)
         filly=filly(i)

         if fillx<width
            if fill(fillx+1,filly)=0 : rem Right
               if area(fillx+1,filly)=currtype
                  fill2=fill2+1
                  fillx(fill2)=fillx+1
                  filly(fill2)=filly
                  fill(fillx+1,filly)=1
                  endfill=0
               endif
            endif
         endif

         if fillx>1
            if fill(fillx-1,filly)=0 : rem Left
               if area(fillx-1,filly)=currtype
                  fill2=fill2+1
                  fillx(fill2)=fillx-1
                  filly(fill2)=filly
                  fill(fillx-1,filly)=1
                  endfill=0
               endif
            endif
         endif

         if filly>1
            if fill(fillx,filly-1)=0 : rem Up
               if area(fillx,filly-1)=currtype
                  fill2=fill2+1
                  fillx(fill2)=fillx
                  filly(fill2)=filly-1
                  fill(fillx,filly-1)=1
                  endfill=0
               endif
            endif
         endif

         if filly<height
            if fill(fillx,filly+1)=0 : rem Down
               if area(fillx,filly+1)=currtype
                  fill2=fill2+1
                  fillx(fill2)=fillx
                  filly(fill2)=filly+1
                  fill(fillx,filly+1)=1
                  endfill=0
               endif
            endif
         endif
      next i
      fills=fill2

      if fills>=width*height then endfill=1

   endwhile

   for i=1 to fills
      fillx=fillx(i)
      filly=filly(i)
      area(fillx,filly)=newtype
   next i

   undim fillx(width*height)
   undim filly(width*height)
   undim fill(width,height)

endfunction

A* Pathfinder

Description: This function will use the famous A* Pathfinding Algorithm to find the shortest path between two points. It requires you to create an array called 'NodeW(width,height)'(where 1 is a wall and 0 is walkable) and an array called 'Path(width,height)'(into which the path will be put).

Peramiters: Width,Height,Start x,Start y,End x,End y

Code:

Function AStarPathFinder(mapwidth,mapheight,startx,starty,endx,endy)

dim NodeOC(mapwidth,mapheight)
   dim Nodestack(mapwidth,mapheight)
   dim Openlistx(mapwidth*mapheight)
   dim Openlisty(mapwidth*mapheight)
   dim Oparentx(mapwidth*mapheight)
   dim Oparenty(mapwidth*mapheight)
   dim ONodeG(mapwidth*mapheight)
   dim ONodeH(mapwidth*mapheight)
   dim ONodeF(mapwidth*mapheight)
   dim Cparentx(mapwidth*mapheight)
   dim Cparenty(mapwidth*mapheight)
   dim CNodeG(mapwidth*mapheight)
   dim CNodeH(mapwidth*mapheight)
   dim CNodeF(mapwidth*mapheight)
   dim Closelistx(mapwidth*mapheight)
   dim Closelisty(mapwidth*mapheight)

Opens=0
   Closed=0

Opens=Opens+1
   NodeOC(startx,starty)=1
   NodeStack(startx,starty)=Opens
   Openlistx(Opens)=startx
   Openlisty(Opens)=starty
   ONodeG(Opens)=0
   ONodeH(Opens)=sqrt((startx-endx)^2+abs(starty-endy)^2)*10
   ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
   OParentx(Opens)=0
   OParenty(Opens)=0

NoPath=0
   endfound=0
   endloop=0

Node=1
   Nodex=startx
   Nodey=starty

repeat

Closed=Closed+1
      NodeOC(nodex,nodey)=2
      NodeStack(nodex,nodey)=Closed
      Closelistx(Closed)=nodex
      Closelisty(Closed)=nodey
      CNodeG(Closed)=ONodeG(Node)
      CNodeH(Closed)=ONodeH(Node)
      CNodeF(Closed)=ONodeF(Node)
      CParentx(Closed)=OParentx(Node)
      CParenty(Closed)=OParenty(Node)
      ONodeG(Node)=-1
      ONodeH(Node)=-1
      ONodeF(Node)=-1
      OParentx(Node)=-1
      OParenty(Node)=-1

if nodex=endx and nodey=endy then endfound=1

x=nodex : y=nodey-1
      if NodeW(x,y)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=10+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+10<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+10
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex+1 : y=nodey-1
      if NodeW(x,y)=0 and NodeW(nodex+1,nodey)=0 and NodeW(nodex,nodey-1)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=14+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+14<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+14
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex+1 : y=nodey
      if NodeW(x,y)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=10+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+10<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+10
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex+1 : y=nodey+1
      if NodeW(x,y)=0 and NodeW(nodex+1,nodey)=0 and NodeW(nodex,nodey+1)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=14+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+14<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+14
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex : y=nodey+1
      if NodeW(x,y)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=10+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+10<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+10
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex-1 : y=nodey+1
      if NodeW(x,y)=0 and NodeW(nodex-1,nodey)=0 and NodeW(nodex,nodey+1)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=14+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+14<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+14
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex-1 : y=nodey
      if NodeW(x,y)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=10+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+10<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+10
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex-1 : y=nodey-1
      if NodeW(x,y)=0 and NodeW(nodex-1,nodey)=0 and NodeW(nodex,nodey-1)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=14+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+14<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+14
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif

cOpen=0
      cF=1000000
      for i=1 to Opens
         if ONodeF(i)>-1
            if ONodeF(i)<cF
               cOpen=i
               cF=ONodeF(i)
            endif
         endif
      next i
      Node=cOpen
      Nodex=Openlistx(Node)
      Nodey=Openlisty(Node)
      if Node=0 and endfound=0 then noPath=1

until NoPath=1 or endfound=1

if NoPath=0
      nodex=endx
      nodey=endy
      Stack=NodeStack(nodex,nodey)
      nodex=CParentx(Stack)
      nodey=CParenty(Stack)
      repeat
         path(nodex,nodey)=1
         Stack=NodeStack(nodex,nodey)
         nodex=CParentx(Stack)
         nodey=CParenty(Stack)
      until nodex=startx and nodey=starty
   else
      cls
      Print "No Path!!!!!"
      suspend for key
   endif

undim NodeOC(mapwidth,mapheight)
   undim Nodestack(mapwidth,mapheight)
   undim Openlistx(mapwidth*mapheight)
   undim Openlisty(mapwidth*mapheight)
   undim Oparentx(mapwidth*mapheight)
   undim Oparenty(mapwidth*mapheight)
   undim ONodeG(mapwidth*mapheight)
   undim ONodeH(mapwidth*mapheight)
   undim ONodeF(mapwidth*mapheight)
   undim Cparentx(mapwidth*mapheight)
   undim Cparenty(mapwidth*mapheight)
   undim CNodeG(mapwidth*mapheight)
   undim CNodeH(mapwidth*mapheight)
   undim CNodeF(mapwidth*mapheight)
   undim Closelistx(mapwidth*mapheight)
   undim Closelisty(mapwidth*mapheight)

endfunction

+ Code Snippet

Function AStarPathFinder(mapwidth,mapheight,startx,starty,endx,endy)

   dim NodeOC(mapwidth,mapheight)
   dim Nodestack(mapwidth,mapheight)
   dim Openlistx(mapwidth*mapheight)
   dim Openlisty(mapwidth*mapheight)
   dim Oparentx(mapwidth*mapheight)
   dim Oparenty(mapwidth*mapheight)
   dim ONodeG(mapwidth*mapheight)
   dim ONodeH(mapwidth*mapheight)
   dim ONodeF(mapwidth*mapheight)
   dim Cparentx(mapwidth*mapheight)
   dim Cparenty(mapwidth*mapheight)
   dim CNodeG(mapwidth*mapheight)
   dim CNodeH(mapwidth*mapheight)
   dim CNodeF(mapwidth*mapheight)
   dim Closelistx(mapwidth*mapheight)
   dim Closelisty(mapwidth*mapheight)

   Opens=0
   Closed=0

   Opens=Opens+1
   NodeOC(startx,starty)=1
   NodeStack(startx,starty)=Opens
   Openlistx(Opens)=startx
   Openlisty(Opens)=starty
   ONodeG(Opens)=0
   ONodeH(Opens)=sqrt((startx-endx)^2+abs(starty-endy)^2)*10
   ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
   OParentx(Opens)=0
   OParenty(Opens)=0

   NoPath=0
   endfound=0
   endloop=0

   Node=1
   Nodex=startx
   Nodey=starty

   repeat

      Closed=Closed+1
      NodeOC(nodex,nodey)=2
      NodeStack(nodex,nodey)=Closed
      Closelistx(Closed)=nodex
      Closelisty(Closed)=nodey
      CNodeG(Closed)=ONodeG(Node)
      CNodeH(Closed)=ONodeH(Node)
      CNodeF(Closed)=ONodeF(Node)
      CParentx(Closed)=OParentx(Node)
      CParenty(Closed)=OParenty(Node)
      ONodeG(Node)=-1
      ONodeH(Node)=-1
      ONodeF(Node)=-1
      OParentx(Node)=-1
      OParenty(Node)=-1

      if nodex=endx and nodey=endy then endfound=1

      x=nodex : y=nodey-1
      if NodeW(x,y)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=10+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+10<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+10
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex+1 : y=nodey-1
      if NodeW(x,y)=0 and NodeW(nodex+1,nodey)=0 and NodeW(nodex,nodey-1)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=14+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+14<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+14
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex+1 : y=nodey
      if NodeW(x,y)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=10+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+10<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+10
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex+1 : y=nodey+1
      if NodeW(x,y)=0 and NodeW(nodex+1,nodey)=0 and NodeW(nodex,nodey+1)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=14+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+14<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+14
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex : y=nodey+1
      if NodeW(x,y)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=10+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+10<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+10
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex-1 : y=nodey+1
      if NodeW(x,y)=0 and NodeW(nodex-1,nodey)=0 and NodeW(nodex,nodey+1)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=14+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+14<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+14
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex-1 : y=nodey
      if NodeW(x,y)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=10+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+10<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+10
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif
      x=nodex-1 : y=nodey-1
      if NodeW(x,y)=0 and NodeW(nodex-1,nodey)=0 and NodeW(nodex,nodey-1)=0
         if NodeOC(x,y)=0
            NodeOC(x,y)=1
            Opens=Opens+1
            NodeStack(x,y)=Opens
            Openlistx(Opens)=x
            Openlisty(Opens)=y
            ONodeG(Opens)=14+CNodeG(closed)
            ONodeH(Opens)=sqrt((x-endx)^2+abs(y-endy)^2)*10
            ONodeF(Opens)=ONodeG(Opens)+ONodeH(Opens)
            OParentx(Opens)=nodex
            OParenty(Opens)=nodey
         else
            if NodeOC(x,y)=1
               Stack=NodeStack(x,y)
               if CNodeG(Closed)+14<ONodeG(Stack)
                  ONodeG(Stack)=CNodeG(Closed)+14
                  ONodeF(Stack)=ONodeG(Stack)+ONodeH(Stack)
                  OParentx(Stack)=nodex
                  OParenty(Stack)=nodey
               endif
            endif
         endif
      endif

      cOpen=0
      cF=1000000
      for i=1 to Opens
         if ONodeF(i)>-1
            if ONodeF(i)<cF
               cOpen=i
               cF=ONodeF(i)
            endif
         endif
      next i
      Node=cOpen
      Nodex=Openlistx(Node)
      Nodey=Openlisty(Node)
      if Node=0 and endfound=0 then noPath=1

   until NoPath=1 or endfound=1

   if NoPath=0
      nodex=endx
      nodey=endy
      Stack=NodeStack(nodex,nodey)
      nodex=CParentx(Stack)
      nodey=CParenty(Stack)
      repeat
         path(nodex,nodey)=1
         Stack=NodeStack(nodex,nodey)
         nodex=CParentx(Stack)
         nodey=CParenty(Stack)
      until nodex=startx and nodey=starty
   else
      cls
      Print "No Path!!!!!"
      suspend for key
   endif

   undim NodeOC(mapwidth,mapheight)
   undim Nodestack(mapwidth,mapheight)
   undim Openlistx(mapwidth*mapheight)
   undim Openlisty(mapwidth*mapheight)
   undim Oparentx(mapwidth*mapheight)
   undim Oparenty(mapwidth*mapheight)
   undim ONodeG(mapwidth*mapheight)
   undim ONodeH(mapwidth*mapheight)
   undim ONodeF(mapwidth*mapheight)
   undim Cparentx(mapwidth*mapheight)
   undim Cparenty(mapwidth*mapheight)
   undim CNodeG(mapwidth*mapheight)
   undim CNodeH(mapwidth*mapheight)
   undim CNodeF(mapwidth*mapheight)
   undim Closelistx(mapwidth*mapheight)
   undim Closelisty(mapwidth*mapheight)

endfunction

Phew! That took a while!

On the other hand, you have different fingers.

Back to top

Profile PM Email Website

Dark Dragon

17

Years of Service

User Offline

Joined: 22nd Jun 2007

Location: In the ring, Kickin\' *donkeybutt*.

Posted: 18th Aug 2008 19:12

Link

whoa! a*.

cool.

Your signature has been erased by a mod - Please reduce it to 600x120 maximum size

Back to top

Profile PM

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 21st Aug 2008 09:00 Edited at: 21st Aug 2008 09:26

Link

Wow, thanks for that nano, thats awesome! Looks like I will have to make some new library files.

Just one question, how do you use the A* pathfinding command. Do you call it in a loop? Or do you call it once and read data from the path array?

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

NanoGamez guy

18

Years of Service

User Offline

Joined: 13th Jan 2007

Location: Closer than you think...

Posted: 21st Aug 2008 12:08

Link

You call it once and then read the path array, however, if you want, I could make one that does call in a loop.

On the other hand, you have different fingers.

Back to top

Profile PM Email Website

Robert The Robot

18

Years of Service

User Offline

Joined: 8th Jan 2007

Location: Fireball XL5

Posted: 22nd Aug 2008 14:24 Edited at: 23rd Aug 2008 12:04

Link

Hi guys, I haven't posted here before but I wondered if you'd be interested in a Medialess file browser for the GUI Library.

There are two functions:
Prepare_File_Browser(FirstImage)
This creates the 26 images used by the browser function, and requires one free bitmap to run. This function can take around a second to execute (the get image command is quite slow) although I have found that be calling "Sync On : Sync" before this function, the time is much less (around 0.05 of a second). I would be interested to know if this works for other people, and not just on my computer.

Browse_Files(FirstImage, BackdropImg, PointerImg, StartDir$, BrowserType, Caption$, Bx, By, MaxFiles, FileType$, CustomFile$, LeftMouse)
This function takes several parameters, and again requires one free bitmap to run.
FirstImage: The number you used when calling Prepare_File_Browser

BackdropImg: This is the image number of whatever image you wish to place at 0,0 on the screen - the browser will be drawn on top of this, allowing you to preserve the background. Specify a value of 0 to not draw any backdrop image.

PointerImg: This is the image number of whatever image you are currently using as a mouse pointer. Specify a value of 0 to display DBC's default mouse pointer.

StartDir$: Specify "" to make the browser start in the current working directory, otherwise you can specify a particular startup directory (e.g. "C:/Program Files") If the path does not exist, the browser will switch to the current working directory.

BrowserType: Specify 0 to call an Open File browser, or 1 to call a Save-as browser. The two operate in similar manners, but Save-as adds a textbox to allow the user to type a filename.

Caption$: This is the message displayed at the top of the file browser.

Bx, By: These define the X and Y screen coordinates of the file browser. Unlike Windows browsers, this browser cannot be moved by clicking and dragging the titlebar, so these values remain fixed.

MaxFiles: This parameter lets you set how many files anfd folders will be returned. A typical value for this would be 1000, but if you find random files appear to be "missing" from the browser list, try increasing the number.

FileType$: This lets you determine just which files get returned. Specify "3d" to serach for .x or .3ds files, "img" for .bmp .dds .dib .jpg .pcx .png .psd .rle .tga .tif files, "aud" to search for .wav .mp3 .mid, or "vid" to search for .avi files.

CustomFile$: If you set FileType$ to any of the defaults, leave this parameter as "". If, however, you wish to search for your own filetypes then FileType$ and CustomFile$ take on new roles. For example, set CustomFile$ to ".x.3ds.dds" and FileType$ to "5.6.7". This will make the browser search for .x, .3ds and .dds files. The browser will use image 5 as the icon for .x files, image 6 for .3ds files and image 7 for .dds files. You may specify up to 8 file types like this, but you must also specify an image number for each filetype, and it is important that both strings do not contain any additional characters. In case you want to use the default icons for a particular filetype, the list at the start of the Prepare_File_Browser function will tell you where they can be found.

LeftMouse: Specify a value of 1 to make the Left mouse button the defualt button, or 2 to set the right mouse button as default.

The function returns the name of the file selected, or (in the case of the save-as browser)the filename the user typed.

Hope this is of some use!

[Edit]The was a problem uploading the source code in a code snippet, so I've attached a Zip file containing the source code. It's just one .dba file, but there's also a sample program at the start to call and run the browser.

"I wish I was a spaceman, the fastest guy alive. I'd fly you round the universe, in Fireball XL5..."

Attachments

Login to view attachments

Back to top

Profile PM Website

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 22nd Aug 2008 20:43

Link

Thats really cool Nano! Ran into a couple errors though. The .. file doesn't seem to change the folder. Also, when I try to do the custom file type, it gives me an error saying that images range from 1 to 160000. I used:
FileType$=".dba"
CustomFile$="10"

Other than that, works great!

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

NanoGamez guy

18

Years of Service

User Offline

Joined: 13th Jan 2007

Location: Closer than you think...

Posted: 22nd Aug 2008 21:07

Link

I think you mean Robert

On the other hand, you have different fingers.

Back to top

Profile PM Email Website

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 22nd Aug 2008 23:15

Link

OOPS! Sorry Robert, saw Nano's sig right above the post and for some reason though nano posted it!

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

Robert The Robot

18

Years of Service

User Offline

Joined: 8th Jan 2007

Location: Fireball XL5

Posted: 23rd Aug 2008 11:28 Edited at: 23rd Aug 2008 12:06

Link

Don't worry, I don't mind

To solve the image error, you need to swap FileType$ and CustomFile$ around, like this:
FileType$="10"
CustomFile$=".dba"

Not sure what's going on with the ".." folder not working, I'll have a look later today and post back.

[Edit]I've found the problem - every back slash gets removed when I post. I've attached the original .dba source code to my first post, and I hope that this time it works!

"I wish I was a spaceman, the fastest guy alive. I'd fly you round the universe, in Fireball XL5..."

Back to top

Profile PM Website

Latch

18

Years of Service

User Offline

Joined: 23rd Jul 2006

Location:

Posted: 24th Aug 2008 05:25

Link

@BN2

Quote: "Thanks! I will get that one together and post it up! Thanks for the contribution too! Always appreciated!"

Was this acknowledgment of actually receiving the email?

Enjoy your day.

Back to top

Profile PM

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 24th Aug 2008 09:46

Link

Yeah it was.

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

Robert The Robot

18

Years of Service

User Offline

Joined: 8th Jan 2007

Location: Fireball XL5

Posted: 9th Sep 2008 19:25 Edited at: 9th Sep 2008 19:27

Link

Hi guys, I've been working on some more functions, I don't know if you're interested:

First I'd like to offer a corrected version of my file browser - there was a minor flaw, with the scrollbar not quite reaching the bottom when the final files were displayed. I've also changed it so that the scrollbar vanishes when there are more than 600 files or folders in the directory (too many more and the scrollbar would be less than a pixel high!). In the unlikely event that you ever see this happen, you'll need to use the Up/Down buttons to scroll through the files.

After the problems that arose when posting the file browser code as a code snippet, I've attached the dba file to this post.

Now, some more functions:

3d Object Library

Particles
I can't take all the credit for these functions, most of the code for the create- and update- routines was taken from the DBC Particle Bombs example program. However, the introduction of arrays to allow for more than one set of particles was my own work, along with the controls over the visual properties and auto-respawn.

The following functions require these commands to be placed at the top of your code:

+ Code Snippet

rem Specify how many sets of particles you will be creating (min. one):
Particles = 
Dim ParticleConstants#(Particles, 13)
Dim ParticleVariables#(Particles, 1000, 3)

Create_Particles

Function Create_Particles(Particle, FirstObj, NumParticles, Texture, xSize#, ySize#, x#, y#, z#, xVel#, yVel#, zVel#, MinLife, MaxLife)
   If NumParticles>1000 then NumParticles = 1000
   If NumParticles<0 then NumParticles = 1

rem Create plains
   For T=0 to NumParticles - 1
      Make Object Plain FirstObj + T, xSize#, ySize#
      Texture Object FirstObj + T, Texture
      Set Object FirstObj+T, 1, 0, 1
   Next T

rem Adjust particle velocities
   xVel# = 100.00 * xVel#
   yVel# = 100.00 * yVel#
   zVel# = 100.00 * zVel#

rem Store Particle data
   ParticleConstants#(Particle, 0) = FirstObj
   ParticleConstants#(Particle, 1) = NumParticles
   ParticleConstants#(Particle, 2) = x#
   ParticleConstants#(Particle, 3) = y#
   ParticleConstants#(Particle, 4) = z#
   ParticleConstants#(Particle, 5) = MinLife
   ParticleConstants#(Particle, 6) = MaxLife
   ParticleConstants#(Particle, 7) = xVel#
   ParticleConstants#(Particle, 8) = yVel#
   ParticleConstants#(Particle, 9) = zVel#
   ParticleConstants#(Particle, 10) = 0.01 : rem Gravity
   ParticleConstants#(Particle, 11) = 0.95 : rem Friction
   ParticleConstants#(Particle, 12) = 0    : rem Bounce rate
   ParticleConstants#(Particle, 13) = 0    : rem Particle Floor

`ParticleVariables#(Particle, P, 0) = xVel#
`ParticleVariables#(Particle, P, 1) = yVel#
`ParticleVariables#(Particle, P, 2) = zVel#
`ParticleVariables#(Particle, P, 3) = Particle Life

rem Set variables
   For T = 1 to ParticleConstants#(ParticleNum, 1)
      rem Set Life
      ParticleVariables#(Particle, T, 3) = ParticleConstants#(Particle, 5) + rnd(ParticleConstants#(Particle, 6) - ParticleConstants#(Particle, 5))

rem Set velocity
      ParticleVariables#(Particle, T, 0) = (rnd(xVel#)-(xVel#/2))/100
      ParticleVariables#(Particle, T, 1) = (rnd(yVel#)-(yVel#/2))/100
      ParticleVariables#(Particle, T, 2) = (rnd(zVel#)-(zVel#/2))/100

Position Object ParticleConstants#(Particle, 0) + (T-1), ParticleConstants#(Particle, 2), ParticleConstants#(Particle, 3), ParticleConstants#(Particle, 4)
   Next T
EndFunction

+ Code Snippet

Function Create_Particles(Particle, FirstObj, NumParticles, Texture, xSize#, ySize#, x#, y#, z#, xVel#, yVel#, zVel#, MinLife, MaxLife)
   If NumParticles>1000 then NumParticles = 1000
   If NumParticles<0 then NumParticles = 1

   rem Create plains
   For T=0 to NumParticles - 1
      Make Object Plain FirstObj + T, xSize#, ySize#
      Texture Object FirstObj + T, Texture
      Set Object FirstObj+T, 1, 0, 1
   Next T

   rem Adjust particle velocities
   xVel# = 100.00 * xVel#
   yVel# = 100.00 * yVel#
   zVel# = 100.00 * zVel#

   rem Store Particle data
   ParticleConstants#(Particle, 0) = FirstObj
   ParticleConstants#(Particle, 1) = NumParticles
   ParticleConstants#(Particle, 2) = x#
   ParticleConstants#(Particle, 3) = y#
   ParticleConstants#(Particle, 4) = z#
   ParticleConstants#(Particle, 5) = MinLife
   ParticleConstants#(Particle, 6) = MaxLife
   ParticleConstants#(Particle, 7) = xVel#
   ParticleConstants#(Particle, 8) = yVel#
   ParticleConstants#(Particle, 9) = zVel#
   ParticleConstants#(Particle, 10) = 0.01 : rem Gravity
   ParticleConstants#(Particle, 11) = 0.95 : rem Friction
   ParticleConstants#(Particle, 12) = 0    : rem Bounce rate
   ParticleConstants#(Particle, 13) = 0    : rem Particle Floor

`ParticleVariables#(Particle, P, 0) = xVel#
`ParticleVariables#(Particle, P, 1) = yVel#
`ParticleVariables#(Particle, P, 2) = zVel#
`ParticleVariables#(Particle, P, 3) = Particle Life

   rem Set variables
   For T = 1 to ParticleConstants#(ParticleNum, 1)
      rem Set Life
      ParticleVariables#(Particle, T, 3) = ParticleConstants#(Particle, 5) + rnd(ParticleConstants#(Particle, 6) - ParticleConstants#(Particle, 5))

      rem Set velocity
      ParticleVariables#(Particle, T, 0) = (rnd(xVel#)-(xVel#/2))/100
      ParticleVariables#(Particle, T, 1) = (rnd(yVel#)-(yVel#/2))/100
      ParticleVariables#(Particle, T, 2) = (rnd(zVel#)-(zVel#/2))/100

      Position Object ParticleConstants#(Particle, 0) + (T-1), ParticleConstants#(Particle, 2), ParticleConstants#(Particle, 3), ParticleConstants#(Particle, 4)
   Next T
EndFunction

Particle: A 'slot' number, pointing to a location in the required arrays so that the particle data can be accessed.
FirstObj: The first object used by the particle set
NumParticles: This is the number of particles that will be created - e.g. Say FirstObj = 5 and Numparticles = 20, Objects will be created from slots 5 up to (but not including) 25.
Texture: The image number used to texture each particle.
xSize#, ySize#: The width and height of each particle (all particles are plains).
x#, y#, z#: The location in 3d space of the particle source.
xVel#, yVel#, zVel#: 2* the max distance each particle will move along the coordinate axes. Please try and ensure that each value is >=0.01, or the particles may all clump together as the Rnd command fails. The function doesn't automatically adjust these values, as it can be an interesting effect.
MinLife, MaxLife: Every particle will survive for at least MinLife screen refreshes, but may survive for as long as MaxLife refreshes.

Update_Particles

Function Update_Particles(Particle, AutoRespawn, Rotation)
   For T = 1 to Int(ParticleConstants#(Particle, 1))
      Obj = ParticleConstants#(Particle, 0) + (T-1)

If ParticleVariables#(Particle, T, 3)>1
         rem Decrease life
         ParticleVariables#(Particle, T, 3) = ParticleVariables#(Particle, T, 3) - 1

rem calculate friction
         ParticleVariables#(Particle, T, 0) = ParticleVariables#(Particle, T, 0) * ParticleConstants#(Particle, 11)
         ParticleVariables#(Particle, T, 1) = ParticleVariables#(Particle, T, 1) * ParticleConstants#(Particle, 11)
         ParticleVariables#(Particle, T, 2) = ParticleVariables#(Particle, T, 2) * ParticleConstants#(Particle, 11)

rem and gravity...
         ParticleVariables#(Particle, T, 1) = ParticleVariables#(Particle, T, 1) - ParticleConstants#(Particle, 10)

rem Main velocity
         xPos# = Object Position X(Obj) + ParticleVariables#(Particle, T, 0)
         yPos# = Object Position Y(Obj) + ParticleVariables#(Particle, T, 1)
         zPos# = Object Position Z(Obj) + ParticleVariables#(Particle, T, 2)

rem Bouncing when it hits the floor
         If ParticleConstants#(Particle, 13) >0
            If yPos#<=0 then ParticleVariables#(Particle, T, 1) = ParticleVariables#(Particle, T, 1) * ParticleConstants#(Particle, 12)
         endif

rem Rotate Particles
         If Rotation = 1
            Rotate Object Obj, wrapvalue(object angle x(Obj)+rnd(50)), wrapvalue(object angle y(Obj)+rnd(50)), wrapvalue(object angle Z(Obj)+rnd(50))
         endif

If Rotation = 2
            Set Object To Camera Orientation Obj
         endif

Position object Obj, xPos#, yPos#, zPos#
      else
         rem Particle life = 1, handle respawn

If AutoRespawn = 1
            rem New particle velocity
            ParticleVariables#(Particle, T, 0) = (rnd(ParticleConstants#(Particle, 7)) - (ParticleConstants#(Particle, 7)/2))/100
            ParticleVariables#(Particle, T, 1) = (rnd(ParticleConstants#(Particle, 8)) - (ParticleConstants#(Particle, 8)/2))/100
            ParticleVariables#(Particle, T, 2) = (rnd(ParticleConstants#(Particle, 9)) - (ParticleConstants#(Particle, 9)/2))/100

rem Calculate new life
            ParticleVariables#(Particle, T, 3) = ParticleConstants#(Particle, 5) + rnd(ParticleConstants#(Particle, 6) - ParticleConstants#(Particle, 5))

rem Reposition
            xPos# = ParticleConstants#(Particle, 2) + ParticleVariables#(Particle, T, 0)
            yPos# = ParticleConstants#(Particle, 3) + ParticleVariables#(Particle, T, 1)
            zPos# = ParticleConstants#(Particle, 4) + ParticleVariables#(Particle, T, 2)
            Position object Obj, xPos#, yPos#, zPos#

else
            ParticleVariables#(Particle, T, 3) = 0
            Hide Object Obj
         endif
      endif
   Next T
EndFunction

+ Code Snippet

Function Update_Particles(Particle, AutoRespawn, Rotation)
   For T = 1 to Int(ParticleConstants#(Particle, 1))
      Obj = ParticleConstants#(Particle, 0) + (T-1)

      If ParticleVariables#(Particle, T, 3)>1
         rem Decrease life
         ParticleVariables#(Particle, T, 3) = ParticleVariables#(Particle, T, 3) - 1

         rem calculate friction
         ParticleVariables#(Particle, T, 0) = ParticleVariables#(Particle, T, 0) * ParticleConstants#(Particle, 11)
         ParticleVariables#(Particle, T, 1) = ParticleVariables#(Particle, T, 1) * ParticleConstants#(Particle, 11)
         ParticleVariables#(Particle, T, 2) = ParticleVariables#(Particle, T, 2) * ParticleConstants#(Particle, 11)

         rem and gravity...
         ParticleVariables#(Particle, T, 1) = ParticleVariables#(Particle, T, 1) - ParticleConstants#(Particle, 10)

         rem Main velocity
         xPos# = Object Position X(Obj) + ParticleVariables#(Particle, T, 0)
         yPos# = Object Position Y(Obj) + ParticleVariables#(Particle, T, 1)
         zPos# = Object Position Z(Obj) + ParticleVariables#(Particle, T, 2)


         rem Bouncing when it hits the floor
         If ParticleConstants#(Particle, 13) >0
            If yPos#<=0 then ParticleVariables#(Particle, T, 1) = ParticleVariables#(Particle, T, 1) * ParticleConstants#(Particle, 12)
         endif

         rem Rotate Particles
         If Rotation = 1
            Rotate Object Obj, wrapvalue(object angle x(Obj)+rnd(50)), wrapvalue(object angle y(Obj)+rnd(50)), wrapvalue(object angle Z(Obj)+rnd(50))
         endif

         If Rotation = 2
            Set Object To Camera Orientation Obj
         endif


         Position object Obj, xPos#, yPos#, zPos#
      else
         rem Particle life = 1, handle respawn

         If AutoRespawn = 1
            rem New particle velocity
            ParticleVariables#(Particle, T, 0) = (rnd(ParticleConstants#(Particle, 7)) - (ParticleConstants#(Particle, 7)/2))/100
            ParticleVariables#(Particle, T, 1) = (rnd(ParticleConstants#(Particle, 8)) - (ParticleConstants#(Particle, 8)/2))/100
            ParticleVariables#(Particle, T, 2) = (rnd(ParticleConstants#(Particle, 9)) - (ParticleConstants#(Particle, 9)/2))/100

            rem Calculate new life
            ParticleVariables#(Particle, T, 3) = ParticleConstants#(Particle, 5) + rnd(ParticleConstants#(Particle, 6) - ParticleConstants#(Particle, 5))

            rem Reposition
            xPos# = ParticleConstants#(Particle, 2) + ParticleVariables#(Particle, T, 0)
            yPos# = ParticleConstants#(Particle, 3) + ParticleVariables#(Particle, T, 1)
            zPos# = ParticleConstants#(Particle, 4) + ParticleVariables#(Particle, T, 2)
            Position object Obj, xPos#, yPos#, zPos#

         else
            ParticleVariables#(Particle, T, 3) = 0
            Hide Object Obj
         endif
      endif
   Next T
EndFunction

Particle: As before, a 'slot' number pointing to a location in the required arrays.
AutoRespawn: Set to 0 to create a 'firework' effect where the particles slowly die away. Set to 1 to have a new particle created as soon as an old particle dies. The new particle's movement is governed according to the original parameters (life, velocity, gravity, friction, bounce height) but is located at the center of the particles.
Rotation: Set to 0 to have all the particles pointing to 0,0,0 (as they were created). Set to 1 to have all particles spinning randomly on all three axes. Set to 2 to have the particles always pointing towards the camera.

Important - this function must be called once every program loop, otherwise the particles will freeze (which could be a bad thing if you're modelling a flame

)

Position_Particle_Source

+ Code Snippet

Function Position_Particle_Source(Particle, x#, y#, z#)
   ParticleConstants#(Particle, 2) = x#
   ParticleConstants#(Particle, 3) = y#
   ParticleConstants#(Particle, 4) = z#
EndFunction

Particle: As before, a 'slot' number pointing to a location in the required arrays.
x#,y#,z#: Change these before updating the particles. All new particles (i.e those that get respawned) will start from this position in 3d space. Existing particles are unaffected, so it allows you to create a vapour trail of exhaust fumes.

Set_Particle_Velocity

+ Code Snippet

Function Set_Particle_Velocity(xVel#, yVel#, zVel#)
   ParticleConstants#(Particle, 7) = xVel#
   ParticleConstants#(Particle, 8) = yVel#
   ParticleConstants#(Particle, 9) = zVel#
EndFunction

Particle: As before, a 'slot' number pointing to a location in the required arrays.
xVel#,yVel#,zVel#: Change these before updating the particles. All new particles (i.e those that get respawned) will start with this new velocity, but existing particles are unaffected.

Set_Particle_Life

+ Code Snippet

Function Set_Particle_Life(MinLife, MaxLife)
   ParticleConstants#(Particle, 5) = MinLife
   ParticleConstants#(Particle, 6) = MaxLife
EndFunction

Particle: As before, a 'slot' number pointing to a location in the required arrays.
MinLife, MaxLife: This allows you to specify new lifetimes for particles as they get respawned.

Set_Particle_Friction

+ Code Snippet

Function Set_Particle_Friction(Particle, Friction#)
   ParticleConstants#(Particle, 11) = Friction#
EndFunction

Particle: As before, a 'slot' number pointing to a location in the required arrays.
Friction#: This allows you to apply a constant force on the particles. Specify a value <1 to slow down the particles, or a value >1 to speed up the particles. A value of 1 will do nothing. By default the friction is set to 0.95 (so every screen update, the particles velocity falls to 95% of the value at the previous loop. If it lives long enough it will eventually grind to a halt)

Set_Particle_Gravity

+ Code Snippet

Function Set_Particle_Gravity(Particle, Gravity#)
   ParticleConstants#(Particle, 10) = Gravity#
EndFunction

Particle: As before, a 'slot' number pointing to a location in the required arrays.
Friction#: This allows you to apply a constant downward force on the particles. Specify a negative value to produce antigravity and make the particle float up. By default, gravity is 0.01.

Enable/Disable Particle Floor

+ Code Snippet

Function Enable_Particle_Floor(Particle)
   ParticleConstants#(Particle, 13) = 1
EndFunction

Function Disable_Particle_Floor(Particle)
   ParticleConstants#(Particle, 13) = 0
EndFunction

Particle: As before, a 'slot' number pointing to a location in the required arrays.
Use these two commands to create a floor at height y = 0. If the particles strike this floor, they will bounce. By default, the floor is disabled.

Set_Particle_Bounce

+ Code Snippet

Function Set_Particle_Bounce(Particle, BounceHeight#)
   ParticleConstants#(Particle, 12) = BounceHeight#
   ParticleConstants#(Particle, 13) = 1
EndFunction

Particle: As before, a 'slot' number pointing to a location in the required arrays.
BounceHeight#: This allows you control over how high the particle rebounds. By default the value is zero (and the particle is prevented from bouncing).

So, there you have it. I hope these functions are of some use. (Actually, if you are interested, it wouldn't be too hard to knock up a few extra functions giving you the ability to hide/show particles, set visual effects, etc. Unless I'm misunderstanding how DBPro and GDk work, I think it might be possible to have a particle system with far more commands than they've got!)

"I wish I was a spaceman, the fastest guy alive. I'd fly you round the universe, in Fireball XL5..."

Attachments

Login to view attachments

Back to top

Profile PM Website

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 9th Sep 2008 19:52

Link

Wow, nice! Lol, still trying to get on top of all the functions.

Thank you!

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

Robert The Robot

18

Years of Service

User Offline

Joined: 8th Jan 2007

Location: Fireball XL5

Posted: 9th Sep 2008 21:06

Link

You're welcome!

"I wish I was a spaceman, the fastest guy alive. I'd fly you round the universe, in Fireball XL5..."

Back to top

Profile PM Website

Robert The Robot

18

Years of Service

User Offline

Joined: 8th Jan 2007

Location: Fireball XL5

Posted: 15th Sep 2008 17:15 Edited at: 16th Sep 2008 21:04

Link

I've been adding to my particle commands, and they're now up to 33 functions! (DBA file attached

)

There are a lot of visual commands which handle just like "Set Object" or "Set Object Diffuse", the only diference being that the function changes the word "Object" to "Particle". The new "Ghost_Particles_on" command is one of my favourites, but it's crippling on the system when applied to more than about 500 particles! (And that's not taking into account any other scenery)

I've added in a "reignite_particles" command. If ever you call "Update_Particles" and choose not to respawn (so the particle behaves like a firework), the particles would "explode" and then remain dead forever. I found it a bit tricky to recycle the particles and allow the "firework" to be set off again, so I created this new function to reactivate the particles. This function can be called at any time - it will find any dead particles in the group, make them alive and recalculate their position/velocity/life so "Update_Particles" will handle them again.

There have been a few changes to "Create_Particles" and "Update_Particles" since I posted them last time, and the required arrays have now changed slightly to:

rem Set "Particles" to be the number of particle groups you wish to create
Particles = 1
Dim ParticleConstants#(Particles, 15)
Dim ParticleVariables#(Particles, 1000, 3)

You see, I was trying to add in a "rotate particles" command like the one in GDK - I failed miserably, but my tinkering with the Update_Particles command led me to define two particle types - "Omni" and "Vector". Omni is like a dandelion seed head, with particles being flung off in all directions based on the specified velocity components:

Vector allows you to use positive and negative velocities, and have all the particles move in a particular direction:

You can specify which type of particles you want when you call "Create_Particles", there's a new parameter tacked on at the end called "VelType". (0 for Omni, 1 for Vector).

So, I think that's it - I'm not aware of having modified any other commands, but it might be safer if you just ignored the ones I sent last time and started again with this new set (Don't worry if you've been adding them to the help files, virtually nothing has changed in the parameters).

Regards
Robert the Robot

[Edit]
Since writing the above, I've had an e-mail asking for some demos of the particle system. These have been added to the functions Zip file, although not all commands are showcased.

I've also spotted a couple of embarassing goofs (two of the functions didn't include "Particle" as a parmeter), and corrected them. There are two new commands - "Delete_Particles" to let you remove a particles object, and "Particles_Exist" which handles like "Object Exist". Every function has now been modified to check that the particles group exists before doing anything.

I feel rather bad about this third revision, I keep posting functions here that have glitches (although I do at least manage to correct them in the end). Sorry BN2!

"I wish I was a spaceman, the fastest guy alive. I'd fly you round the universe, in Fireball XL5..."

Attachments

Login to view attachments

Back to top

Profile PM Website

Latch

18

Years of Service

User Offline

Joined: 23rd Jul 2006

Location:

Posted: 20th Nov 2008 16:24

Link

This particle library is really great. I\\\'m using it to display different details of an interior Sparky\\\'s Collision Demo I was putting together. Here\\\'s a screeny. Though hard to tell exactly what\\\'s going on you can see a cascade of orange sparks (from the particle library) as a result of a bullet hitting the wall. Attachment...

Enjoy your day.

Attachments

Login to view attachments

Back to top

Profile PM

Robert The Robot

18

Years of Service

User Offline

Joined: 8th Jan 2007

Location: Fireball XL5

Posted: 20th Nov 2008 17:35

Link

Wow, that looks good! Very nice use of the particle functions, Latch!

@BN2
Just wondering, how are the community function libraries coming?

"I wish I was a spaceman, the fastest guy alive. I'd fly you round the universe, in Fireball XL5..."

Back to top

Profile PM Website

BN2 Productions

21

Years of Service

User Offline

Joined: 22nd Jan 2004

Location:

Posted: 21st Nov 2008 08:24

Link

Been extremely busy for the last few MONTHS between school and work. Haven't made any significant progress unfortunately.

Ever notice how in Microsoft word, the word "microsoft" is auto corrected to be "Microsoft" but "macintosh" just gets the dumb red underline?

Back to top

Profile PM

Sorry your browser is not supported!

DarkBASIC Discussion / Community Function Libraries V. 1 Beta

Attachments

Attachments

Attachments

Attachments