## Anyone have good code for making a Priority Queue?

General FreeBASIC programming questions.
leopardpm
Posts: 1795
Joined: Feb 28, 2009 20:58

### Re: Anyone have good code for making a Priority Queue?

grindstone wrote:Another question: Are there negative values?

nope... the values I am dealing with are TIMER values... so Doubles and positive

if doing Doubles is too slow, then I guess could convert TIMER to an integer (Timer * 10000) to get 1/10 of a millisecond steps
grindstone
Posts: 737
Joined: May 05, 2015 5:35
Location: Germany

### Re: Anyone have good code for making a Priority Queue?

Alright, here's my 2nd attempt, a 5 level binary tree. Not completed yet, but already enough to play around with:

Code: Select all

`Type tEndNode   As Integer frontX = 0   As Integer frontY = 0   As Boolean valid = FALSEEnd TypeType tPathNode   As tPathNode Ptr child(0 To 255)End TypeType tPreEndNode   As tEndNode Ptr child(0 To 255)End TypeDim As tPathNode Ptr frontier = New tPathNode 'create root nodeSub FrontierAdd(fp As tPathNode Ptr, _                 ByVal frontX As Integer, _                 ByVal frontY As Integer, _                 ByVal frontCost As Integer)   Dim As tEndNode Ptr fpe   Dim As String*5 f = Mki(frontCost), g   Dim As Integer fc      'MSB   If fp->child(f[3]) = 0 Then      fp->child(f[3]) = New tPathNode   EndIf      If fp->child(f[3])->child(f[2]) = 0 Then      fp->child(f[3])->child(f[2]) = New tPathNode   EndIf      If fp->child(f[3])->child(f[2])->child(f[1]) = 0 Then      Cast(tPreEndNode Ptr, fp->child(f[3])->child(f[2])->child(f[1])) = New tPreEndNode   EndIf      'LSB   If fp->child(f[3])->child(f[2])->child(f[1])->child(f[0]) = 0 Then      Cast(tEndNode Ptr, fp->child(f[3])->child(f[2])->child(f[1])->child(f[0])) = New tEndNode   EndIf      fpe = Cast(tEndNode Ptr, fp->child(f[3])->child(f[2])->child(f[1])->child(f[0]))   fpe->frontX = frontX   fpe->frontY = frontY   fpe->valid  = TRUE      End SubSub FrontierList(fp As tPathNode Ptr, frontCost As Integer = 0, level As Integer = 0)   Dim As tEndNode Ptr fpe   Dim As String*5 fs   Dim As Integer fc      For b3 As Integer = 0 To 255      If fp->child(b3) = 0 Then         Continue For      EndIf      For b2 As Integer = 0 To 255         If fp->child(b3)->child(b2) = 0 Then            Continue For         EndIf         For b1 As Integer = 0 To 255            If fp->child(b3)->child(b2)->child(b1) = 0 Then               Continue For            EndIf            For b0 As Integer = 0 To 255               If fp->child(b3)->child(b2)->child(b1)->child(b0) = 0 Then                  Continue For               EndIf               fpe = Cast(tEndNode Ptr, fp->child(b3)->child(b2)->child(b1)->child(b0))               fs[0] = b0               fs[1] = b1               fs[2] = b2               fs[3] = b3               fc = Cvi(fs)               Print Cvi(fs), fpe->frontX, fpe->frontY            Next         Next      Next   Next      End SubFunction FrontierLowest(fp As tPathNode Ptr) As Integer   Dim As tEndNode Ptr fpe   Dim As String*5 fs      For b3 As Integer = 0 To 255      If fp->child(b3) = 0 Then         Continue For      EndIf      For b2 As Integer = 0 To 255         If fp->child(b3)->child(b2) = 0 Then            Continue For         EndIf         For b1 As Integer = 0 To 255            If fp->child(b3)->child(b2)->child(b1) = 0 Then               Continue For            EndIf            For b0 As Integer = 0 To 255               If fp->child(b3)->child(b2)->child(b1)->child(b0) = 0 Then                  Continue For               EndIf               fpe = Cast(tEndNode Ptr, fp->child(b3)->child(b2)->child(b1)->child(b0))               fs[0] = b0               fs[1] = b1               fs[2] = b2               fs[3] = b3               Return Cvi(fs)            Next         Next      Next   NextEnd FunctionFunction FrontierHighest(fp As tPathNode Ptr) As Integer   Dim As tEndNode Ptr fpe   Dim As String*5 fs      For b3 As Integer = 255 To 0 Step -1      If fp->child(b3) = 0 Then         Continue For      EndIf      For b2 As Integer = 255 To 0 Step -1         If fp->child(b3)->child(b2) = 0 Then            Continue For         EndIf         For b1 As Integer = 255 To 0 Step -1            If fp->child(b3)->child(b2)->child(b1) = 0 Then               Continue For            EndIf            For b0 As Integer = 255 To 0 Step -1               If fp->child(b3)->child(b2)->child(b1)->child(b0) = 0 Then                  Continue For               EndIf               fpe = Cast(tEndNode Ptr, fp->child(b3)->child(b2)->child(b1)->child(b0))               fs[0] = b0               fs[1] = b1               fs[2] = b2               fs[3] = b3               Return Cvi(fs)            Next         Next      Next   NextEnd FunctionFunction FrontierValue(fp As tPathNode Ptr, v As Integer) As tEndNode   Dim As tEndNode result   Dim As String*5 f = Mki(v)      'MSB   If fp->child(f[3]) = 0 Then      Return result   EndIf      If fp->child(f[3])->child(f[2]) = 0 Then      Return result   EndIf      If fp->child(f[3])->child(f[2])->child(f[1]) = 0 Then      Return result   EndIf      'LSB   If fp->child(f[3])->child(f[2])->child(f[1])->child(f[0]) = 0 Then      Return result   EndIf      result = *(Cast(tEndNode Ptr, fp->child(f[3])->child(f[2])->child(f[1])->child(f[0])))   result.valid = TRUE   Return result   End FunctionSub FrontierDelete(fp As tPathNode Ptr, v As Integer)   Dim As String*5 f = Mki(v)   Dim As tEndNode Ptr ep      If FrontierValue(fp, v).valid Then      ep = Cast(tEndNode Ptr, fp->child(f[3])->child(f[2])->child(f[1])->child(f[0]))      Delete ep      fp->child(f[3])->child(f[2])->child(f[1])->child(f[0]) = 0      For x As Integer = 0 To 255         If fp->child(f[3])->child(f[2])->child(f[1])->child(x) Then            Return         EndIf      Next      'fp->child(f[3])->child(f[2])->child(f[1]) has no subnodes --> erase      Delete fp->child(f[3])->child(f[2])->child(f[1])      fp->child(f[3])->child(f[2])->child(f[1]) = 0      For x As Integer = 0 To 255         If fp->child(f[3])->child(f[2])->child(x) Then            Return         EndIf      Next      'fp->child(f[3])->child(f[2]) has no subnodes --> erase      Delete fp->child(f[3])->child(f[2])      fp->child(f[3])->child(f[2]) = 0      For x As Integer = 0 To 255         If fp->child(f[3])->child(x) Then            Return         EndIf      Next      'fp->child(f[3]) has no subnodes --> erase      Delete fp->child(f[3])      fp->child(f[3]) = 0   EndIf   End SubFrontierAdd(frontier, 100, 100, 1)FrontierAdd(frontier, 200, 200, 10)FrontierAdd(frontier, 300, 300, 5)FrontierAdd(frontier, 400, 400, 100)FrontierAdd(frontier, 402, 400, 7)FrontierAdd(frontier, 401, 400, 10000)FrontierAdd(frontier, 500, 100, 5362)'FrontierAdd(frontier, 700, 400, -5)?"ADD"'Sleep'EndFrontierList(frontier)? "TRAV"? FrontierLowest(frontier)? "LOW"? FrontierHighest(frontier)?"HIGH"? FrontierValue(frontier, 7).valid? "VAL"FrontierDelete(frontier, 5362)FrontierList(frontier)?FrontierDelete(frontier, 1)FrontierList(frontier)?FrontierDelete(frontier, 100)FrontierList(frontier)?FrontierDelete(frontier, 10000)FrontierList(frontier)?FrontierAdd(frontier, 30, 98, 27)FrontierList(frontier)?FrontierDelete(frontier, 7)FrontierList(frontier)?FrontierDelete(frontier, 10)FrontierList(frontier)?FrontierDelete(frontier, 5)FrontierList(frontier)?FrontierAdd(frontier, 30, 98, 27)FrontierList(frontier)Sleep'FrontierErase(frontier)`
leopardpm
Posts: 1795
Joined: Feb 28, 2009 20:58

