Edmund's crap.
This commit is contained in:
Georges Dupéron
parent
9109316231
commit
b11a0bb179
143
exo5.lisp
Normal file
143
exo5.lisp
Normal file
|
|
@ -0,0 +1,143 @@
|
|||
(defstruct (transport) nb-noeuds source puits arcs-sortants arcs capacites)
|
||||
(defstruct (flot (:include transport)) flots)
|
||||
(defstruct (file) (tete nil) (queue nil))
|
||||
(defun list->file (l)
|
||||
(make-file l (last l)))
|
||||
(defun end-file (f)
|
||||
(endp (file-tete f)))
|
||||
(defun file-enqueue (f x)
|
||||
(if (endp (file-tete f))
|
||||
(progn (setf (file-tete f) (list x))
|
||||
(setf (file-queue f) (file-tete f)))
|
||||
(progn (setf (cdr (file-queue f)) (cons x nil))
|
||||
(setf (file-queue f) (cdr (file-queue f))))))
|
||||
|
||||
(defun file-dequeue (f)
|
||||
(prog1 (car (file-tete f))
|
||||
(setf (file-tete f) (cdr (file-tete f)))
|
||||
(when (endp (file-tete f))
|
||||
(setf (file-queue f) nil))))
|
||||
|
||||
(defun transport->ecart (gt)
|
||||
(loop
|
||||
with len = (* 2 (length (transport-arcs gt)))
|
||||
with as = (make-array (transport-nb-noeuds gt) :initial-element nil)
|
||||
and a = (make-array len)
|
||||
and c = (make-array len)
|
||||
and index
|
||||
and index2
|
||||
with ge = (make-transport :nb-noeuds (transport-nb-noeuds gt)
|
||||
:source (transport-source gt)
|
||||
:puits (transport-puits gt)
|
||||
:arcs-sortants as
|
||||
:arcs a
|
||||
:capacites c)
|
||||
for arc across (transport-arcs gt)
|
||||
for cap across (transport-capacites gt)
|
||||
for i upfrom 0
|
||||
do (setq index (* 2 i))
|
||||
do (setq index2 (+ 1 index))
|
||||
do (push index (aref as (car arc)))
|
||||
do (push index2 (aref as (cdr arc)))
|
||||
do (setf (aref a index) arc)
|
||||
do (setf (aref a index2) (cons (cdr arc) (car arc)))
|
||||
do (setf (aref c index) cap)
|
||||
do (setf (aref c index2) 0)
|
||||
finally (return ge)))
|
||||
|
||||
;; TODO : kdo
|
||||
|
||||
(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 puits = (transport-puits gt)
|
||||
and noeud-fils
|
||||
for noeud = (transport-source gt) then (file-dequeue file)
|
||||
do (dolist (arcnum (aref (transport-arcs-sortants gt) noeud))
|
||||
(setq noeud-fils (cdr (aref (transport-arcs gt) arcnum)))
|
||||
(unless (or (aref chemins noeud-fils) (= 0 (aref (transport-capacites gt) arcnum)))
|
||||
(setf (aref chemins noeud-fils) (cons arcnum (aref chemins noeud)))
|
||||
(file-enqueue file noeud-fils)
|
||||
(when (eql noeud-fils puits)
|
||||
(return-from pcc (aref chemins puits)))))
|
||||
when (end-file file)
|
||||
return nil
|
||||
end))
|
||||
|
||||
(defun delta-sur-chemin (gt chemin)
|
||||
(loop
|
||||
for arcnum in chemin
|
||||
with capa = (transport-capacites gt)
|
||||
minimize (aref capa arcnum)))
|
||||
|
||||
(defun maj-ecart (ge chemin delta)
|
||||
(loop
|
||||
for arcnum in chemin
|
||||
for arcnumpair = (if (evenp arcnum) arcnum (- arcnum 1))
|
||||
do (decf (aref (transport-capacites ge) arcnumpair) delta)
|
||||
do (incf (aref (transport-capacites ge) (+ arcnumpair 1)) delta)))
|
||||
|
||||
(defun get-flot-max (gf)
|
||||
(loop
|
||||
for arcnum in (aref (flot-arcs-sortants gf) (transport-source gf))
|
||||
sum (aref (flot-flots gf) arcnum)))
|
||||
|
||||
(defun get-valeurs-flot (gt ge)
|
||||
(loop
|
||||
with len = (length (transport-arcs gt))
|
||||
with len2 = (* len 2)
|
||||
with f = (make-array len)
|
||||
with gf = (make-flot :nb-noeuds (transport-nb-noeuds gt)
|
||||
:source (transport-source gt)
|
||||
:puits (transport-puits gt)
|
||||
:arcs-sortants (transport-arcs-sortants gt)
|
||||
:arcs (transport-arcs gt)
|
||||
:capacites (transport-capacites gt)
|
||||
:flots f)
|
||||
for i from 0 below len
|
||||
for i2 from 1 below len2 by 2
|
||||
do (setf (aref f i) (aref (transport-capacites ge) i2))
|
||||
finally (return gf)))
|
||||
|
||||
(defun get-flot (gt ge)
|
||||
(let ((flot (get-valeurs-flot gt ge)))
|
||||
(cons (get-flot-max flot) flot)))
|
||||
|
||||
(defun edmonds-karp (gt)
|
||||
(loop
|
||||
with ge = (transport->ecart gt)
|
||||
for pcc = (plus-court-chemin ge)
|
||||
for delta = (delta-sur-chemin ge pcc)
|
||||
unless pcc
|
||||
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))))
|
||||
|
||||
(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)
|
||||
Loading…
Reference in New Issue
Block a user