Posted to tcl by Florentis at Fri Oct 16 04:10:54 GMT 2026view raw

  1. # hypergraphe.tcl --
  2. #
  3. # Un hypergraphe : des sommets et des hyperarêtes, chacune étant un sous-
  4. # ensemble QUELCONQUE de sommets (2, 3, 5...). Exemple classique : les
  5. # co-auteurs. Les sommets sont les auteurs, chaque article est une
  6. # hyperarête qui regroupe ses auteurs.
  7. #
  8. # Deux représentations, complémentaires :
  9. #
  10. # A. des données qui vivent : chaque auteur est une VARIABLE typée, et un
  11. # article est une liste de liens (var) vers ses auteurs. Modifier un
  12. # auteur est visible de tous ses articles ; type deref prend un
  13. # instantané.
  14. # B. de l'analyse : un article est un MASQUE DE BITS (bitarray) sur la
  15. # liste des auteurs. Taille, intersection, union, degré, dual : des
  16. # opérations sur entiers.
  17. #
  18. # Une procédure fait le pont de A vers B. Aucun fichier externe.
  19.  
  20. # ===========================================================================
  21. # A. Données vivantes : sommets = variables, hyperarêtes = listes de liens
  22. # ===========================================================================
  23.  
  24. puts "\n=== A. données vivantes avec des liens ==="
  25.  
  26. type def auteur {
  27. {string}nom;
  28. {int}articles = 0
  29. }
  30.  
  31. type def papier {
  32. {string}titre;
  33. {list.var(typed).auteur}auteurs
  34. }
  35.  
  36. set {auteur}alice nom alice
  37. set {auteur}bob nom bob
  38. set {auteur}carol nom carol
  39. set {auteur}dave nom dave
  40.  
  41. set {papier}pa titre "Types et liens" auteurs {alice bob carol}
  42. set {papier}pb titre "Sommes et variants" auteurs {carol dave}
  43.  
  44. # un article regroupe des LIENS : on voit les noms de variables, pas les valeurs
  45. puts "pa = $pa"
  46.  
  47. # publier : chaque auteur du papier gagne un article (on écrit À TRAVERS les liens)
  48. proc publier {papier} {
  49. upvar 1 $papier p
  50. for {set i 0} {$i < [llength $p(auteurs)]} {incr i} {
  51. set p(auteurs.$i.articles) [expr {$p(auteurs.$i.articles) + 1}]
  52. }
  53. }
  54. publier pa
  55. publier pb
  56. puts "apres publication : alice=$alice(articles) carol=$carol(articles) dave=$dave(articles)"
  57.  
  58. # les liens suivent les variables : une seule carol, partagée par les deux
  59. set carol(nom) "Carol Dupont"
  60. puts "carol vue par pa : $pa(auteurs.2.nom) ; vue par pb : $pb(auteurs.0.nom)"
  61.  
  62. # un instantané, figé : le résultat est une vraie liste d'auteurs
  63. set avant [type deref $pa]
  64. publier pa
  65. set apres [type deref $pa]
  66. puts "instantané avant : [lmap a $avant(auteurs) {lindex $a 1}]"
  67. puts "instantané après : [lmap a $apres(auteurs) {lindex $a 1}] (nombre d'articles de chacun)"
  68. puts "type : [type get $avant]"
  69.  
  70. # un auteur supprimé : erreur franche, qui dit où
  71. unset bob
  72. puts "\nauteur supprimé : [catch {type deref $pa} msg] $msg"
  73. set {auteur}bob nom bob articles 2 ;# on le recrée
  74.  
  75. # une variable non typée n'est pas acceptée comme auteur
  76. set intrus "x"
  77. puts "variable non typée : [catch {set {papier}pz titre "?" auteurs {intrus}} msg] $msg"
  78.  
  79. # ===========================================================================
  80. # B. Hyperarêtes = masques de bits
  81. # ===========================================================================
  82.  
  83. puts "=== B. analyse avec des masques de bits ==="
  84.  
  85. # n sommets : la liste des étiquettes a exactement n éléments, et chaque
  86. # hyperarête est un entier de n bits (le bit i = le sommet i en fait partie).
  87.  
  88. type def {hg({int}n)} {
  89. {list($n).string}labels;
  90. {list.bitarray($n)}edges
  91. }
  92.  
  93. set {hg(5)}H labels {alice bob carol dave erin} \
  94. edges {0b00111 0b01100 0b11000 0b00011}
  95. # articles : 0: alice bob carol 1: carol dave 2: dave erin 3: alice bob
  96. puts "type : [type get $H]"
  97.  
  98. # les membres d'un masque, par leurs noms
  99. proc noms {labels masque} {
  100. set out {}
  101. set i 0
  102. foreach nom $labels {
  103. if {($masque >> $i) & 1} {lappend out $nom}
  104. incr i
  105. }
  106. return $out
  107. }
  108. set etiquettes $H(labels)
  109.  
  110. puts "\nArticles"
  111. for {set i 0} {$i < 4} {incr i} {
  112. puts [format " article %d : %-22s taille %d" $i \
  113. [join [noms $etiquettes $H(edges.$i)] ", "] \
  114. [expr {popcount($H(edges.$i))}]]
  115. }
  116.  
  117. puts "\nChaque bit se lit directement : carol a-t-elle écrit l'article 0 ? $H(edges.0.2)"
  118.  
  119. puts "\nArticles qui partagent des auteurs (intersection non vide)"
  120. for {set i 0} {$i < 4} {incr i} {
  121. for {set j [expr {$i + 1}]} {$j < 4} {incr j} {
  122. set commun [expr {$H(edges.$i) & $H(edges.$j)}]
  123. if {$commun} {
  124. puts " $i et $j : [join [noms $etiquettes $commun] ", "]"
  125. }
  126. }
  127. }
  128.  
  129. puts "\nDegré de chaque sommet (nombre d'articles)"
  130. for {set k 0} {$k < 5} {incr k} {
  131. set deg 0
  132. for {set i 0} {$i < 4} {incr i} { incr deg $H(edges.$i.$k) }
  133. puts [format " %-6s %d" [lindex $etiquettes $k] $deg]
  134. }
  135.  
  136. puts "\nCo-auteurs de carol (union de ses articles, sans elle)"
  137. set union 0
  138. for {set i 0} {$i < 4} {incr i} {
  139. if {$H(edges.$i.2)} { set union [expr {$union | $H(edges.$i)}] }
  140. }
  141. puts " [join [noms $etiquettes [expr {$union & ~(1 << 2)}]] ", "]"
  142.  
  143. # L'hypergraphe DUAL : les articles deviennent les sommets, les auteurs les
  144. # hyperarêtes (c'est la matrice transposée).
  145. proc dual {H} {
  146. set nart [llength $H(edges)]
  147. set masques {}
  148. for {set k 0} {$k < [llength $H(labels)]} {incr k} {
  149. set m 0
  150. for {set i 0} {$i < $nart} {incr i} {
  151. if {$H(edges.$i.$k)} { set m [expr {$m | (1 << $i)}] }
  152. }
  153. lappend masques $m
  154. }
  155. return $masques
  156. }
  157. set {hg(4)}D labels {art0 art1 art2 art3} edges [dual $H]
  158. puts "\nDual : les hyperarêtes sont les auteurs"
  159. for {set k 0} {$k < 5} {incr k} {
  160. puts [format " %-6s a écrit : %s" [lindex $etiquettes $k] \
  161. [join [noms $D(labels) $D(edges.$k)] ", "]]
  162. }
  163.  
  164. puts "\nGaranties du typage"
  165. puts " [catch {set H(edges.1) 0b100000} msg] $msg"
  166. puts " [catch {set {hg(5)}faux labels {a b c} edges {1}} msg] $msg"
  167.  
  168.  
  169. # ===========================================================================
  170. # Le pont : de la forme A (liens) à la forme B (masques)
  171. # ===========================================================================
  172.  
  173. puts "\n=== A vers B ==="
  174.  
  175. # Un masque de bits sur la liste d'étiquettes donnée, à partir d'un papier.
  176. proc masque_de {papier etiquettes} {
  177. upvar 1 $papier p
  178. set m 0
  179. for {set i 0} {$i < [llength $p(auteurs)]} {incr i} {
  180. set k [lsearch -exact $etiquettes $p(auteurs.$i.nom)]
  181. if {$k < 0} { error "auteur inconnu : $p(auteurs.$i.nom)" }
  182. set m [expr {$m | (1 << $k)}]
  183. }
  184. return $m
  185. }
  186. set carol(nom) carol ;# nom d'origine
  187. set noms {alice bob carol dave}
  188. set {hg(4)}G labels $noms edges [list [masque_de pa $noms] [masque_de pb $noms]]
  189. puts "pa -> [format %04b $G(edges.0)] pb -> [format %04b $G(edges.1)]"
  190. puts "carol est dans les deux : intersection = [join [noms $noms [expr {$G(edges.0) & $G(edges.1)}]] ", "]"
  191.  

Add a comment

Please note that this site uses the meta tags nofollow,noindex for all pages that contain comments.
Items are closed for new comments after 1 week