### Re: Anyone have good code for making a Priority Queue?

OMG! that is EXTENSIVE! not sure I understand the output yet.... will mull it over and see.... that is ALOT of work you put into this, grindstone! I am unsure the effort expended will be worth the miniscule time savings in the program though... BUT, it could also be applied to alot of other different programs as well..... having a good, fast Binary Tree Search is always helpful
grindstone
Posts: 737
Joined: May 05, 2015 5:35
Location: Germany

### Re: Anyone have good code for making a Priority Queue?

Yes, it was a lot of work, and it took a lot of brainpower - when I coded the template of this a few years ago: A search tree list to maintain my music collection <smile>.

This time it was not so hard. If you have a closer look at the code you will see that most of the procedures are quite similar, so I only had to copy them and with a few modifications adapt them to their different purposes.

The basic idea was to convert the "frontCost" (32 bit-) Integer value to a 4-byte-string and use the values of the "characters" as indices of the subnode arrays. So the storing place incidentally contains the information of the frontCost value, and the list is quasi self-sorting.

Here a completed and commented version of the code. I only made some functional tests and leave the performance tests to you (and I am curious about the results <grin>).

Code: Select all

`Type tEndNode   As Integer frontX = 0   As Integer frontY = 0   As Boolean valid = FALSEEnd TypeType tPathNode   As tPathNode Ptr child(0 To 255) 'array of child nodesEnd TypeDim As tPathNode Ptr frontier = New tPathNode 'create root nodeSub FrontierAdd(fp As tPathNode Ptr, _                 ByVal frontX As Integer, _                 ByVal frontY As Integer, _                 ByVal frontCost As Long)   Dim As tEndNode Ptr fpe   Dim As String*5 f = Mkl(frontCost), g         If fp = 0 Then Return       'MSB   If fp->child(f[3]) = 0 Then 'no such node      fp->child(f[3]) = New tPathNode 'create node for MSB index   EndIf      'byte 2   If fp->child(f[3])->child(f[2]) = 0 Then 'no such node      fp->child(f[3])->child(f[2]) = New tPathNode 'create node for byte 2 index   EndIf      'byte 1   If fp->child(f[3])->child(f[2])->child(f[1]) = 0 Then 'no such node      Cast(tPathNode Ptr, fp->child(f[3])->child(f[2])->child(f[1])) = New tPathNode 'create node for byte 1 index   EndIf      'LSB   If fp->child(f[3])->child(f[2])->child(f[1])->child(f[0]) = 0 Then 'no such node      'create end node (containing "frontX" and "frontY") for LSB index      Cast(tEndNode Ptr, fp->child(f[3])->child(f[2])->child(f[1])->child(f[0])) = New tEndNode   EndIf      'get pointer to end node to ease access   fpe = Cast(tEndNode Ptr, fp->child(f[3])->child(f[2])->child(f[1])->child(f[0]))      'write values to end node   fpe->frontX = frontX   fpe->frontY = frontY   fpe->valid  = TRUE      End SubSub FrontierList(fp As tPathNode Ptr)   Dim As tEndNode Ptr fpe   Dim As String*5 fs         If fp = 0 Then Return      For b3 As Integer = 0 To 255 'all MSB indices      If fp->child(b3) = 0 Then 'no child node ( = no such value )         Continue For 'next MSB index ( = skip all lower significant bytes )      EndIf      For b2 As Integer = 0 To 255 'all byte 2 indices         If fp->child(b3)->child(b2) = 0 Then 'no child node            Continue For 'next byte 2 index         EndIf         For b1 As Integer = 0 To 255 'all byte 1 indices            If fp->child(b3)->child(b2)->child(b1) = 0 Then               Continue For            EndIf            For b0 As Integer = 0 To 255 'all LSB indices               If fp->child(b3)->child(b2)->child(b1)->child(b0) = 0 Then                  Continue For               EndIf               'found existing end node               'get pointer to end node to ease access               fpe = Cast(tEndNode Ptr, fp->child(b3)->child(b2)->child(b1)->child(b0))               'write indices to "frontCost" value string               fs[0] = b0               fs[1] = b1               fs[2] = b2               fs[3] = b3               Print Cvl(fs), fpe->frontX, fpe->frontY 'convert "frontCost" value to long and print result            Next         Next      Next   Next      End SubFunction FrontierLowest(fp As tPathNode Ptr) As Long   Dim As tEndNode Ptr fpe   Dim As String*5 fs      If fp = 0 Then Return 0      For b3 As Integer = 0 To 255 'all MSB indices      If fp->child(b3) = 0 Then 'no child node ( = no such value )         Continue For 'next MSB index ( = skip all lower significant bytes )      EndIf      For b2 As Integer = 0 To 255 'all byte 2 indices         If fp->child(b3)->child(b2) = 0 Then 'no child node            Continue For 'next byte 2 index         EndIf         For b1 As Integer = 0 To 255 'all byte 1 indices            If fp->child(b3)->child(b2)->child(b1) = 0 Then               Continue For            EndIf            For b0 As Integer = 0 To 255 'all LSB indices               If fp->child(b3)->child(b2)->child(b1)->child(b0) = 0 Then                  Continue For               EndIf               '1st ( = lowest ) value of the list found               'get pointer to end node to ease access               fpe = Cast(tEndNode Ptr, fp->child(b3)->child(b2)->child(b1)->child(b0))               'write indices to "frontCost" value string               fs[0] = b0               fs[1] = b1               fs[2] = b2               fs[3] = b3               Return Cvl(fs) 'return lowest value            Next         Next      Next   NextEnd FunctionFunction FrontierHighest(fp As tPathNode Ptr) As Long   Dim As tEndNode Ptr fpe   Dim As String*5 fs      If fp = 0 Then Return 0      For b3 As Integer = 255 To 0 Step -1 'all MSB indices in reverse order      If fp->child(b3) = 0 Then 'no child node ( = no such value )         Continue For 'next MSB index ( = skip all lower significant bytes )      EndIf      For b2 As Integer = 255 To 0 Step -1 'all byte 2 indices in reverse order         If fp->child(b3)->child(b2) = 0 Then 'no child node            Continue For 'next byte 2 index         EndIf         For b1 As Integer = 255 To 0 Step -1 'all byte 1 indices in reverse order            If fp->child(b3)->child(b2)->child(b1) = 0 Then               Continue For            EndIf            For b0 As Integer = 255 To 0 Step -1 'all LSB indices in reverse order               If fp->child(b3)->child(b2)->child(b1)->child(b0) = 0 Then                  Continue For               EndIf               'last ( = highest ) value of the list found               'get pointer to end node to ease access               fpe = Cast(tEndNode Ptr, fp->child(b3)->child(b2)->child(b1)->child(b0))               'write indices to "frontCost" value string               fs[0] = b0               fs[1] = b1               fs[2] = b2               fs[3] = b3               Return Cvl(fs) 'return highest value            Next         Next      Next   NextEnd FunctionFunction FrontierValue(fp As tPathNode Ptr, v As Long) As tEndNode   Dim As tEndNode result   Dim As String*5 f = Mki(v)      If fp = 0 Then Return result      'MSB   If fp->child(f[3]) = 0 Then      Return result 'no such value ( = return "result" with ".valid" set to FALSE )   EndIf      'byte 2   If fp->child(f[3])->child(f[2]) = 0 Then      Return result   EndIf      'byte 1   If fp->child(f[3])->child(f[2])->child(f[1]) = 0 Then      Return result   EndIf      'LSB   If fp->child(f[3])->child(f[2])->child(f[1])->child(f[0]) = 0 Then      Return result   EndIf      'get end node corresponding to the requested value   result = *(Cast(tEndNode Ptr, fp->child(f[3])->child(f[2])->child(f[1])->child(f[0])))   result.valid = TRUE   Return result   End FunctionSub FrontierDelete(fp As tPathNode Ptr, v As Long)   Dim As String*5 f = Mki(v)   Dim As tEndNode Ptr ep      If fp = 0 Then Return      If FrontierValue(fp, v).valid Then 'end node exists      ep = Cast(tEndNode Ptr, fp->child(f[3])->child(f[2])->child(f[1])->child(f[0]))      Delete ep 'delete end node      fp->child(f[3])->child(f[2])->child(f[1])->child(f[0]) = 0 'set pointer to NULL            'delete unused subnodes      'LSB level      For x As Integer = 0 To 255 'scan child node array for subnodes         If fp->child(f[3])->child(f[2])->child(f[1])->child(x) Then 'subnode found ( = terminate scan )            Return         EndIf      Next      'fp->child(f[3])->child(f[2])->child(f[1]) has no subnodes ( = node can be erased )      Delete fp->child(f[3])->child(f[2])->child(f[1]) 'erase node      fp->child(f[3])->child(f[2])->child(f[1]) = 0 'set pointer to NULL            'byte 1 level      For x As Integer = 0 To 255         If fp->child(f[3])->child(f[2])->child(x) Then            Return         EndIf      Next      'fp->child(f[3])->child(f[2]) has no subnodes ( = node can be erased )      Delete fp->child(f[3])->child(f[2])      fp->child(f[3])->child(f[2]) = 0            'byte 2 level       For x As Integer = 0 To 255         If fp->child(f[3])->child(x) Then            Return         EndIf      Next      'fp->child(f[3]) has no subnodes ( = node can be erased )      Delete fp->child(f[3])      fp->child(f[3]) = 0   EndIf   End SubSub FrontierKill(ByRef frontier As tPathNode Ptr)   Dim As Long x      Do 'delete all nodes      x = FrontierHighest(frontier)      FrontierDelete(frontier, x)   Loop While x      Delete frontier 'delete the root node   frontier = 0 'set root pointer to NULL   End SubFrontierAdd(frontier, 100, 100, 1)FrontierAdd(frontier, 200, 200, 10)FrontierAdd(frontier, 300, 300, 5)FrontierAdd(frontier, 400, 400, 100)FrontierAdd(frontier, 402, 400, 7)FrontierAdd(frontier, 401, 400, 10000)FrontierAdd(frontier, 500, 100, 5362)'FrontierAdd(frontier, 700, 400, -5)?"ADD"'Sleep'EndFrontierList(frontier)? "TRAV"? FrontierLowest(frontier)? "LOW"? FrontierHighest(frontier)?"HIGH"? FrontierValue(frontier, 7).valid? "VAL"'FrontierDelete(frontier, 5362)'FrontierList(frontier)'?'FrontierDelete(frontier, 1)'FrontierList(frontier)'?'FrontierDelete(frontier, 100)'FrontierList(frontier)'?'FrontierDelete(frontier, 10000)'FrontierList(frontier)?FrontierAdd(frontier, 30, 98, 27)FrontierList(frontier)'?'FrontierDelete(frontier, 7)'FrontierList(frontier)'?'FrontierDelete(frontier, 10)'FrontierList(frontier)'?'FrontierDelete(frontier, 5)'FrontierList(frontier)?FrontierAdd(frontier, 30, 98, 27)FrontierList(frontier)? "KILL"? frontier?FrontierKill(frontier)FrontierList(frontier)?? frontierSleep`
leopardpm
Posts: 1795
Joined: Feb 28, 2009 20:58

### Re: Anyone have good code for making a Priority Queue?

@grindstone
that works well!

I have something else that is similar and might need some help, gonna try and tackle it myself first before asking for any help. my issue is making recursive code, which always throws me for a loop. Basically, I am generating a tree structure... has been blowing my mind for the past 2 days but thought again about it and have a few more ideas... will let you know.