utils.lisp (12476B)
1 (uiop:define-package #:aoc/utils 2 (:use #:cl) 3 (:mix-reexport #:alexandria #:serapeum #:split-sequence 4 #:group-by #:str #:queues) 5 (:import-from #:queues.simple-queue) 6 (:import-from #:queues.priority-queue) 7 (:export 8 #:read-input 9 #:read-input-fields 10 #:read-input-match 11 #:char-number 12 #:make-map 13 #:make-empty-map 14 #:print-map 15 #:map-find 16 #:input-map 17 #:input-map-width 18 #:input-map-height 19 #:map-cell 20 #:map-integer-at 21 #:point+ 22 #:point- 23 #:point* 24 #:point-mod 25 #:point-x 26 #:point-y 27 #:point-in-bounds-p 28 #:point-in-map-p 29 #:*map-neighbours* 30 #:point-neighbours 31 #:manhattan-distance 32 #:do-map-neighbours 33 #:read-number-list 34 #:find-pattern 35 #:define-parser 36 #:modular-inverse 37 #:crt)) 38 (in-package #:aoc/utils) 39 40 (defun normalize-type (type) 41 (cond 42 ((or (eq type 'string) 43 (null type)) 44 'simple-string) 45 ((eq type 'number) 46 'integer) 47 (t type))) 48 49 (defun wrap-nullable (converter) 50 (lambda (line) 51 (if (= (length line) 0) 52 nil 53 (funcall converter line)))) 54 55 (defun get-type-converter (type) 56 (wrap-nullable 57 (if (functionp type) 58 type 59 (ecase (normalize-type type) 60 (simple-string #'identity) 61 (integer #'parse-integer) 62 (keyword (compose #'make-keyword #'string-upcase)))))) 63 64 (defun read-input (input &key (type 'string)) 65 (loop with converter = (get-type-converter type) 66 for line = (read-line input nil) 67 while line 68 collect (funcall converter line))) 69 70 (defun convert-fields (converters fields) 71 (loop for converter in converters 72 for field = (pop fields) 73 collect (funcall converter field))) 74 75 (defun read-input-fields (input field-types &key (delimiter " ")) 76 (loop with converters = (mapcar #'get-type-converter 77 field-types) 78 for line = (read-line input nil) 79 while line 80 collect (convert-fields converters 81 (split-sequence delimiter line :test #'string=)))) 82 83 (defun read-input-match (input regex &key types) 84 (loop with scanner = (ppcre:create-scanner regex) 85 with converters = (and types (mapcar #'get-type-converter types)) 86 for line = (read-line input nil) 87 for groups = (and line 88 (multiple-value-bind (match groups) 89 (ppcre:scan-to-strings scanner line) 90 (and match (coerce groups 'list)))) 91 while groups 92 collect (if converters 93 (convert-fields converters groups) 94 groups))) 95 96 97 (declaim (ftype (function (character) fixnum) char-number) 98 (inline char-number)) 99 (defun char-number (char) 100 (- (char-int char) 48)) 101 102 (defstruct input-map 103 (data nil :type (simple-array simple-string)) 104 (width 0 :type fixnum) 105 (height 0 :type fixnum)) 106 107 (defun make-map (input) 108 (loop with width = nil 109 with data = nil 110 for row = (read-line input nil) 111 for height from 0 112 while (and row (> (length row) 0)) 113 when (= height 0) 114 do (setf width (length row)) 115 do (push row data) 116 finally (return (and data 117 (make-input-map :data (coerce (nreverse data) 'vector) 118 :width width 119 :height height))))) 120 121 (defun make-empty-map (width height &key (initial-element #\.)) 122 (make-input-map :data (loop with array = (make-array height 123 :element-type 'simple-string) 124 for y below height 125 do (setf (aref array y) 126 (make-array width 127 :element-type 'character 128 :initial-element initial-element)) 129 finally (return array)) 130 :width width 131 :height height)) 132 133 (defun print-map (map &key (stream *standard-output*) position) 134 (loop for y from 0 below (input-map-height map) 135 for line = (aref (input-map-data map) y) 136 if (and (not (null position)) 137 (= (point-y position) y)) 138 do (loop for c across line 139 for x from 0 140 do (format stream "~A" (if (equal (cons x y) position) #\@ c)) 141 finally (format stream "~%")) 142 else 143 do (format stream "~A~%" line))) 144 145 (defun map-find (map needle) 146 (loop for y from 0 below (input-map-height map) 147 for line = (aref (input-map-data map) y) 148 for pos = (position needle line) 149 when pos 150 do (return (cons pos y)))) 151 152 (declaim (inline point+ point- point* point-mod point-x point-y) 153 (ftype (function (cons) fixnum) point-x point-y)) 154 155 (defun point-x (point) 156 (car point)) 157 158 (defun point-y (point) 159 (cdr point)) 160 161 (defun (setf point-x) (new-value point) 162 (setf (car point) new-value)) 163 164 (defun (setf point-y) (new-value point) 165 (setf (cdr point) new-value)) 166 167 (defun point+ (point-a point-b) 168 (cons (the fixnum (+ (point-x point-a) 169 (point-x point-b))) 170 (the fixnum (+ (point-y point-a) 171 (point-y point-b))))) 172 173 (defun point- (point-a point-b) 174 (cons (the fixnum (- (point-x point-a) 175 (point-x point-b))) 176 (the fixnum (- (point-y point-a) 177 (point-y point-b))))) 178 179 (defun point* (point-a point-factor) 180 (cons (the fixnum (* (point-x point-a) 181 (point-x point-factor))) 182 (the fixnum (* (point-y point-a) 183 (point-y point-factor))))) 184 185 (defun point-mod (point-a point-divisor) 186 (cons (the fixnum (mod (point-x point-a) 187 (point-x point-divisor))) 188 (the fixnum (mod (point-y point-a) 189 (point-y point-divisor))))) 190 191 (declaim (ftype (function (cons fixnum fixnum) boolean) point-in-bounds-p) 192 (inline point-in-bounds-p point-in-map-p)) 193 (defun point-in-bounds-p (point width height) 194 (destructuring-bind (x . y) point 195 (declare (type fixnum x y)) 196 (and (>= x 0) (>= y 0) 197 (< x width) (< y height)))) 198 199 (defun point-in-map-p (point map) 200 (point-in-bounds-p point 201 (input-map-width map) 202 (input-map-height map))) 203 204 (declaim (inline map-cell map-integer-at (setf map-cell)) 205 (ftype (function (input-map cons) character) map-cell) 206 (ftype (function (character input-map cons) character) (setf map-cell))) 207 208 (defun map-cell (map point) 209 (aref (aref (input-map-data map) 210 (point-y point)) 211 (point-x point))) 212 213 (defun (setf map-cell) (new map point) 214 (let ((row (aref (input-map-data map) 215 (point-y point)))) 216 (setf (aref row (point-x point)) new))) 217 218 (defun map-integer-at (map point) 219 (parse-integer (aref (input-map-data map) (point-y point)) 220 :start (point-x point) 221 :junk-allowed t)) 222 223 (defparameter *map-neighbours* (loop for y from -1 to 1 224 nconc (loop for x from -1 to 1 225 when (not (and (= y 0) 226 (= x 0))) 227 collect (cons x y)))) 228 229 (defun point-neighbours (point) 230 (mapcar (curry #'point+ point) 231 *map-neighbours*)) 232 233 (declaim (ftype (function (cons cons) fixnum) manhattan-distance) 234 (inline manhattan-distance)) 235 236 (defun manhattan-distance (from to) 237 (+ (abs (- (point-x to) 238 (point-x from))) 239 (abs (- (point-y to) 240 (point-y from))))) 241 242 (defmacro do-map-neighbours ((neighbour-point map start-point) &body body) 243 (with-gensyms (width height lb? rb? tb? bb?) 244 (once-only ((sp start-point) 245 (mp map)) 246 `(let* ((,width (input-map-width ,mp)) 247 (,height (input-map-height ,mp)) 248 (,lb? (> (point-x ,sp) 0)) 249 (,rb? (< (point-x ,sp) (1- ,width))) 250 (,tb? (> (point-y ,sp) 0)) 251 (,bb? (< (point-y ,sp) (1- ,height)))) 252 ,@(loop for nb in *map-neighbours* 253 collect `(let ((,neighbour-point (point+ ,sp ',nb))) 254 (when (and ,@(let ((checks)) 255 (when (< (point-x nb) 0) 256 (push lb? checks)) 257 (when (< (point-y nb) 0) 258 (push tb? checks)) 259 (when (> (point-x nb) 0) 260 (push rb? checks)) 261 (when (> (point-y nb) 0) 262 (push bb? checks)) 263 checks)) 264 ,@body))))))) 265 266 (defun read-number-list (string &key (start 0)) 267 (loop for i from start below (length string) 268 collect (multiple-value-bind (number end) 269 (parse-integer string 270 :start i 271 :junk-allowed t) 272 (setf i end) 273 number))) 274 275 (defun find-pattern (list &optional (minimum-length 5)) 276 (loop for length from minimum-length to (floor (/ (length list) 2)) 277 when (loop for i below length 278 for c-1 = (elt list i) 279 for c-2 = (elt list (+ i length)) 280 always (= c-1 c-2)) 281 do (return-from find-pattern length))) 282 283 (eval-when (:compile-toplevel :load-toplevel :execute) 284 (defun transform-state-table (definitions) 285 (loop with table = (list nil nil) 286 with callbacks = nil 287 with current = nil 288 for definition in definitions 289 do (setf current table) 290 (loop for element in definition 291 do (etypecase element 292 (character 293 (setf current (or (assoc element (cddr current)) 294 (car (setf (cdr (last current)) 295 (list (list element nil))))))) 296 (list 297 (let ((sym (GENSYM "CALLBACK"))) 298 (setf (cadr current) sym) 299 (push (cons sym element) callbacks))))) 300 finally (return (values table 301 callbacks))))) 302 303 (defun do-parse (stream table) 304 (loop with current = table 305 with callback = nil 306 with global = t 307 for char = (read-char stream nil) 308 until (null char) 309 do (setf current (assoc char (cddr current)) 310 callback (cadr current)) 311 (if (or (null current) 312 (and callback 313 (null (funcall (symbol-value callback))))) 314 (progn 315 (setf current table) 316 (unless global 317 (unread-char char stream)) 318 (setf global t)) 319 (setf global nil)))) 320 321 (defmacro define-parser (name (stream) (&rest variable-bindings) &body parse-tables) 322 (multiple-value-bind (table callbacks) 323 (transform-state-table parse-tables) 324 (let ((table-var (gensym "TABLE")) 325 (callback-syms (mapcar #'car callbacks))) 326 `(defun ,name (,stream) 327 (let ((,table-var ',table) 328 ,@variable-bindings) 329 (let ,(loop for (sym . code) in callbacks 330 collect `(,sym (lambda () ,code))) 331 (declare (special ,@callback-syms)) 332 (do-parse stream ,table-var)) 333 (values ,@(mapcar #'car variable-bindings))))))) 334 335 (defun gcd-extended (a b) 336 (if (zerop b) 337 (values a 1 0) 338 (multiple-value-bind (gcd x1 y1) 339 (gcd-extended b (mod a b)) 340 (values gcd y1 (- x1 (* y1 (floor a b))))))) 341 342 (defun modular-inverse (a m) 343 (multiple-value-bind (gcd x y) 344 (gcd-extended a m) 345 (declare (ignore y)) 346 (if (/= gcd 1) 347 nil 348 (mod x m)))) 349 350 (defun crt (x y w h) 351 (let* ((m (lcm w h)) 352 (w-inv (modular-inverse w h)) 353 (h-inv (modular-inverse h w))) 354 (mod (+ (* y w w-inv) 355 (* x h h-inv)) 356 m)))