exo5.lisp (12866B)
1 (defstruct (transport) nb-noeuds source puits arcs-sortants arcs capacites) 2 (defstruct (flot (:include transport)) flots) 3 (defstruct (couche (:include transport)) present) 4 (defstruct (file) (tete nil) (queue nil)) 5 (defun list->file (l) 6 (make-file l (last l))) 7 (defun end-file (f) 8 (endp (file-tete f))) 9 (defun file-enqueue (f x) 10 (if (endp (file-tete f)) 11 (progn (setf (file-tete f) (list x)) 12 (setf (file-queue f) (file-tete f))) 13 (progn (setf (cdr (file-queue f)) (cons x nil)) 14 (setf (file-queue f) (cdr (file-queue f)))))) 15 16 (defun file-dequeue (f) 17 (prog1 (car (file-tete f)) 18 (setf (file-tete f) (cdr (file-tete f))) 19 (when (endp (file-tete f)) 20 (setf (file-queue f) nil)))) 21 22 (defun transport->ecart (gt) 23 (loop 24 with len = (* 2 (length (transport-arcs gt))) 25 with as = (make-array (transport-nb-noeuds gt) :initial-element nil) 26 and a = (make-array len) 27 and c = (make-array len) 28 and index 29 and index2 30 with ge = (make-transport :nb-noeuds (transport-nb-noeuds gt) 31 :source (transport-source gt) 32 :puits (transport-puits gt) 33 :arcs-sortants as 34 :arcs a 35 :capacites c) 36 for arc across (transport-arcs gt) 37 for cap across (transport-capacites gt) 38 for i upfrom 0 39 do (setq index (* 2 i)) 40 do (setq index2 (+ 1 index)) 41 do (push index (aref as (car arc))) 42 do (push index2 (aref as (cdr arc))) 43 do (setf (aref a index) arc) 44 do (setf (aref a index2) (cons (cdr arc) (car arc))) 45 do (setf (aref c index) cap) 46 do (setf (aref c index2) 0) 47 finally (return ge))) 48 49 (defun transport->couche (gt) 50 (let ((ge (transport->ecart gt))) 51 (make-couche :nb-noeuds (transport-nb-noeuds ge) 52 :source (transport-source ge) 53 :puits (transport-puits ge) 54 :arcs-sortants (transport-arcs-sortants ge) 55 :arcs (transport-arcs ge) 56 :capacites (transport-capacites ge) 57 :present (make-array 1 :initial-element nil)))) ;; sera écrasé par liste-plus-courts-chemins 58 59 (defun plus-court-chemin (gt) 60 "Renvoie le plus court chemin de s à t dans un graphe d'écart. 61 Le chemin est représenté par les numéros des :arcs qui le composent, du puits à la source." 62 (loop named pcc 63 with file = (make-file) 64 and chemins = (make-array (transport-nb-noeuds gt) :element-type t :initial-element nil) 65 and puits = (transport-puits gt) 66 and noeud-fils 67 for noeud = (transport-source gt) then (file-dequeue file) 68 do (dolist (arcnum (aref (transport-arcs-sortants gt) noeud)) 69 (setq noeud-fils (cdr (aref (transport-arcs gt) arcnum))) 70 (unless (or (aref chemins noeud-fils) (= 0 (aref (transport-capacites gt) arcnum))) 71 (setf (aref chemins noeud-fils) (cons arcnum (aref chemins noeud))) 72 (file-enqueue file noeud-fils) 73 (when (eql noeud-fils puits) 74 (return-from pcc (aref chemins puits))))) 75 when (end-file file) 76 return nil 77 end)) 78 79 (defun delta-sur-chemin (gt chemin) 80 (loop 81 for arcnum in chemin 82 with capa = (transport-capacites gt) 83 minimize (aref capa arcnum))) 84 85 (defun maj-ecart (ge chemin delta) 86 (loop 87 for arcnum in chemin 88 for arcnumpair = (if (evenp arcnum) arcnum (- arcnum 1)) 89 do (decf (aref (transport-capacites ge) arcnumpair) delta) 90 do (incf (aref (transport-capacites ge) (+ arcnumpair 1)) delta))) 91 92 (defun get-flot-max (gf) 93 (loop 94 for arcnum in (aref (flot-arcs-sortants gf) (transport-source gf)) 95 sum (aref (flot-flots gf) arcnum))) 96 97 (defun transport/couche->flot (gt ge/c) 98 (loop 99 with len = (length (transport-arcs gt)) 100 with len2 = (* len 2) 101 with f = (make-array len) 102 with gf = (make-flot :nb-noeuds (transport-nb-noeuds gt) 103 :source (transport-source gt) 104 :puits (transport-puits gt) 105 :arcs-sortants (transport-arcs-sortants gt) 106 :arcs (transport-arcs gt) 107 :capacites (transport-capacites gt) 108 :flots f) 109 and capa = (if (transport-p ge/c) (transport-capacites ge/c) (couche-capacites ge/c)) 110 for i from 0 below len 111 for i2 from 1 below len2 by 2 112 do (setf (aref f i) (aref capa i2)) 113 finally (return gf))) 114 115 (defun get-flot (gt ge/c) 116 (let ((flot (transport/couche->flot gt ge/c))) 117 (cons (get-flot-max flot) flot))) 118 119 (defun edmonds-karp (gt) 120 (loop 121 with ge = (transport->ecart gt) 122 for pcc = (plus-court-chemin ge) 123 for delta = (delta-sur-chemin ge pcc) 124 unless pcc 125 return (get-flot gt ge) 126 do (maj-ecart ge pcc delta))) 127 128 (defun nettoyer (arcs+capa) 129 (loop 130 with nb-noeuds = (1+ (max (loop for i in arcs+capa maximize (car i)) 131 (loop for i in arcs+capa maximize (cadr i)))) 132 and copaing 133 with arcs-sortants = (make-array nb-noeuds :initial-element nil) 134 initially (loop 135 for arc in arcs+capa 136 do (push (aref arcs-sortants (car arc)) arc)) 137 for arc in arcs+capa 138 for arcsrest = (setf (aref arcs-sortants (car arc)) (cdr (aref arcs-sortants (car arc)))) 139 unless (= (car arc) (cadr arc)) ;; boucle 140 if (setq copaing (find (cadr arc) arcsrest ;; arcs multiples 141 :key #'cadr)) 142 do (incf (caddr copaing) (caddr arc)) 143 else if (setq copaing (find (cadr arc) (aref arcs-sortants (cadr arc)) 144 :key #'identity)) 145 collect (list (car arc) nb-noeuds (caddr arc)) 146 and collect (list nb-noeuds (cadr arc) (caddr arc)) 147 and do (setf (car arc) nb-noeuds) 148 and do (incf nb-noeuds) 149 else 150 collect arc 151 end)) 152 153 (defun build-transport-list (source puits arcs+capa) 154 (setq arcs+capa (nettoyer arcs+capa)) 155 (loop 156 with source = source 157 and puits = puits 158 and nb-noeuds = (1+ (max (loop for i in arcs+capa maximize (car i)) 159 (loop for i in arcs+capa maximize (cadr i)))) 160 and nb-arcs = (length arcs+capa) 161 with arcs-sortants = (make-array nb-noeuds :initial-element nil) 162 and arcs = (make-array nb-arcs) 163 and capa = (make-array nb-arcs) 164 for ac in arcs+capa 165 for i upfrom 0 166 do (push i (aref arcs-sortants (car ac))) 167 do (setf (aref arcs i) (cons (car ac) (cadr ac))) 168 do (setf (aref capa i) (caddr ac)) 169 finally (return 170 (make-transport :nb-noeuds nb-noeuds 171 :source source 172 :puits puits 173 :arcs-sortants arcs-sortants 174 :arcs arcs 175 :capacites capa)))) 176 177 (defun build-transport-array (source puits arcs+capa) 178 (build-transport-list source puits (map 'list #'identity arcs+capa))) 179 180 (defun liste-plus-courts-chemins (gc) 181 "Modifie les arcs présents dans un graphe de couche (seuls les arcs qui font partie d'un plus court chemin de s à t sont conservés)." 182 (loop named pcc 183 with len = (length (couche-arcs gc)) 184 with file = (make-file) 185 and file2 = (make-file) 186 and dejavu = (make-array len :initial-element -1) 187 and niveau = 0 188 and puits = (couche-puits gc) 189 and noeud-fils 190 for noeud = (couche-source gc) then (file-dequeue file) 191 initially (setf (couche-present gc) (make-array (length (couche-arcs gc)) :initial-element nil)) 192 initially (setf (aref dejavu (couche-source gc)) niveau) 193 when (eql noeud puits) 194 return gc 195 do (dolist (arcnum (aref (couche-arcs-sortants gc) noeud)) 196 (setq noeud-fils (cdr (aref (couche-arcs gc) arcnum))) 197 (unless (= 0 (aref (couche-capacites gc) arcnum)) ;; Pas les arcs saturés 198 (if (= (aref dejavu noeud-fils) niveau) ;; Lorsqu'on a déjà vu le noeud dans cette couche 199 (setf (aref (couche-present gc) arcnum) niveau) ;; => L'arc fait partie de la couche 200 (when (= (aref dejavu noeud-fils) -1) ;; Lorsqu'on n'a jamais vu le noeud 201 (file-enqueue file2 noeud-fils) ;; On l'ajoute à la file d'attente 202 (setf (aref dejavu noeud-fils) niveau) ;; Il fait partie du niveau courant 203 (setf (aref (couche-present gc) arcnum) niveau))))) ;; Fait partie de la couche 204 when (end-file file) 205 do (setq file file2) 206 and when (end-file file) 207 return nil 208 end 209 and do (incf niveau) 210 and do (setq file2 (make-file)) 211 end)) 212 213 (defun maj-ecart-couche (gc) 214 (let ((noeud-fils nil) 215 (liste-arcs-sortants (aref (couche-arcs-sortants gc) (couche-source gc))) 216 (numarc nil) 217 (delta nil) 218 (pile-arcs-sortants nil) 219 (pile-delta nil) 220 (pile-arcs nil)) 221 (tagbody 222 loopstart 223 (when (endp liste-arcs-sortants) 224 (go pop)) 225 (setq numarc (pop liste-arcs-sortants)) 226 (unless (aref (couche-present gc) numarc) ;; Ne prendre en compte que les arcs qui sont dans le graphe de couche 227 (go loopstart)) 228 (unless (> (aref (couche-capacites gc) numarc) 0) ;; Ne pas prendre en compte les arcs qu'on a saturés durant cette fonction 229 (go loopstart)) 230 (push numarc pile-arcs) 231 (setq noeud-fils (cdr (aref (couche-arcs gc) numarc))) 232 ;; TODO : sortir ce if le plus haut possible, ça coûte cher à chaque itération… 233 (setq delta (if delta 234 (min delta (aref (couche-capacites gc) numarc)) 235 (aref (couche-capacites gc) numarc))) 236 (if (eql noeud-fils (couche-puits gc)) 237 (progn 238 (loop 239 for pdelta on pile-delta 240 do (decf (car pdelta) delta)) 241 (loop 242 ;; Remonter jusqu'à la racine en faisant +/- avec delta 243 for arcnum in pile-arcs 244 for arcnumpair = (if (evenp arcnum) arcnum (- arcnum 1)) 245 do (decf (aref (couche-capacites gc) arcnumpair) delta) 246 do (incf (aref (couche-capacites gc) (+ arcnumpair 1)) delta) 247 ;; pop de la pile 248 finally (push delta pile-delta) 249 finally (push liste-arcs-sortants pile-arcs-sortants) 250 finally (go pop))) 251 (progn 252 (push liste-arcs-sortants pile-arcs-sortants) 253 (push delta pile-delta) 254 ;; Récupérer la liste des arcs sortants 255 (setq liste-arcs-sortants (aref (couche-arcs-sortants gc) noeud-fils)) 256 (go loopstart))) 257 pop 258 (unless (endp pile-arcs-sortants) 259 (setq delta (pop pile-delta)) 260 (setq liste-arcs-sortants (pop pile-arcs-sortants)) 261 (setf pile-arcs (cdr pile-arcs)) 262 (go loopstart)) 263 end) 264 gc)) 265 266 (defun dinic (gt) 267 (loop 268 with gc = (transport->couche gt) 269 for gc-pcc = (liste-plus-courts-chemins gc) 270 unless gc-pcc 271 return (get-flot gt gc) 272 do (maj-ecart-couche gc))) 273 274 (defun build-graphe-exemple (n &optional (density 10) (maxcapa 10)) 275 (when (<= n 2) 276 (error "build-graphe-exemple : n est trop petit !")) 277 (loop 278 with arcs = nil 279 with dejafait = (make-array n :initial-element nil) 280 for x from 0 below (- n 1) 281 do (loop 282 for i from 0 to (random density) 283 for y = (+ 1 (random (- n 2))) ;; +1 : ne pas aller vers 0 (la source) 284 when (>= y x) 285 do (setq y (+ y 1)) ;; Pas de boucle. 286 unless (member y (aref dejafait x)) 287 do (push y (aref dejafait x)) 288 and do (push (list x y (random maxcapa)) arcs)) 289 finally (return (build-transport-list 0 (- n 1) arcs)))) 290 291 ;; (defvar exemple-gt (build-transport-array 0 3 #((0 1 3) (0 2 2) (1 3 4) (2 3 1) (2 1 1)))) 292 293 ;; (edmonds-karp exemple-gt) 294 ;; ;; => 5 295 ;; (edmonds-karp (build-graphe-exemple 5 3)) 296 ;; (car (edmonds-karp (build-graphe-exemple 20))) 297 ;; (car (edmonds-karp (build-graphe-exemple 100 10))) 298 ;; (car (edmonds-karp (build-graphe-exemple 1000 10 40))) 299 ;; (car (edmonds-karp (build-graphe-exemple 10000 10 100))) 300 301 ;; (dinic exemple-gt) 302 ;; ;; => 5 303 304 (defun test-between (maxn &optional (nb-average 5) (minn 3)) 305 (loop 306 for n from (max minn 3) to maxn 307 for gts = (loop 308 repeat nb-average 309 collect (build-graphe-exemple n 100)) 310 for eks = (progn 311 (format t "~&ek ~a~&" n) 312 (time (loop 313 for gt in gts 314 collect (car (edmonds-karp gt))))) 315 for ds = (progn 316 (format t "~&di ~a~&" n) 317 (time (loop 318 for gt in gts 319 collect (car (dinic gt)))))))