Bir Cizgenin Yonlu Dongusuz Cizge (Directed Acyclic Graph) olup olmadigini kontrol eden bir program yazin

Question

Aslinda matematiktemi sorsam veri biliminde mi sorsam bilemedim.

Girdi : Yonlu bir Cizge

Istenen cikti : Cizgede dongu yoksa (DAG ise) dogru degil ise yanlis

Opsyonel istenen cikti : Yanlis ise cizgedeki donguler

 

Hikaye: Bir sene once basladigim iste ilk karsima cikan "ciddi" problemlerden biriydi bu soru.

Elimizde cizge degil multi cizge vardi ama bu sorunun detaylarini degistirmiyor.

Comments

Yazacağımız programı test edeceğimiz bir iki tane yönlü çizge verebilir misiniz? Girdilerin neye benzediğini ve türünü (string midir, list midir, dictionary türünde midir) bilirsek, istenen fonksiyonu da bu veri yapısına ait çizgelere bakarak tanımlamayı deneyebiliriz.

---

Tabii girdi olarak adjecency matrix kabul edebiliriz.Iki tane ornek yazdim simdilik

Yonlu Dongusuz Cizgeler

[[0,1,1],[0,0,1],[0,0,0]

[[0,1],[0,0]]

Yonlu ama Dongulu Cizge

[[0,1,1],[0,0,1],[0,0,1]]

[[0,1],[1,0]]

---

Mathematica'nin bunun icin kendi fonksiyonu var https://reference.wolfram.com/language/ref/AcyclicGraphQ.html

---

m = {{0, 1, 1}, {0, 0, 1}, {0, 0, 0}};
g = AdjacencyGraph[m]
AcyclicGraphQ@g

True

m = {{0, 1, 1}, {0, 0, 1}, {0, 0, 1}};
g = AdjacencyGraph[m]
AcyclicGraphQ@g

True

---

@OkkesDulgerci son cizge DAG degil ama mathematica DAG diyor ?

---

Haklisin. Possible Issues kisminda buna deginilmis. Kendine donguler gozardi ediliyormus. Kendine dongu olup olmadigi da kontrol edilebilir. Asagida bunu yapan kucuk bi program var. Yanlis durumunda cizgedeki donguleri gosteriyor..

Answer 1

ClearAll["Global`*"]
m = {{0, 1, 1}, {0, 0, 1}, {0, 0, 1}};
test[m_] :=With[{g = AdjacencyGraph[m, VertexLabels -> "Name"]}, 
  If[LoopFreeGraphQ@g == True && AcyclicGraphQ@g == True, "Dogru", {"Yanlis", HighlightGraph[g, Subgraph[g, #] & /@ ConnectedComponents[g]]}]]


test[m]

 

m={{0, 1, 0, 0, 1, 1, 0, 0}, {1, 0, 1, 1, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 
  1, 0, 1}, {0, 0, 1, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 1, 1, 0}, {0, 0,
   0, 0, 1, 0, 0, 0}, {0, 0, 0, 0, 0, 1, 0, 0}, {0, 0, 0, 1, 0, 1, 1, 
  0}};

test[m]

 

m = {{0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 1, 1, 1, 0,
     0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0}, {0, 0, 
    0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 
    0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0,
     0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 
    0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0,
     0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 
    0, 0, 0, 0}};

test[m]

Dogru