From b11a0bb1796a8c64c149992d0961910e3b7f9879 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <jahvascriptmaniac+github@free.fr>
Date: Sun, 12 Dec 2010 03:34:47 +0100
Subject: [PATCH] Edmund's crap.

---
 exo5.lisp | 143 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 143 insertions(+)
 create mode 100644 exo5.lisp

diff --git a/exo5.lisp b/exo5.lisp
new file mode 100644
index 0000000..373f08b
--- /dev/null
+++ b/exo5.lisp
@@ -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)
\ No newline at end of file