day25.scm (5988B)
1 ; Copyright (c) 2023, Natacha Porté 2 ; 3 ; Permission to use, copy, modify, and distribute this software for any 4 ; purpose with or without fee is hereby granted, provided that the above 5 ; copyright notice and this permission notice appear in all copies. 6 ; 7 ; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 ; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 ; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 ; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 ; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 ; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 ; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 15 (import (chicken io) (chicken sort) (chicken string) 16 comparse 17 trace 18 srfi-1 19 srfi-14 20 srfi-69) 21 22 ;;;;;;;;;;;;;;;;; 23 ;; Input parsing 24 25 (define letters 26 (as-string (one-or-more (in char-set:letter)))) 27 28 (define data-line 29 (sequence* ((label letters) 30 (_ (char-seq ": ")) 31 (first letters) 32 (rest (zero-or-more (preceded-by (is #\space) letters))) 33 (_ (is #\newline))) 34 (result `(,label ,first . ,rest)))) 35 36 (define all-data 37 (one-or-more data-line)) 38 39 (define data 40 (parse all-data (read-string))) 41 (define verbose (< (length data) 15)) 42 (when verbose (write-line (conc "Input: " data))) 43 44 ;;;;;;;;;;;;;;;;; 45 ;; First Puzzle 46 47 (define node-count -1) 48 (define node-ids 49 (let loop ((result (make-hash-table)) 50 (todo data) 51 (next-id 1)) 52 (cond ((null? todo) (set! node-count (sub1 next-id)) result) 53 ((null? (car todo)) (loop result (cdr todo) next-id)) 54 ((hash-table-exists? result (caar todo)) 55 (loop result (cons (cdar todo) (cdr todo)) next-id)) 56 (else (hash-table-set! result (caar todo) next-id) 57 (when verbose (write-line (conc "Using node " (caar todo) " as " next-id))) 58 (loop result (cons (cdar todo) (cdr todo)) (add1 next-id)))))) 59 60 (define (unfold-edge-list data-list) 61 (let loop ((todo data-list) (acc '())) 62 (cond ((null? todo) acc) 63 ((null? (cdar todo)) (loop (cdr todo) acc)) 64 (else (loop (cons (cons (caar todo) (cddar todo)) (cdr todo)) 65 (cons (list (caar todo) (cadar todo)) acc)))))) 66 67 (define (translate-data data-list) 68 (map (lambda (l) (map (lambda (n) (hash-table-ref node-ids n)) l)) 69 data-list)) 70 71 (define (add-edge-list! edge-vec edge-list) 72 (let loop ((todo edge-list)) 73 (if (null? todo) 74 edge-vec 75 (begin 76 (vector-set! edge-vec 77 (caar todo) 78 (cons (cadar todo) (vector-ref edge-vec (caar todo)))) 79 (vector-set! edge-vec 80 (cadar todo) 81 (cons (caar todo) (vector-ref edge-vec (cadar todo)))) 82 (loop (cdr todo)))))) 83 84 (define (connected-components mark-vec edge-vec) 85 (let loop ((start 1) 86 (todo '()) 87 (result '())) 88 (cond ((null? todo) 89 (cond ((>= start (vector-length mark-vec)) result) 90 ((vector-ref mark-vec start) 91 (loop (add1 start) '() result)) 92 (else (loop (add1 start) 93 (list start) 94 (cons 0 result))))) 95 ((vector-ref mark-vec (car todo)) 96 (loop start (cdr todo) result)) 97 (else 98 (vector-set! mark-vec (car todo) #t) 99 (loop start 100 (append (vector-ref edge-vec (car todo)) (cdr todo)) 101 (cons (add1 (car result)) (cdr result))))))) 102 103 (define (dedup l) 104 (let loop ((todo (sort! l >)) (acc '())) 105 (if (null? todo) 106 acc 107 (loop (cdr todo) 108 (if (and (not (null? acc)) (= (car acc) (car todo))) 109 acc 110 (cons (car todo) acc)))))) 111 112 (define (answer-1 edge-list seed-node) 113 (let ((mark-vec (make-vector (add1 node-count))) 114 (edge-vec (make-vector (add1 node-count)))) 115 (vector-fill! mark-vec #f) 116 (vector-fill! edge-vec '()) 117 (add-edge-list! edge-vec edge-list) 118 (vector-set! mark-vec seed-node #t) 119 (let loop ((starting? #t) 120 (changed? #f) 121 (edges-todo (vector-ref edge-vec seed-node)) 122 (edges-seen '()) 123 (result 1)) 124 (cond ((and starting? (null? edges-todo)) 125 (loop #f #f edges-seen '() result)) 126 (starting? 127 (vector-set! mark-vec (car edges-todo) #t) 128 (loop #t #f 129 (cdr edges-todo) 130 (append (vector-ref edge-vec (car edges-todo)) edges-seen) 131 (add1 result))) 132 ((null? edges-todo) 133 (cond ((= 3 (length edges-seen)) 134 (* result (- node-count result))) 135 (changed? 136 (loop #f #f (dedup edges-seen) '() result)) 137 (else 138 (loop #t #f (dedup edges-seen) '() result)))) 139 ((vector-ref mark-vec (car edges-todo)) 140 (loop #f changed? (cdr edges-todo) edges-seen result)) 141 ((>= (apply + (map (lambda (n) (if (vector-ref mark-vec n) 1 0)) 142 (vector-ref edge-vec (car edges-todo)))) 143 2) 144 (vector-set! mark-vec (car edges-todo) #t) 145 (loop #f 146 #t 147 (cdr edges-todo) 148 (append (vector-ref edge-vec (car edges-todo)) edges-seen) 149 (add1 result))) 150 (else 151 (loop #f changed? (cdr edges-todo) (cons (car edges-todo) edges-seen) result)))))) 152 153 (write-line (conc "First puzzle: " 154 (answer-1 (unfold-edge-list (translate-data data)) 155 (hash-table-ref node-ids (cadar data)))))