day12.scm (5728B)
1 (use-modules (ice-9 popen))
2 (use-modules (ice-9 rdelim))
3 (use-modules (ice-9 format))
4 (use-modules (srfi srfi-1))
5
6 (define (parse-numbers numbers)
7 (filter (lambda (x) x) (map string->number (string-split numbers #\,))))
8
9 (define (parse-input filename)
10 (let ((file (open-input-file filename))
11 (records '()))
12 (while #t
13 (let ((line (car (%read-line file))))
14 (if (eof-object? line)
15 (break)
16 (let* ((tmp (string-split line #\ ))
17 (pattern (string->list (car tmp)))
18 (group (parse-numbers (list-ref tmp 1))))
19 (set! records (cons (list pattern group) records))))))
20 records))
21
22 (define (check-group pattern curr-count curr-group)
23 (if (null? pattern)
24 (if (> curr-count 0)
25 (append curr-group (list curr-count))
26 curr-group)
27 (case (car pattern)
28 ((#\.) (if (> curr-count 0)
29 (check-group (cdr pattern) 0 (append curr-group (list curr-count)))
30 (check-group (cdr pattern) 0 curr-group)))
31 ((#\#) (check-group (cdr pattern) (1+ curr-count) curr-group)))))
32
33 (define (group-cmp prefix-group target-group strict prefix-group-ended)
34 ;; strict forces same length, otherwise only prefix part is checked
35 ;; prefix-group-ended indicates if last group can still change
36 (if (null? target-group)
37 (null? prefix-group)
38 (if (null? prefix-group)
39 (not strict)
40 (if (= (car prefix-group) (car target-group))
41 (group-cmp (cdr prefix-group) (cdr target-group) strict prefix-group-ended)
42 ;; can make this part smarter to cut more branches
43 (if (and (= (length prefix-group) 1) (not prefix-group-ended))
44 (< (car prefix-group) (car target-group))
45 #f)))))
46
47 (define (is-prefix-valid max-len prefix group)
48 (let ((prefix-group (check-group prefix 0 '()))
49 (strict (= max-len (length prefix)))
50 (prefix-group-ended (or (= max-len (length prefix))
51 (and (> (length prefix) 0)
52 (equal? (list-ref prefix (1- (length prefix))) #\.)))))
53 ;; (display (list "valid-check" prefix-group group strict prefix-group-ended)) (newline)
54 (group-cmp prefix-group group strict prefix-group-ended)))
55
56 (define (get-determined-prefix pattern prefix)
57 (if (null? pattern)
58 prefix
59 (if (equal? (car pattern) #\?)
60 prefix
61 (get-determined-prefix (cdr pattern)
62 (append prefix (list (car pattern)))))))
63
64 (define (expand-pattern pattern)
65 (let ((candidates '()))
66 (do ((i 0 (1+ i))) ((or (>= i (length pattern)) (not (null? candidates))))
67 (if (equal? (list-ref pattern i) #\?)
68 (begin
69 (let ((tmp (list-copy pattern)))
70 (list-set! tmp i #\.)
71 (set! candidates (cons tmp candidates)))
72 (let ((tmp (list-copy pattern)))
73 (list-set! tmp i #\#)
74 (set! candidates (cons tmp candidates))))))
75 candidates))
76
77 (define (find-valid-permutation pattern group)
78 (let ((queue (list pattern))
79 (valid-count 0))
80 (while (> (length queue) 0)
81 (let* ((curr (car queue))
82 (curr-prefix (get-determined-prefix curr '()))
83 (curr-prefix-valid (is-prefix-valid (length curr) curr-prefix group))
84 (curr-prefix-ended (= (length curr-prefix) (length curr))))
85 ;; (display (list "queue" queue)) (newline)
86 ;; (display (list "curr" curr curr-prefix curr-prefix-valid curr-prefix-ended)) (newline)
87 (set! queue (cdr queue))
88 (if curr-prefix-valid
89 (if curr-prefix-ended
90 (begin
91 ;; (display (list "found valid" curr-prefix)) (newline)
92 (set! valid-count (1+ valid-count)))
93 (let ((candidates (expand-pattern curr)))
94 (set! queue (append candidates queue)))))
95 )
96 )
97 ;; (display (list "found" valid-count "permutations for" pattern group)) (newline)
98 valid-count
99 )
100 )
101
102 (define (repeat lst n sep)
103 (if (= n 1)
104 lst
105 (if (null? sep)
106 (append lst (repeat lst (1- n) sep))
107 (append lst (list sep) (repeat lst (1- n) sep)))))
108
109 (let* ((records (parse-input "input.txt"))
110 (permutations
111 (map (lambda (x) (find-valid-permutation (car x) (car (cdr x)))) records))
112 (total-permutation (fold + 0 permutations))
113 ;; (permutations-2
114 ;; (map (lambda (x) (find-valid-permutation (repeat (car x) 2 #\?)
115 ;; (repeat (car (cdr x)) 2 #nil))) records))
116 ;; (total-permutation-2 (fold + 0 permutations))
117 )
118 ;; this won't work for part 2, we need a (log n) algo or something that takes
119 ;; the entire sequence into consideration. consider separating the pattern by
120 ;; all the consecutive runs of #\., that gives us the blocks to build on. each
121 ;; block can match from 0 to len / 2 groups. then within each block fromed
122 ;; only by #\# and #\?, we check how many ways there are to form specified
123 ;; groups. some memorization could help. may need to break blocks down further
124 ;; at #\# boundaries, i.e. we need to know ?###??? can never make (1) and
125 ;; needs at least (3). maybe list these as "mergable" blocks: i.e. ?### gives
126 ;; ((() (1)) 3) => ((3) (4)).
127
128 ;; need some kind of memoization/dynamic programming
129
130 ;; 7007
131 (format #t "Part 1: ~d" total-permutation)
132 (newline)
133 ;; (format #t "Part 2: ~d" total-permutation-2)
134 ;; (newline)
135 )