sol.scm (4311B) [raw]
1 #!/usr/local/bin/chicken-csi -ss 2 (import (chicken io) 3 (chicken string)) 4 5 ; utils 6 (define (range n) 7 (if (equal? n 0) 8 '(0) 9 (append (range (sub1 n)) (list n)))) 10 11 (define (filter pred lst) 12 (if (null? lst) 13 '() 14 (if (pred (car lst)) 15 (cons (car lst) (filter pred (cdr lst))) 16 (filter pred (cdr lst))))) 17 18 (define (first-n lst n) 19 (if (equal? n 0) 20 '() 21 (cons (car lst) (first-n (cdr lst) (sub1 n))))) 22 23 (define (n-on lst n) 24 (if (equal? n 0) 25 lst 26 (n-on (cdr lst) (sub1 n)))) 27 28 ; [D] 29 ; [N] [C] => ((N Z) (D C M) (P)) 30 ; [Z] [M] [P] 31 ; 1 2 3 32 33 ; key insight: chars are at 1 5 ... N - 2 (where n = length) 34 (define (get-mask n) 35 (filter (lambda (x) (eq? (modulo x 4) 1)) 36 (range n))) 37 38 (define (get-boxes line) 39 (map (lambda (k) (substring line k (add1 k))) 40 (get-mask (string-length line)))) 41 42 (define (add-layer boxes stacks) 43 (cond ((null? boxes) 44 '()) 45 ((equal? (car boxes) " ") 46 (cons (car stacks) (add-layer (cdr boxes) (cdr stacks)))) 47 (else 48 (cons (cons (car boxes) (car stacks)) 49 (add-layer (cdr boxes) (cdr stacks)))))) 50 51 (define (init-stacks n) 52 (map (lambda (x) '()) (get-mask n))) 53 54 (define (parse-boxes lines) 55 (let ((n (string-length (car lines)))) 56 (let loop ((lines lines) (stacks (init-stacks n))) 57 (let ((l (car lines))) 58 (if (equal? l "") 59 (map (lambda (s) (reverse (cdr s))) stacks) 60 (loop (cdr lines) (add-layer (get-boxes l) stacks))))))) 61 62 ; move N from A to B -> (N A B) 63 (define (parse-move x) 64 (let* ((parts (string-split x)) 65 (count (string->number (list-ref parts 1))) 66 (from (sub1 (string->number (list-ref parts 3)))) 67 (to (sub1 (string->number (list-ref parts 5))))) 68 (list count from to))) 69 70 ; TODO: this could be filter + map 71 (define (parse-moves lines) 72 (cond ((null? lines) '()) 73 ((and (> (string-length (car lines)) 0) 74 (equal? (substring (car lines) 0 1) "m")) 75 (cons (parse-move (car lines)) (parse-moves (cdr lines)))) 76 (else (parse-moves (cdr lines))))) 77 78 (define (pop-box stacks k) 79 (if (>= k (length stacks)) 80 (error "Bad pop") 81 (if (equal? k 0) 82 (values (caar stacks) (cons (cdar stacks) (cdr stacks))) 83 (let-values (((b sts) (pop-box (cdr stacks) (sub1 k)))) 84 (values b (cons (car stacks) sts)))))) 85 86 (define (push-box stacks k e) 87 (if (>= k (length stacks)) 88 (error "Bad push") 89 (if (equal? k 0) 90 (cons (cons e (car stacks)) (cdr stacks)) 91 (cons (car stacks) (push-box (cdr stacks) (sub1 k) e))))) 92 93 (define (pop-boxes stacks k n) 94 (if (>= k (length stacks)) 95 (error "Bad pop") 96 (if (equal? k 0) 97 (values (first-n (car stacks) n) (cons (n-on (car stacks) n) (cdr stacks))) 98 (let-values (((b sts) (pop-boxes (cdr stacks) (sub1 k) n))) 99 (values b (cons (car stacks) sts)))))) 100 101 (define (push-boxes stacks k e) 102 (if (>= k (length stacks)) 103 (error "Bad push") 104 (if (equal? k 0) 105 (cons (append e (car stacks)) (cdr stacks)) 106 (cons (car stacks) (push-boxes (cdr stacks) (sub1 k) e))))) 107 108 (define (play-move-1 move stacks) 109 (let ((n (car move)) 110 (f (cadr move)) 111 (t (caddr move))) 112 (let-values (((boxes sts) (pop-boxes stacks f n))) 113 (push-boxes sts t (reverse boxes))))) 114 115 ; same as 1, but no reverse 116 (define (play-move-2 move stacks) 117 (let ((n (car move)) 118 (f (cadr move)) 119 (t (caddr move))) 120 (let-values (((boxes sts) (pop-boxes stacks f n))) 121 (push-boxes sts t boxes)))) 122 123 (define (play-moves moves stacks player) 124 (if (null? moves) 125 stacks 126 (play-moves (cdr moves) (player (car moves) stacks) player))) 127 128 ; TODO: add1/sub1 on stack nums, iterate, profit 129 (define (main args) 130 (let* ((lines (read-lines)) 131 (stacks (parse-boxes lines)) 132 (moves (parse-moves lines))) 133 (for-each (lambda (s) (display (car s))) 134 (play-moves moves stacks play-move-1)) 135 (newline) 136 (for-each (lambda (s) (if (not (eq? 'tmp (car s))) (display (car s)))) 137 (play-moves moves (append stacks '((tmp))) play-move-2)) 138 (newline))) 139 140 ; test data for the REPL 141 (define sks '((N Z) (D C M) (P))) 142 143 (main '())