9.scm (7361B)
1 (define signed-shift 2 (lambda (x) 3 (if (= 0 x) 4 0 5 (/ x (abs x))))) 6 7 (define next-knot-position 8 (lambda (head-pos last-tail-pos) 9 (let* ((x-delta (- (car head-pos) (car last-tail-pos))) 10 (x-shift (signed-shift x-delta)) 11 (y-delta (- (cdr head-pos) (cdr last-tail-pos))) 12 (y-shift (signed-shift y-delta))) 13 (cond 14 ;; We only move the tail when it's no longer touching the head 15 ;; These conditions hold when the head moved right (+2) or left (-2) 16 ;; and was already to that side of the tail 17 ((= x-delta 2) 18 (cons (+ (car last-tail-pos) 1) 19 (+ (cdr last-tail-pos) y-shift))) ; Handle moving diagonally if necessary 20 ((= x-delta -2) 21 (cons (- (car last-tail-pos) 1) 22 (+ (cdr last-tail-pos) y-shift))) 23 24 ;; These conditions hold when the head moved up (+2) or down (-2) 25 ;; and was already to that side of the tail 26 ((= y-delta 2) 27 (cons (+ (car last-tail-pos) x-shift) 28 (+ (cdr last-tail-pos) 1))) 29 ((= y-delta -2) 30 (cons (+ (car last-tail-pos) x-shift) 31 (- (cdr last-tail-pos) 1))) 32 (else last-tail-pos))))) 33 34 (define move-knots 35 (lambda (knots dir n move-list) 36 (letrec ((last-chain (if (not (null? move-list)) 37 (car move-list) 38 '())) 39 (step-all-knots 40 (lambda (position accum) 41 (if (> position knots) 42 (reverse accum) 43 (let* ((last-head-knot (if (not (null? last-chain)) 44 (list-tail last-chain position) 45 '())) 46 (last-head-pos (if (not (null? last-head-knot)) 47 (car last-head-knot) 48 (cons 0 0))) 49 (last-tail-pos (if (not (null? last-head-knot)) 50 (cadr last-head-knot) 51 (cons 0 0))) 52 (prev-knot (if (not (null? accum)) 53 (car accum)))) 54 (if (null? accum) 55 (let* ((initial-head-pos 56 (and 57 (cond 58 ((char-ci=? dir #\u) (cons (car last-head-pos) (+ (cdr last-head-pos) 1))) ; Inc Y 59 ((char-ci=? dir #\d) (cons (car last-head-pos) (- (cdr last-head-pos) 1))) ; Dec Y 60 ((char-ci=? dir #\r) (cons (+ (car last-head-pos) 1) (cdr last-head-pos))) ; Inc X 61 ((char-ci=? dir #\l) (cons (- (car last-head-pos) 1) (cdr last-head-pos))))))) ; Dec X 62 (step-all-knots (+ position 1) 63 (list (next-knot-position initial-head-pos last-tail-pos) 64 initial-head-pos))) 65 (step-all-knots (+ position 1) 66 (cons 67 (next-knot-position prev-knot last-tail-pos) 68 accum)))))))) 69 (if (= n 0) 70 move-list 71 (move-knots knots 72 dir 73 (- n 1) 74 (cons 75 (step-all-knots 0 '()) 76 move-list)))))) 77 78 (define read-line 79 (lambda (port) 80 (letrec ((loop 81 (lambda (accum) 82 (let ((c (read-char port))) 83 (if (or (eof-object? c) (char=? c #\newline)) 84 (reverse accum) 85 (loop (cons c accum))))))) 86 (loop '())))) 87 88 (define read-next-move 89 (lambda (port) 90 (let ((instr (read-line port))) 91 (if (not (null? instr)) 92 (let ((cmd (car instr)) 93 (count (string->number (list->string (cddr instr))))) 94 (cons cmd count)) 95 '())))) 96 97 (define build-move-list 98 (lambda (move-fn) 99 (call-with-input-file "input" 100 (lambda (port) 101 (letrec ((loop 102 (lambda (move-list) 103 (let ((this-move (read-next-move port))) 104 (if (null? this-move) 105 move-list 106 (loop (move-fn (car this-move) (cdr this-move) move-list))))))) 107 (loop '())))))) 108 109 (define list-head 110 (lambda (l n) 111 (letrec ((loop 112 (lambda (l accum n) 113 (if (= n 0) 114 (reverse accum) 115 (loop (cdr l) (cons (car l) accum) (- n 1)))))) 116 (loop l '() n)))) 117 118 ;;; Orders by X from low to high and then for same X values orders by Y from low to high 119 (define coord-less-than? 120 (lambda (c1 c2) 121 (if (= (car c1) (car c2)) 122 (< (cdr c1) (cdr c2)) 123 (< (car c1) (car c2))))) 124 125 ;;; Sloppy with all the reverses 126 (define merge 127 (lambda (left right) 128 (letrec ((loop 129 (lambda (left right accum) 130 (cond 131 ((null? left) 132 (reverse (if (null? right) 133 accum 134 (append (reverse right) accum)))) 135 ((null? right) 136 (reverse (if (null? left) 137 accum 138 (append (reverse left) accum)))) 139 ((coord-less-than? (car left) (car right)) 140 (loop (cdr left) right (cons (car left) accum))) 141 (else (loop left (cdr right) (cons (car right) accum))))))) 142 (loop left right '())))) 143 144 (define sort-moves 145 (lambda (move-list) 146 (if (<= (length move-list) 1) 147 move-list 148 (let* ((mid (quotient (length move-list) 2)) 149 (left (list-head move-list mid)) 150 (right (list-tail move-list mid))) 151 (merge (sort-moves left) (sort-moves right)))))) 152 153 (define unique 154 (lambda (l) 155 (letrec ((loop 156 (lambda (l accum) 157 (cond 158 ((null? l) accum) 159 ((null? accum) 160 (loop (cdr l) (cons (car l) accum))) 161 ((and (= (caar l) (caar accum)) 162 (= (cdar l) (cdar accum))) (loop (cdr l) accum)) 163 (else (loop (cdr l) (cons (car l) accum))))))) 164 (loop l '())))) 165 166 (define count-unique-spaces 167 (lambda (move-fn end-pos) 168 (let ((move-list (build-move-list move-fn))) 169 (length (unique (sort-moves (map (lambda (chain) 170 (car (list-tail chain end-pos))) 171 move-list))))))) 172 173 (define solve 174 (lambda () 175 (let ((star-1 (count-unique-spaces (lambda (dir count move-list) 176 (move-knots 0 dir count move-list)) 177 1)) 178 (star-2 (count-unique-spaces (lambda (dir count move-list) 179 (move-knots 8 dir count move-list)) 180 9))) 181 (display "Star 1 answer: ") 182 (print star-1) 183 (display "Star 2 answer: ") 184 (print star-2))))