Hop ! dinic (il manque juste la routine qui le lance 50x pour tester la vitesse.
This commit is contained in:
Georges Dupéron
parent
8eafc6e733
commit
c395a517fa
127
exo5.lisp
127
exo5.lisp
|
|
@ -48,20 +48,20 @@
|
|||
|
||||
(defun transport->couche (gt)
|
||||
(let ((ge (transport->ecart gt)))
|
||||
(make-transport :nb-noeuds (transport-nb-noeuds ge)
|
||||
:source (transport-source ge)
|
||||
:puits (transport-puits ge)
|
||||
:arcs-sortants (transport-arcs-sortants ge)
|
||||
:arcs (transport-arcs ge)
|
||||
:capacites (transport-capacites ge)
|
||||
:present (make-array (length (transport-arcs ge))))))
|
||||
(make-couche :nb-noeuds (transport-nb-noeuds ge)
|
||||
:source (transport-source ge)
|
||||
:puits (transport-puits ge)
|
||||
:arcs-sortants (transport-arcs-sortants ge)
|
||||
:arcs (transport-arcs ge)
|
||||
:capacites (transport-capacites ge)
|
||||
:present (make-array 1 :initial-element nil)))) ;; sera écrasé par liste-plus-courts-chemins
|
||||
|
||||
(defun plus-court-chemin (gt)
|
||||
"Renvoie le plus court chemin de s à t dans un graphe d'écart.
|
||||
Le chemin est représenté par les numéros des :arcs qui le composent, du puits à la source."
|
||||
(loop named pcc
|
||||
with file = (make-file)
|
||||
and chemins = (make-array (transport-nb-noeuds gt) :element-type t :initial-element nil) ;; TODO
|
||||
and chemins = (make-array (transport-nb-noeuds gt) :element-type t :initial-element nil)
|
||||
and puits = (transport-puits gt)
|
||||
and noeud-fils
|
||||
for noeud = (transport-source gt) then (file-dequeue file)
|
||||
|
|
@ -94,7 +94,7 @@
|
|||
for arcnum in (aref (flot-arcs-sortants gf) (transport-source gf))
|
||||
sum (aref (flot-flots gf) arcnum)))
|
||||
|
||||
(defun get-valeurs-flot (gt ge)
|
||||
(defun transport/couche->flot (gt ge/c)
|
||||
(loop
|
||||
with len = (length (transport-arcs gt))
|
||||
with len2 = (* len 2)
|
||||
|
|
@ -106,13 +106,14 @@
|
|||
:arcs (transport-arcs gt)
|
||||
:capacites (transport-capacites gt)
|
||||
:flots f)
|
||||
and capa = (if (transport-p ge/c) (transport-capacites ge/c) (couche-capacites ge/c))
|
||||
for i from 0 below len
|
||||
for i2 from 1 below len2 by 2
|
||||
do (setf (aref f i) (aref (transport-capacites ge) i2))
|
||||
do (setf (aref f i) (aref capa i2))
|
||||
finally (return gf)))
|
||||
|
||||
(defun get-flot (gt ge)
|
||||
(let ((flot (get-valeurs-flot gt ge)))
|
||||
(defun get-flot (gt ge/c)
|
||||
(let ((flot (transport/couche->flot gt ge/c)))
|
||||
(cons (get-flot-max flot) flot)))
|
||||
|
||||
(defun edmonds-karp (gt)
|
||||
|
|
@ -152,9 +153,6 @@
|
|||
(mbuild-transport build-transport-array across)
|
||||
(mbuild-transport build-transport-list in)
|
||||
|
||||
(defvar exemple-gt (build-transport-array 0 3 #((0 1 3) (0 2 2) (1 3 4) (2 3 1) (2 1 1))))
|
||||
(edmonds-karp exemple-gt)
|
||||
|
||||
(defun liste-plus-courts-chemins (gc)
|
||||
"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)."
|
||||
(loop named pcc
|
||||
|
|
@ -166,17 +164,19 @@
|
|||
and puits = (couche-puits gc)
|
||||
and noeud-fils
|
||||
for noeud = (couche-source gc) then (file-dequeue file)
|
||||
initially (setf (couche-present gc) (make-array (length (couche-present gc)) :initial-element -1))
|
||||
initially (setf (couche-present gc) (make-array (length (couche-arcs gc)) :initial-element nil))
|
||||
initially (setf (aref dejavu (couche-source gc)) niveau)
|
||||
when (eql noeud puits)
|
||||
return gc ;; TODO
|
||||
return gc
|
||||
do (dolist (arcnum (aref (couche-arcs-sortants gc) noeud))
|
||||
(setq noeud-fils (cdr (aref (couche-arcs gc) arcnum)))
|
||||
(unless (= 0 (aref (couche-capacites gc) arcnum))
|
||||
(unless (>= 0 (aref dejavu noeud))
|
||||
(unless (= niveau (aref dejavu noeud))
|
||||
(file-enqueue file2 noeud-fils)
|
||||
(setf (aref dejavu noeud) niveau))
|
||||
(setf (aref (couche-present gc) arcnum) t)))) ;; Fait partie de la couche
|
||||
(unless (= 0 (aref (couche-capacites gc) arcnum)) ;; Pas les arcs saturés
|
||||
(if (= (aref dejavu noeud-fils) niveau) ;; Lorsqu'on a déjà vu le noeud dans cette couche
|
||||
(setf (aref (couche-present gc) arcnum) niveau) ;; => L'arc fait partie de la couche
|
||||
(when (= (aref dejavu noeud-fils) -1) ;; Lorsqu'on n'a jamais vu le noeud
|
||||
(file-enqueue file2 noeud-fils) ;; On l'ajoute à la file d'attente
|
||||
(setf (aref dejavu noeud-fils) niveau) ;; Il fait partie du niveau courant
|
||||
(setf (aref (couche-present gc) arcnum) niveau))))) ;; Fait partie de la couche
|
||||
when (end-file file)
|
||||
do (setq file file2)
|
||||
and when (end-file file)
|
||||
|
|
@ -186,6 +186,66 @@
|
|||
and do (setq file2 (make-file))
|
||||
end))
|
||||
|
||||
(defun maj-ecart-couche (gc)
|
||||
(let ((noeud-fils nil)
|
||||
(liste-arcs-sortants (aref (couche-arcs-sortants gc) (couche-source gc)))
|
||||
(numarc nil)
|
||||
(delta nil)
|
||||
(pile-arcs-sortants nil)
|
||||
(pile-delta nil)
|
||||
(pile-arcs nil))
|
||||
(tagbody
|
||||
loopstart
|
||||
(when (endp liste-arcs-sortants)
|
||||
(go pop))
|
||||
(setq numarc (pop liste-arcs-sortants))
|
||||
(unless (aref (couche-present gc) numarc) ;; Ne prendre en compte que les arcs qui sont dans le graphe de couche
|
||||
(go loopstart))
|
||||
(unless (> (aref (couche-capacites gc) numarc) 0) ;; Ne pas prendre en compte les arcs qu'on a saturés durant cette fonction
|
||||
(go loopstart))
|
||||
(push numarc pile-arcs)
|
||||
(setq noeud-fils (cdr (aref (couche-arcs gc) numarc)))
|
||||
;; TODO : sortir ce if le plus haut possible, ça coûte cher à chaque itération…
|
||||
(setq delta (if delta
|
||||
(min delta (aref (couche-capacites gc) numarc))
|
||||
(aref (couche-capacites gc) numarc)))
|
||||
(if (eql noeud-fils (couche-puits gc))
|
||||
(progn
|
||||
(loop
|
||||
for pdelta on pile-delta
|
||||
do (decf (car pdelta) delta))
|
||||
(loop
|
||||
;; Remonter jusqu'à la racine en faisant +/- avec delta
|
||||
for arcnum in pile-arcs
|
||||
for arcnumpair = (if (evenp arcnum) arcnum (- arcnum 1))
|
||||
do (decf (aref (couche-capacites gc) arcnumpair) delta)
|
||||
do (incf (aref (couche-capacites gc) (+ arcnumpair 1)) delta)
|
||||
;; pop de la pile
|
||||
finally (push liste-arcs-sortants pile-arcs-sortants)
|
||||
finally (go pop)))
|
||||
(progn
|
||||
(push liste-arcs-sortants pile-arcs-sortants)
|
||||
(push delta pile-delta)
|
||||
;; Récupérer la liste des arcs sortants
|
||||
(setq liste-arcs-sortants (aref (couche-arcs-sortants gc) noeud-fils))
|
||||
(go loopstart)))
|
||||
pop
|
||||
(unless (endp pile-arcs-sortants)
|
||||
(setq delta (pop pile-delta))
|
||||
(setq liste-arcs-sortants (pop pile-arcs-sortants))
|
||||
(setf pile-arcs (cdr pile-arcs))
|
||||
(go loopstart))
|
||||
end)
|
||||
gc))
|
||||
|
||||
(defun dinic (gt)
|
||||
(loop
|
||||
with gc = (transport->couche gt)
|
||||
for gc-pcc = (liste-plus-courts-chemins gc)
|
||||
unless gc-pcc
|
||||
return (get-flot gt gc)
|
||||
do (maj-ecart-couche gc)))
|
||||
|
||||
(defun build-graphe-exemple (n &optional (density 10) (maxcapa 10))
|
||||
(loop
|
||||
with arcs = nil
|
||||
|
|
@ -201,10 +261,27 @@
|
|||
and do (push (list x y (random maxcapa)) arcs))
|
||||
finally (return (build-transport-list 0 (- n 1) arcs))))
|
||||
|
||||
;; (edmonds-karp (build-graphe-exemple 5 3))
|
||||
(defvar exemple-gt (build-transport-array 0 3 #((0 1 3) (0 2 2) (1 3 4) (2 3 1) (2 1 1))))
|
||||
|
||||
(edmonds-karp exemple-gt)
|
||||
;; => 5
|
||||
(edmonds-karp (build-graphe-exemple 5 3))
|
||||
(car (edmonds-karp (build-graphe-exemple 20)))
|
||||
(car (edmonds-karp (build-graphe-exemple 100 10)))
|
||||
(car (edmonds-karp (build-graphe-exemple 1000 10 40)))
|
||||
(car (edmonds-karp (build-graphe-exemple 10000 10 100)))
|
||||
|
||||
(liste-plus-courts-chemins (transport->ecart exemple-gt))
|
||||
(dinic exemple-gt)
|
||||
;; => 5
|
||||
|
||||
;; TODO :
|
||||
|
||||
;; (defun test-under (maxn)
|
||||
;; (loop
|
||||
;; for n from 2 to maxn
|
||||
;; collect (loop
|
||||
;; for i from 0 to 4
|
||||
;; for gt = (build-graphe-exemple 20)
|
||||
;; collect (time (edmonds-karp gt)) into t-ek
|
||||
;; collect (time (dinic gt)) into t-d
|
||||
;; finally (return (list n t-ek t-d)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user