143 lines
5.2 KiB
Common Lisp
143 lines
5.2 KiB
Common Lisp
(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) |