Data Structure UNION-FIND to solve Kruskal's problem

Share your advanced PureBasic knowledge/code with the community.
User avatar
Fig
Enthusiast
Enthusiast
Posts: 351
Joined: Thu Apr 30, 2009 5:23 pm
Location: Côtes d'Azur, France

Data Structure UNION-FIND to solve Kruskal's problem

Post by Fig »

This is an Union-Find data structure (aka Disjoint-set data structure). See https://en.wikipedia.org/wiki/Disjoint- ... _structure
I use it to solve the Kruskal's problem (ie find the minimum-spanning-tree graph).
Left click to see each step. See https://en.wikipedia.org/wiki/Kruskal%27s_algorithm

Tested on win10x64, PB5.62 x86.

Image

Code: Select all

;/ this part is UNION-FIND DATA SET
;/ 
Procedure.l MakeSet(size.l)
    If size<=0:MessageRequester("Error","MakeSet() can't get zero or negative argument"):ProcedureReturn 0:EndIf
    size+1
    *sizeID=AllocateMemory(size*8):If *sizeID=0:MessageRequester("Error","Allocate Memory SIZE can't make its job in MakeSet()"):ProcedureReturn 0:EndIf
    PokeL(*sizeID,size)
    For i=1 To size-1
        PokeL(*sizeID+i*8,i)
        PokeL(*sizeID+i*8+4,1)
    Next i
    ProcedureReturn *sizeID
EndProcedure

Procedure.l Find(*sizeID,p.l)
    ;Find the root of the component/set
    root.l=p
    While root<>PeekL(*sizeID+root*8)
        root=PeekL(*sizeID+root*8)
    Wend
    ;path Compression. Gives us amortized constant time complexity.
    While p<>root
        it.l=PeekL(*sizeID+p*8)
        PokeL(*sizeID+p*8,root)
        p=it
    Wend
    ProcedureReturn root  
EndProcedure

Procedure Connected(*sizeID,p.l,q.l)
    If find(*sizeID,p)=find(*sizeID,q):ProcedureReturn 1:EndIf
    ProcedureReturn 0
EndProcedure

Procedure Unify(*sizeID,p.l,q.l)
    root1.l=find(*sizeID,p)
    root2.l=find(*sizeID,q)
    If root1=root2:ProcedureReturn 0:EndIf ;same group
    sizeR1.l=PeekL(*sizeID+root1*8+4)
    sizeR2.l=PeekL(*sizeID+root2*8+4)
    If sizeR1<sizeR2
        PokeL(*sizeID+root2*8+4,sizeR1+SizeR2)
        PokeL(*sizeID+root1*8,root2)
    Else
        PokeL(*sizeID+root1*8+4,sizeR1+SizeR2)
        PokeL(*sizeID+root2*8,root1)
    EndIf
    nb.l=PeekL(*sizeID)-1
    PokeL(*sizeID,nb)
EndProcedure


;/ This PART is data for the Kruskal's problem
;/ https://en.wikipedia.org/wiki/Kruskal%27s_algorithm
#NbPoints=10
Procedure debugSet(*sizeID)
    ClearDebugOutput()
    For i=1 To #NbPoints
        Debug Chr(64+i)+" Groupe "+find(*sizeID,i)
    Next i    
EndProcedure
Structure link
    PointA.l
    PointB.l
    Cost.l
    final.l
EndStructure
Structure pts
    x.l
    y.l
    Name.s
