Anyone have good code for making a Priority Queue?

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

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

Postby leopardpm » Dec 11, 2018 0:31

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: 640
Joined: May 05, 2015 5:35
Location: Germany

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

Postby grindstone » Dec 11, 2018 1:32

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 = FALSE
End Type

Type tPathNode
   As tPathNode Ptr child(0 To 255)
End Type

Type tPreEndNode
   As tEndNode Ptr child(0 To 255)
End Type

Dim As tPathNode Ptr frontier = New tPathNode 'create root node


Sub 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 Sub

Sub 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 Sub

Function 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
   Next
End Function

Function 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
   Next
End Function

Function 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 Function

Sub 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 Sub


FrontierAdd(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
'End



FrontierList(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: 1791
Joined: Feb 28, 2009 20:58

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

Postby leopardpm » Dec 11, 2018 2:09

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: 640
Joined: May 05, 2015 5:35
Location: Germany

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

Postby grindstone » Dec 11, 2018 9:28

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 = FALSE
End Type

Type tPathNode
   As tPathNode Ptr child(0 To 255) 'array of child nodes
End Type

Dim As tPathNode Ptr frontier = New tPathNode 'create root node

Sub 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 Sub

Sub 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 Sub

Function 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
   Next
End Function

Function 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
   Next
End Function

Function 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 Function

Sub 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 Sub

Sub 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 Sub


FrontierAdd(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
'End

FrontierList(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)
?
? frontier

Sleep

leopardpm
Posts: 1791
Joined: Feb 28, 2009 20:58

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

Postby leopardpm » Dec 15, 2018 1:20

@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.

Return to “General”

Who is online

Users browsing this forum: No registered users and 3 guests