commit c395a517fafcf35030024edcc68ec1622d9aade6
parent 8eafc6e7336f9177af5992e234841a5a06ac4ced
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Sun, 12 Dec 2010 16:37:31 +0100
Hop ! dinic (il manque juste la routine qui le lance 50x pour tester la vitesse.
Diffstat:
| M | exo5.lisp | | | 128 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------------- |
1 file changed, 102 insertions(+), 26 deletions(-)
diff --git a/exo5.lisp b/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))
-\ No newline at end of file
+(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)))))