EndStructure
Global NewList Link.link()
Dim Points.pts(#NbPoints)
Procedure AddLink(pointA,PointB,Cost)
    AddElement(Link())
    Link()\PointA=pointA
    Link()\PointB=pointB
    Link()\Cost=Cost
EndProcedure
Addlink(1,2,5) ;AB 5
Addlink(1,4,9) ;AD 5
Addlink(1,5,1) ;AE 1
Addlink(2,4,2) ;BD 2
Addlink(2,3,4) ;BC 4
Addlink(3,10,8);CJ 8
Addlink(3,9,1) ;CI 1
Addlink(3,8,4) ;CH 4
Addlink(4,5,2) ;DE 2
Addlink(4,6,5) ;DF 5
Addlink(4,7,11);DG 11
Addlink(4,8,2) ;DH 2
Addlink(5,6,1) ;EF 1
Addlink(6,7,7) ;FG 7
Addlink(7,8,1) ;GH 1
Addlink(7,9,4) ;GI 4
Addlink(8,9,6) ;HI 6
Addlink(9,10,0);IJ 0
SortStructuredList(Link(),#PB_Sort_Ascending ,OffsetOf(link\cost),TypeOf(link\cost))
For i=1 To #NbPoints
    Points(i)\Name=Chr(64+i)
    Read.i Points(i)\x
    Points(i)\x=Points(i)\x*100+Random(50)-25
    Read.i Points(i)\y
    Points(i)\y=Points(i)\y*80
Next i
*mem=MakeSet(#NbPoints)

If OpenWindow(0, 0, 0, 800, 600, "Kruskal problem, solved with Union-Find data structure", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)=0:End:EndIf
CanvasGadget(0, 0, 0, 800, 600, #PB_Canvas_Container)
CloseGadgetList()
CreateImage(0,800,600)

CurrentEdge=0
Repeat
    Event = WaitWindowEvent()
    If Event = #PB_Event_Gadget
        If EventType()=#PB_EventType_LeftButtonDown Or CurrentEdge=0
            If SelectElement(Link(),CurrentEdge)
                If Connected(*mem,link()\PointA,link()\PointB)=0
                    Unify(*mem,link()\PointA,link()\PointB)
                    link()\final=1
                    debugSet(*mem)
                Else
                    link()\final=2
                EndIf
            Else
                MessageRequester("Info","Kuskal's problem is solved, this is the minimum-spanning-tree graph")
            EndIf
            CurrentEdge+1
            StartDrawing(ImageOutput(0))
            Box(0,0,800,600,#Black)
            DrawText(0,0,"[Clic left] to examin next nodes")

            ForEach Link()
                ptA.l=link()\PointA
                ptB.l=link()\PointB
                If link()\final=1
                    LineXY(Points(ptA)\x,Points(ptA)\y,Points(ptB)\x,Points(ptB)\y,$28ACE2)
                    DrawText((Points(ptB)\x-Points(ptA)\x)/2+Points(ptA)\x,(Points(ptB)\y-Points(ptA)\y)/2+Points(ptA)\y,Str(link()\Cost))
                ElseIf link()\final=0
                    LineXY(Points(ptA)\x,Points(ptA)\y,Points(ptB)\x,Points(ptB)\y,#White)
                    DrawText((Points(ptB)\x-Points(ptA)\x)/2+Points(ptA)\x,(Points(ptB)\y-Points(ptA)\y)/2+Points(ptA)\y,Str(link()\Cost))
                ElseIf link()\final=2
                    LineXY(Points(ptA)\x,Points(ptA)\y,Points(ptB)\x,Points(ptB)\y,#Black)
                EndIf   
            Next
            DrawingMode(#PB_2DDrawing_Transparent)
            For i=1 To #NbPoints
                Circle(Points(i)\x,points(i)\y,12,#Blue)
                DrawText(Points(i)\x-TextWidth(points(i)\Name)/2,points(i)\y-TextHeight(points(i)\Name)/2,points(i)\Name,#White)
            Next i 
            StopDrawing()
            StartDrawing(CanvasOutput(0))
            DrawImage(ImageID(0),0,0)
            StopDrawing()
        EndIf
    EndIf
Until Event = #PB_Event_CloseWindow
FreeMemory(*mem)
;points coordonnates to display
DataSection
    Data.i 1,1,2,1,4,1 ;ABC
    Data.i 2,2,1,2     ;DE
    Data.i 1,3,2,3     ;FG
    Data.i 3,2         ;H
    Data.i 3,3,4,3     ;IJ
EndDataSection
Last edited by Fig on Mon Sep 17, 2018 10:36 am, edited 6 times in total.
There are 2 methods to program bugless.
But only the third works fine.

Win10, Pb x64 5.71 LTS
User avatar
NicTheQuick
Addict
Addict
Posts: 1224
Joined: Sun Jun 22, 2003 7:43 pm
Location: Germany, Saarbrücken
Contact:

Re: Data Structure UNION-FIND to solve Kruskal's problem

Post by NicTheQuick »

I've got an "Overflow in a dynamically allocated memory block." in line 8.
The english grammar is freeware, you can use it freely - But it's not Open Source, i.e. you can not change it or publish it in altered way.
User avatar
Fig
Enthusiast
Enthusiast
Posts: 351
Joined: Thu Apr 30, 2009 5:23 pm
Location: Côtes d'Azur, France

Re: Data Structure UNION-FIND to solve Kruskal's problem

Post by Fig »

Corrected, thank you for running prog with purifer on... :lol:
There are 2 methods to program bugless.
But only the third works fine.

Win10, Pb x64 5.71 LTS
User avatar
Kwai chang caine
Always Here
Always Here
Posts: 5342
Joined: Sun Nov 05, 2006 11:42 pm
Location: Lyon - France

Re: Data Structure UNION-FIND to solve Kruskal's problem

Post by Kwai chang caine »

Impressive subject :shock:
Thanks for sharing 8)
ImageThe happiness is a road...
Not a destination
Post Reply