diff --git a/exo5.lisp b/exo5.lisp index 64717a7..c316f83 100644 --- 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)))))