day20.scm (6611B)
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 operator 29 (in #\% #\&)) 30 31 (define source 32 (any-of (as-string (char-seq "broadcaster")) 33 (sequence operator letters))) 34 35 (define data-line 36 (sequence* ((label source) 37 (_ (char-seq " -> ")) 38 (first letters) 39 (rest (zero-or-more (preceded-by (char-seq ", ") letters))) 40 (_ (is #\newline))) 41 (result `(,label ,first . ,rest)))) 42 43 (define all-data 44 (one-or-more data-line)) 45 46 (define data 47 (map (lambda (line) (if (pair? (car line)) 48 (cons (cadar line) (cons (caar line) (cdr line))) 49 line)) 50 (parse all-data (read-string)))) 51 (define verbose (< (length data) 10)) 52 (when verbose (write-line (conc "Input: " data))) 53 54 ;;;;;;;;;;;;;;;;; 55 ;; First Puzzle 56 57 (define node-names (map car data)) 58 59 (define node-hash (alist->hash-table data)) 60 61 (define back-links 62 (let ((result (alist->hash-table (map (lambda (name) (list name)) 63 node-names)))) 64 (let outer-loop ((todo data)) 65 (if (null? todo) 66 result 67 (begin 68 (let inner-loop ((name (caar todo)) 69 (dest (if (equal? (caar todo) "broadcaster") 70 (cdar todo) 71 (cddar todo)))) 72 (unless (null? dest) 73 (hash-table-set! result (car dest) 74 ; (cons name (hash-table-ref result (car dest)))) 75 (cons name (hash-table-ref/default result (car dest) '()))) 76 (inner-loop name (cdr dest)))) 77 (outer-loop (cdr todo))))))) 78 79 (define memories 80 (alist->hash-table 81 (filter (lambda (line) (not (null? line))) 82 (map (lambda (line) 83 (cond ((eqv? (cadr line) #\&) 84 (cons (car line) 85 (alist->hash-table 86 (map (lambda (dest) (cons dest #f)) 87 (hash-table-ref back-links 88 (car line)))))) 89 ((eqv? (cadr line) #\%) (cons (car line) #f)) 90 (else '()))) 91 data)))) 92 93 (define (all? hash) 94 (let loop ((todo (hash-table->alist hash))) 95 (cond ((null? todo) #t) 96 ((not (cdar todo)) #f) 97 (else (loop (cdr todo)))))) 98 99 (define (run-node from high? name) 100 (if (hash-table-exists? node-hash name) 101 (let ((def (hash-table-ref node-hash name))) 102 (cond ((eqv? (car def) #\%) 103 (if high? '() 104 (let ((new-state (not (hash-table-ref memories name)))) 105 (hash-table-set! memories name new-state) 106 (map (lambda (dest) (list name new-state dest)) (cdr def))))) 107 ((eqv? (car def) #\&) 108 (let ((mem (hash-table-ref memories name))) 109 (hash-table-set! mem from high?) 110 (let ((sent-state (not (all? mem)))) 111 (map (lambda (dest) (list name sent-state dest)) (cdr def))))) 112 (else (assert #f "Unrunnable def " def " at node " name)))) 113 '())) 114 115 (define (run-list state-list) 116 (apply append (map (lambda (args) (apply run-node args)) state-list))) 117 118 (define start-list 119 (map (lambda (dest) (list "broadcaster" #f dest)) 120 (hash-table-ref node-hash "broadcaster"))) 121 122 (define (run-cycle state-list n-low n-high) 123 (if (null? state-list) 124 (list n-low n-high) 125 (run-cycle (run-list state-list) 126 (+ n-low (apply + (map (lambda (line) (if (cadr line) 0 1)) state-list))) 127 (+ n-high (apply + (map (lambda (line) (if (cadr line) 1 0)) state-list)))))) 128 129 (define (run-cycles n n-low n-high) 130 (if (= 0 n) 131 (list n-low n-high) 132 (let ((c (run-cycle start-list (add1 n-low) n-high))) 133 (run-cycles (sub1 n) (car c) (cadr c))))) 134 ;(trace run-list) 135 136 (write-line (conc "First puzzle: " (apply * (run-cycles 1000 0 0)))) 137 138 ;;;;;;;;;;;;;;;;; 139 ;; Second Puzzle 140 141 ; The second puzzle was done with eyes and paper, after having the spoiler 142 ; that the problem is supposed to be solved using the special structure of 143 ; the invidual input. 144 ; I hate this kind of puzzles. 145 146 ;(define memories 147 ; (alist->hash-table 148 ; (filter (lambda (line) (not (null? line))) 149 ; (map (lambda (line) 150 ; (cond ((eqv? (cadr line) #\&) 151 ; (cons (car line) 152 ; (alist->hash-table 153 ; (map (lambda (dest) (cons dest #f)) 154 ; (hash-table-ref back-links 155 ; (car line)))))) 156 ; ((eqv? (cadr line) #\%) (cons (car line) #f)) 157 ; (else '()))) 158 ; data)))) 159 ;(define (run-cycle-2 state-list n-low n-high n-rx) 160 ; (if (null? state-list) 161 ; (list n-low n-high n-rx) 162 ; (run-cycle-2 (run-list state-list) 163 ; (+ n-low (apply + (map (lambda (line) (if (cadr line) 0 1)) state-list))) 164 ; (+ n-high (apply + (map (lambda (line) (if (cadr line) 1 0)) state-list))) 165 ; (+ n-rx (apply + (map (lambda (line) (if (and (not (cadr line)) (equal? (caddr line) "ln")) 1 0)) state-list))) 166 ;))) 167 168 ;(define (run-cycles-2 n n-low n-high) 169 ; (let ((c (run-cycle-2 start-list (add1 n-low) n-high 0))) 170 ;(if (> (caddr c) 0) 171 ;(write-line (conc n " " (caddr c))) 172 ; (run-cycles-2 (add1 n) (car c) (cadr c))))) 173 174 ;(write-line (conc "Second puzzle: " (run-cycles-2 1 0 0)))