suzanne.soy/2010-m1s1-complexite
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Début de dinic

Browse Source
This commit is contained in:
Georges Dupéron 2010-12-12 12:50:58 +01:00
parent b11a0bb179
commit e5859506cb
1 changed files with 78 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
exo5.lisp
View File

@ -115,29 +115,82 @@
return (get-flot gt ge)
do (maj-ecart ge pcc delta)))
(defun build-transport (source puits arcs+capa)
(loop
with source = source
and puits = puits
and noeuds = (remove-duplicates (append (map 'list #'car arcs+capa)
(map 'list #'cadr arcs+capa)))
with nb-noeuds = (length noeuds)
and nb-arcs = (length arcs+capa)
with arcs-sortants = (make-array nb-noeuds :initial-element nil)
and arcs = (make-array nb-arcs)
and capa = (make-array nb-arcs)
for ac across arcs+capa
for i upfrom 0
do (push i (aref arcs-sortants (car ac)))
do (setf (aref arcs i) (cons (car ac) (cadr ac)))
do (setf (aref capa i) (caddr ac))
finally (return
(make-transport :nb-noeuds nb-noeuds
:source source
:puits puits
:arcs-sortants arcs-sortants
:arcs arcs
:capacites capa))))
(defmacro mbuild-transport (name across/in)
`(defun ,name (source puits arcs+capa)
(loop
with source = source
and puits = puits
and noeuds = (remove-duplicates (append (map 'list #'car arcs+capa)
(map 'list #'cadr arcs+capa)))
with nb-noeuds = (length noeuds)
and nb-arcs = (length arcs+capa)
with arcs-sortants = (make-array nb-noeuds :initial-element nil)
and arcs = (make-array nb-arcs)
and capa = (make-array nb-arcs)
for ac ,across/in arcs+capa
for i upfrom 0
do (push i (aref arcs-sortants (car ac)))
do (setf (aref arcs i) (cons (car ac) (cadr ac)))
do (setf (aref capa i) (caddr ac))
finally (return
(make-transport :nb-noeuds nb-noeuds
:source source
:puits puits
:arcs-sortants arcs-sortants
:arcs arcs
:capacites capa)))))
(defvar exemple-gt (build-transport 0 3 #((0 1 3) (0 2 2) (1 3 4) (2 3 1) (2 1 1))))
(edmonds-karp exemple-gt)
(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 (gt)
"Renvoie la liste des plus courts chemins de s à t dans un graphe d'écart.
Chaque 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 puits = (transport-puits gt)
and noeud-fils
and retchemins = nil
for noeud = (transport-source gt) then (file-dequeue file)
when (eql noeud puits)
return retchemins
do (dolist (arcnum (aref (transport-arcs-sortants gt) noeud))
(setq noeud-fils (cdr (aref (transport-arcs gt) arcnum)))
(unless (= 0 (aref (transport-capacites gt) arcnum))
(if (eql noeud-fils puits)
(progn
(push (cons arcnum (aref chemins noeud)) retchemins)
(file-enqueue file noeud-fils))
(unless (aref chemins noeud-fils)
(setf (aref chemins noeud-fils) (cons arcnum (aref chemins noeud)))
(file-enqueue file noeud-fils)))))
when (end-file file)
return nil
end))
(defun build-graphe-exemple (n &optional (density 10) (maxcapa 10))
(loop
with arcs = nil
with dejafait = (make-array n :initial-element nil)
for x from 0 below (- n 1)
do (loop
for i from 0 to (random density)
for y = (+ 1 (random (- n 2))) ;; +1 : ne pas aller vers 0 (la source)
when (>= y x)
do (setq y (+ y 1)) ;; Pas de boucle.
unless (member y (aref dejafait x))
do (push y (aref dejafait x))
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))
(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))