Browse code
feat: add kruskal
Edward Langley authored on 01/03/2023 10:57:20Showing 1 changed files
| 1 | 1 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,203 @@ |
| 1 |
+(defpackage :fwoar.lisp-sandbox.kruskal |
|
| 2 |
+ (:use :cl ) |
|
| 3 |
+ (:export )) |
|
| 4 |
+(in-package :fwoar.lisp-sandbox.kruskal) |
|
| 5 |
+ |
|
| 6 |
+(defclass disjoint-set () |
|
| 7 |
+ ((%size :accessor ds-size :initform 1) |
|
| 8 |
+ (%parent :accessor ds-parent :initform nil))) |
|
| 9 |
+ |
|
| 10 |
+(defmethod initialize-instance :after ((ds disjoint-set) &key) |
|
| 11 |
+ (setf (ds-parent ds) ds)) |
|
| 12 |
+(defmethod print-object ((o disjoint-set) s) |
|
| 13 |
+ (print-unreadable-object (o s :type t :identity t) |
|
| 14 |
+ (format s "size: ~d parent: ~s" |
|
| 15 |
+ (ds-size o) |
|
| 16 |
+ (unless (eql (ds-parent o) o) |
|
| 17 |
+ (ds-parent o))))) |
|
| 18 |
+ |
|
| 19 |
+(defun ds-find (ds) |
|
| 20 |
+ (if (eql (ds-parent ds) |
|
| 21 |
+ ds) |
|
| 22 |
+ ds |
|
| 23 |
+ (setf (ds-parent ds) |
|
| 24 |
+ (ds-find (ds-parent ds))))) |
|
| 25 |
+ |
|
| 26 |
+ |
|
| 27 |
+(defun ds-union (x y) |
|
| 28 |
+ (let ((x (ds-find x)) |
|
| 29 |
+ (y (ds-find y))) |
|
| 30 |
+ (unless (eql x y) |
|
| 31 |
+ (when (< (ds-size x) |
|
| 32 |
+ (ds-size y)) |
|
| 33 |
+ (rotatef x y)) |
|
| 34 |
+ (setf (ds-parent y) x |
|
| 35 |
+ (ds-size x) (+ (ds-size x) |
|
| 36 |
+ (ds-size y)))) |
|
| 37 |
+ x)) |
|
| 38 |
+ |
|
| 39 |
+(defun kruskal (edges) |
|
| 40 |
+ (let ((node-labels (make-hash-table))) |
|
| 41 |
+ (labels ((l (it) |
|
| 42 |
+ (alexandria:ensure-gethash it node-labels |
|
| 43 |
+ (make-instance 'disjoint-set))) |
|
| 44 |
+ (k-step (forest edges) |
|
| 45 |
+ (destructuring-bind ((s e . edge-rest) . rest) edges |
|
| 46 |
+ (let ((ds-s (l s)) |
|
| 47 |
+ (ds-e (l e))) |
|
| 48 |
+ (values (if (eql (ds-find ds-s) |
|
| 49 |
+ (ds-find ds-e)) |
|
| 50 |
+ forest |
|
| 51 |
+ (progn |
|
| 52 |
+ (ds-union ds-s ds-e) |
|
| 53 |
+ (cons (list* s e edge-rest) forest))) |
|
| 54 |
+ rest))))) |
|
| 55 |
+ (loop for (s e) in edges do |
|
| 56 |
+ (l s) |
|
| 57 |
+ (l e)) |
|
| 58 |
+ (loop for (forest %edges) = (multiple-value-list (k-step () edges)) |
|
| 59 |
+ then (multiple-value-list (k-step forest %edges)) |
|
| 60 |
+ while %edges |
|
| 61 |
+ finally (return (reverse forest)))))) |
|
| 62 |
+ |
|
| 63 |
+#| |
|
| 64 |
+|---+---+---+---| |
|
| 65 |
+| a | b | c | d | |
|
| 66 |
+|---+---+---+---| |
|
| 67 |
+| e | f | g | h | |
|
| 68 |
+|---+---+---+---| |
|
| 69 |
+| j | k | l | m | |
|
| 70 |
+|---+---+---+---| |
|
| 71 |
+| n | o | p | q | |
|
| 72 |
+|---+---+---+---| |
|
| 73 |
+ |
|
| 74 |
+|---+---+---+---| |
|
| 75 |
+| a | b c d | |
|
| 76 |
+| + +---+ | |
|
| 77 |
+| e f g | h | |
|
| 78 |
+|---+---+ +---| |
|
| 79 |
+| i j k l | |
|
| 80 |
+| +---+---+ | |
|
| 81 |
+| m | n o q | |
|
| 82 |
+|---+---+---+---| |
|
| 83 |
+|# |
|
| 84 |
+(defun grid-graph (max) |
|
| 85 |
+ (flet ((w () |
|
| 86 |
+ (random max))) |
|
| 87 |
+ (stable-sort `((a b ,(w)) (a e ,(w)) ;; (a f ,(w)) |
|
| 88 |
+ (b c ,(w)) (b f ,(w)) ;; (b g ,(w)) |
|
| 89 |
+ (c d ,(w)) (c g ,(w)) ;; (c h ,(w)) |
|
| 90 |
+ #| |# (d h ,(w)) ;; |
|
| 91 |
+ (e f ,(w)) (e j ,(w)) ;; (e k ,(w)) |
|
| 92 |
+ (f g ,(w)) (f k ,(w)) ;; (f l ,(w)) |
|
| 93 |
+ (g h ,(w)) (g l ,(w)) ;; (g m ,(w)) |
|
| 94 |
+ #| |# (h m ,(w)) |
|
| 95 |
+ (j k ,(w)) (j n ,(w)) ;; (j o ,(w)) |
|
| 96 |
+ (k l ,(w)) (k o ,(w)) ;; (k p ,(w)) |
|
| 97 |
+ (l m ,(w)) (l p ,(w)) ;; (l q ,(w)) |
|
| 98 |
+ #| |# (m q ,(w)) |
|
| 99 |
+ (n o ,(w)) |
|
| 100 |
+ (o p ,(w)) |
|
| 101 |
+ (p q ,(w))) |
|
| 102 |
+ '< |
|
| 103 |
+ :key #'third))) |
|
| 104 |
+ |
|
| 105 |
+(defun grid-edges (w h) |
|
| 106 |
+ (remove-if-not (lambda (it) |
|
| 107 |
+ (destructuring-bind ((s-x s-y) |
|
| 108 |
+ (e-x e-y)) |
|
| 109 |
+ it |
|
| 110 |
+ (and (< s-x w) |
|
| 111 |
+ (< e-x w) |
|
| 112 |
+ (< s-y h) |
|
| 113 |
+ (< e-y h)))) |
|
| 114 |
+ (loop for x below w |
|
| 115 |
+ append (loop for y below h |
|
| 116 |
+ append (list (list (list x y) |
|
| 117 |
+ (list x (1+ y))) |
|
| 118 |
+ (list (list x y) |
|
| 119 |
+ (list (1+ x) y))))))) |
|
| 120 |
+ |
|
| 121 |
+(defun print-grid (grid edge-map) |
|
| 122 |
+ (let ((edges (make-hash-table :test #'equal))) |
|
| 123 |
+ (loop |
|
| 124 |
+ for (s e) in edge-map do |
|
| 125 |
+ (push e (gethash s edges))) |
|
| 126 |
+ (princ #\+) |
|
| 127 |
+ (loop repeat (1- (* (array-dimension grid 1) 4)) do |
|
| 128 |
+ (princ "-")) |
|
| 129 |
+ (princ #\+) |
|
| 130 |
+ (terpri) |
|
| 131 |
+ (loop |
|
| 132 |
+ for x below (array-dimension grid 0) do |
|
| 133 |
+ (princ #\|) |
|
| 134 |
+ (loop for y below (array-dimension grid 1) |
|
| 135 |
+ do |
|
| 136 |
+ (format t " ~a " (aref grid x y)) |
|
| 137 |
+ when (< y (1- (array-dimension grid 1))) |
|
| 138 |
+ do (princ (if (member (list x (1+ y)) |
|
| 139 |
+ (gethash (list x y) |
|
| 140 |
+ edges) |
|
| 141 |
+ :test #'equal) |
|
| 142 |
+ #\space |
|
| 143 |
+ #\|))) |
|
| 144 |
+ (princ #\|) |
|
| 145 |
+ (terpri) |
|
| 146 |
+ when (< x (1- (array-dimension grid 0))) do |
|
| 147 |
+ (princ #\|) |
|
| 148 |
+ (loop for y below (array-dimension grid 1) |
|
| 149 |
+ do |
|
| 150 |
+ (princ |
|
| 151 |
+ (if (member (list (1+ x) y) |
|
| 152 |
+ (gethash (list x y) |
|
| 153 |
+ edges) |
|
| 154 |
+ :test #'equal) |
|
| 155 |
+ " " |
|
| 156 |
+ "---")) |
|
| 157 |
+ when (< y (1- (array-dimension grid 1))) |
|
| 158 |
+ do (princ #\+)) |
|
| 159 |
+ (princ #\|) |
|
| 160 |
+ (terpri)) |
|
| 161 |
+ (princ #\+) |
|
| 162 |
+ (loop repeat (1- (* (array-dimension grid 1) 4)) do |
|
| 163 |
+ (princ "-")) |
|
| 164 |
+ (princ #\+) |
|
| 165 |
+ (terpri))) |
|
| 166 |
+ |
|
| 167 |
+(defun fully-connected (n max-weight) |
|
| 168 |
+ (flet ((symbolicate (it) |
|
| 169 |
+ (coords->symbol (list (floor it (1+ (floor (sqrt n)))) |
|
| 170 |
+ (mod it (1+ (floor (sqrt n))))) |
|
| 171 |
+ n))) |
|
| 172 |
+ (let ((nodes (loop for x below n |
|
| 173 |
+ collect x))) |
|
| 174 |
+ (loop |
|
| 175 |
+ for (h . tail) on nodes |
|
| 176 |
+ append (loop for it in tail |
|
| 177 |
+ collect (list (symbolicate h) |
|
| 178 |
+ (symbolicate it) |
|
| 179 |
+ (random max-weight))))))) |
|
| 180 |
+ |
|
| 181 |
+(defun symbol->coords (sym side-len) |
|
| 182 |
+ (let* ((v (- (char-code (elt (symbol-name sym) 0)) |
|
| 183 |
+ #.(char-code #\A))) |
|
| 184 |
+ (v (if (> v 8) |
|
| 185 |
+ (1- v) |
|
| 186 |
+ v))) |
|
| 187 |
+ (list (floor v side-len) |
|
| 188 |
+ (mod v side-len)))) |
|
| 189 |
+ |
|
| 190 |
+(defun coords->symbol (coords side-len) |
|
| 191 |
+ (let ((it (+ (* side-len (elt coords 0)) |
|
| 192 |
+ (elt coords 1)))) |
|
| 193 |
+ (intern |
|
| 194 |
+ (string |
|
| 195 |
+ (code-char |
|
| 196 |
+ (+ #.(char-code #\A) |
|
| 197 |
+ (if (>= it 8) |
|
| 198 |
+ (1+ it) |
|
| 199 |
+ it))))))) |
|
| 200 |
+ |
|
| 201 |
+(defun ->graph (edges &optional (s t)) |
|
| 202 |
+ (format s "graph {~%~{~:@{~2t~a -- ~a [label=\"~a\"]~%~}~}~&}~%"
|
|
| 203 |
+ edges)) |