commit 9e723182f09b41430bdf5ea292e86d061d2264c9 parent 8490469fa2cd35ad0f82ae158e785fa5a0cdc4ad Author: Decay <decay@todayiwilllaunchmyinfantsonintoorbit.com> Date: Fri, 9 Dec 2022 22:57:41 -0800 Day 9 in Scheme Should be R5 Scheme, tested and run under Chicken Scheme Diffstat:
| A | 9/9.scm | | | 184 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 184 insertions(+), 0 deletions(-)
diff --git a/9/9.scm b/9/9.scm @@ -0,0 +1,184 @@ +(define signed-shift + (lambda (x) + (if (= 0 x) + 0 + (/ x (abs x))))) + +(define next-knot-position + (lambda (head-pos last-tail-pos) + (let* ((x-delta (- (car head-pos) (car last-tail-pos))) + (x-shift (signed-shift x-delta)) + (y-delta (- (cdr head-pos) (cdr last-tail-pos))) + (y-shift (signed-shift y-delta))) + (cond + ;; We only move the tail when it's no longer touching the head + ;; These conditions hold when the head moved right (+2) or left (-2) + ;; and was already to that side of the tail + ((= x-delta 2) + (cons (+ (car last-tail-pos) 1) + (+ (cdr last-tail-pos) y-shift))) ; Handle moving diagonally if necessary + ((= x-delta -2) + (cons (- (car last-tail-pos) 1) + (+ (cdr last-tail-pos) y-shift))) + + ;; These conditions hold when the head moved up (+2) or down (-2) + ;; and was already to that side of the tail + ((= y-delta 2) + (cons (+ (car last-tail-pos) x-shift) + (+ (cdr last-tail-pos) 1))) + ((= y-delta -2) + (cons (+ (car last-tail-pos) x-shift) + (- (cdr last-tail-pos) 1))) + (else last-tail-pos))))) + +(define move-knots + (lambda (knots dir n move-list) + (letrec ((last-chain (if (not (null? move-list)) + (car move-list) + '())) + (step-all-knots + (lambda (position accum) + (if (> position knots) + (reverse accum) + (let* ((last-head-knot (if (not (null? last-chain)) + (list-tail last-chain position) + '())) + (last-head-pos (if (not (null? last-head-knot)) + (car last-head-knot) + (cons 0 0))) + (last-tail-pos (if (not (null? last-head-knot)) + (cadr last-head-knot) + (cons 0 0))) + (prev-knot (if (not (null? accum)) + (car accum)))) + (if (null? accum) + (let* ((initial-head-pos + (and + (cond + ((char-ci=? dir #\u) (cons (car last-head-pos) (+ (cdr last-head-pos) 1))) ; Inc Y + ((char-ci=? dir #\d) (cons (car last-head-pos) (- (cdr last-head-pos) 1))) ; Dec Y + ((char-ci=? dir #\r) (cons (+ (car last-head-pos) 1) (cdr last-head-pos))) ; Inc X + ((char-ci=? dir #\l) (cons (- (car last-head-pos) 1) (cdr last-head-pos))))))) ; Dec X + (step-all-knots (+ position 1) + (list (next-knot-position initial-head-pos last-tail-pos) + initial-head-pos))) + (step-all-knots (+ position 1) + (cons + (next-knot-position prev-knot last-tail-pos) + accum)))))))) + (if (= n 0) + move-list + (move-knots knots + dir + (- n 1) + (cons + (step-all-knots 0 '()) + move-list)))))) + +(define read-line + (lambda (port) + (letrec ((loop + (lambda (accum) + (let ((c (read-char port))) + (if (or (eof-object? c) (char=? c #\newline)) + (reverse accum) + (loop (cons c accum))))))) + (loop '())))) + +(define read-next-move + (lambda (port) + (let ((instr (read-line port))) + (if (not (null? instr)) + (let ((cmd (car instr)) + (count (string->number (list->string (cddr instr))))) + (cons cmd count)) + '())))) + +(define build-move-list + (lambda (move-fn) + (call-with-input-file "input" + (lambda (port) + (letrec ((loop + (lambda (move-list) + (let ((this-move (read-next-move port))) + (if (null? this-move) + move-list + (loop (move-fn (car this-move) (cdr this-move) move-list))))))) + (loop '())))))) + +(define list-head + (lambda (l n) + (letrec ((loop + (lambda (l accum n) + (if (= n 0) + (reverse accum) + (loop (cdr l) (cons (car l) accum) (- n 1)))))) + (loop l '() n)))) + +;;; Orders by X from low to high and then for same X values orders by Y from low to high +(define coord-less-than? + (lambda (c1 c2) + (if (= (car c1) (car c2)) + (< (cdr c1) (cdr c2)) + (< (car c1) (car c2))))) + +;;; Sloppy with all the reverses +(define merge + (lambda (left right) + (letrec ((loop + (lambda (left right accum) + (cond + ((null? left) + (reverse (if (null? right) + accum + (append (reverse right) accum)))) + ((null? right) + (reverse (if (null? left) + accum + (append (reverse left) accum)))) + ((coord-less-than? (car left) (car right)) + (loop (cdr left) right (cons (car left) accum))) + (else (loop left (cdr right) (cons (car right) accum))))))) + (loop left right '())))) + +(define sort-moves + (lambda (move-list) + (if (<= (length move-list) 1) + move-list + (let* ((mid (quotient (length move-list) 2)) + (left (list-head move-list mid)) + (right (list-tail move-list mid))) + (merge (sort-moves left) (sort-moves right)))))) + +(define unique + (lambda (l) + (letrec ((loop + (lambda (l accum) + (cond + ((null? l) accum) + ((null? accum) + (loop (cdr l) (cons (car l) accum))) + ((and (= (caar l) (caar accum)) + (= (cdar l) (cdar accum))) (loop (cdr l) accum)) + (else (loop (cdr l) (cons (car l) accum))))))) + (loop l '())))) + +(define count-unique-spaces + (lambda (move-fn end-pos) + (let ((move-list (build-move-list move-fn))) + (length (unique (sort-moves (map (lambda (chain) + (car (list-tail chain end-pos))) + move-list))))))) + +(define solve + (lambda () + (let ((star-1 (count-unique-spaces (lambda (dir count move-list) + (move-knots 0 dir count move-list)) + 1)) + (star-2 (count-unique-spaces (lambda (dir count move-list) + (move-knots 8 dir count move-list)) + 9))) + (display "Star 1 answer: ") + (print star-1) + (display "Star 2 answer: ") + (print star-2))))