utils.lisp (7202B)
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 #:print-map 14 #:input-map 15 #:input-map-width 16 #:input-map-height 17 #:map-cell 18 #:map-integer-at 19 #:point+ 20 #:point- 21 #:point-x 22 #:point-y 23 #:point-neighbours 24 #:manhattan-distance 25 #:do-map-neighbours 26 #:read-number-list 27 #:find-pattern)) 28 (in-package #:aoc/utils) 29 30 (defun normalize-type (type) 31 (cond 32 ((or (eq type 'string) 33 (null type)) 34 'simple-string) 35 ((eq type 'number) 36 'integer) 37 (t type))) 38 39 (defun wrap-nullable (converter) 40 (lambda (line) 41 (if (= (length line) 0) 42 nil 43 (funcall converter line)))) 44 45 (defun get-type-converter (type) 46 (wrap-nullable 47 (if (functionp type) 48 type 49 (ecase (normalize-type type) 50 (simple-string #'identity) 51 (integer #'parse-integer) 52 (keyword (compose #'make-keyword #'string-upcase)))))) 53 54 (defun read-input (input &key (type 'string)) 55 (loop with converter = (get-type-converter type) 56 for line = (read-line input nil) 57 while line 58 collect (funcall converter line))) 59 60 (defun convert-fields (converters fields) 61 (loop for converter in converters 62 for field = (pop fields) 63 collect (funcall converter field))) 64 65 (defun read-input-fields (input field-types &key (delimiter " ")) 66 (loop with converters = (mapcar #'get-type-converter 67 field-types) 68 for line = (read-line input nil) 69 while line 70 collect (convert-fields converters 71 (split-sequence delimiter line :test #'string=)))) 72 73 (defun read-input-match (input regex &key types) 74 (loop with scanner = (ppcre:create-scanner regex) 75 with converters = (and types (mapcar #'get-type-converter types)) 76 for line = (read-line input nil) 77 for groups = (and line 78 (multiple-value-bind (match groups) 79 (ppcre:scan-to-strings scanner line) 80 (and match (coerce groups 'list)))) 81 while groups 82 collect (if converters 83 (convert-fields converters groups) 84 groups))) 85 86 87 (declaim (ftype (function (character) fixnum) char-number) 88 (inline char-number)) 89 (defun char-number (char) 90 (- (char-int char) 48)) 91 92 (defstruct input-map 93 (data nil :type (simple-array simple-string)) 94 (width 0 :type fixnum) 95 (height 0 :type fixnum)) 96 97 (defun make-map (input) 98 (loop with width = nil 99 with data = nil 100 for row = (read-line input nil) 101 for height from 0 102 while (and row (> (length row) 0)) 103 when (= height 0) 104 do (setf width (length row)) 105 do (push row data) 106 finally (return (and data 107 (make-input-map :data (coerce (nreverse data) 'vector) 108 :width width 109 :height height))))) 110 111 (defun print-map (map &key (stream *standard-output*)) 112 (loop for y from 0 below (input-map-height map) 113 do (format stream "~A~%" (aref (input-map-data map) y)))) 114 115 (declaim (inline point+ point- point-x point-y) 116 (ftype (function (cons) fixnum) point-x point-y)) 117 118 (defun point-x (point) 119 (car point)) 120 121 (defun point-y (point) 122 (cdr point)) 123 124 (defun point+ (point-a point-b) 125 (cons (the fixnum (+ (point-x point-a) 126 (point-x point-b))) 127 (the fixnum (+ (point-y point-a) 128 (point-y point-b))))) 129 130 (defun point- (point-a point-b) 131 (cons (the fixnum (- (point-x point-a) 132 (point-x point-b))) 133 (the fixnum (- (point-y point-a) 134 (point-y point-b))))) 135 136 (declaim (inline map-cell map-integer-at (setf map-cell)) 137 (ftype (function (input-map cons) character) map-cell) 138 (ftype (function (character input-map cons) character) (setf map-cell))) 139 140 (defun map-cell (map point) 141 (aref (aref (input-map-data map) 142 (point-y point)) 143 (point-x point))) 144 145 (defun (setf map-cell) (new map point) 146 (let ((row (aref (input-map-data map) 147 (point-y point)))) 148 (setf (aref row (point-x point)) new))) 149 150 (defun map-integer-at (map point) 151 (parse-integer (aref (input-map-data map) (point-y point)) 152 :start (point-x point) 153 :junk-allowed t)) 154 155 (defparameter *map-neighbours* (loop for y from -1 to 1 156 nconc (loop for x from -1 to 1 157 when (not (and (= y 0) 158 (= x 0))) 159 collect (cons x y)))) 160 161 (defun point-neighbours (point) 162 (mapcar (curry #'point+ point) 163 *map-neighbours*)) 164 165 (defun manhattan-distance (from to) 166 (+ (abs (- (point-x to) 167 (point-x from))) 168 (abs (- (point-y to) 169 (point-y from))))) 170 171 (defmacro do-map-neighbours ((neighbour-point map start-point) &body body) 172 (with-gensyms (width height lb? rb? tb? bb?) 173 (once-only ((sp start-point) 174 (mp map)) 175 `(let* ((,width (input-map-width ,mp)) 176 (,height (input-map-height ,mp)) 177 (,lb? (> (point-x ,sp) 0)) 178 (,rb? (< (point-x ,sp) (1- ,width))) 179 (,tb? (> (point-y ,sp) 0)) 180 (,bb? (< (point-y ,sp) (1- ,height)))) 181 ,@(loop for nb in *map-neighbours* 182 collect `(let ((,neighbour-point (point+ ,sp ',nb))) 183 (when (and ,@(let ((checks)) 184 (when (< (point-x nb) 0) 185 (push lb? checks)) 186 (when (< (point-y nb) 0) 187 (push tb? checks)) 188 (when (> (point-x nb) 0) 189 (push rb? checks)) 190 (when (> (point-y nb) 0) 191 (push bb? checks)) 192 checks)) 193 ,@body))))))) 194 195 (defun read-number-list (string &key (start 0)) 196 (loop for i from start below (length string) 197 collect (multiple-value-bind (number end) 198 (parse-integer string 199 :start i 200 :junk-allowed t) 201 (setf i end) 202 number))) 203 204 (defun find-pattern (list &optional (minimum-length 5)) 205 (loop for length from minimum-length to (floor (/ (length list) 2)) 206 when (loop for i below length 207 for c-1 = (elt list i) 208 for c-2 = (elt list (+ i length)) 209 always (= c-1 c-2)) 210 do (return-from find-pattern length)))