sol.scm (4011B) [raw]
1 #!/usr/local/bin/chicken-csi -ss 2 (import srfi-69 3 (chicken string) 4 (chicken io)) 5 6 ;; parse a line into a list of all points covered by rocks 7 (define (parse-line line) 8 (let ((pairs (map (lambda (p) (map string->number (string-split p ","))) 9 (string-split line " ->")))) 10 (let loop ((points '()) (ps pairs)) 11 (if (null? (cdr ps)) 12 points 13 (let ((x1 (car (car ps))) (y1 (cadr (car ps))) 14 (x2 (car (cadr ps))) (y2 (cadr (cadr ps)))) 15 (cond ((and (= x1 x2) (not (= y1 y2))) 16 (loop (append points 17 (zip (n-of-v (add1 (abs (- y1 y2))) x1) 18 (range y1 y2))) 19 (cdr ps))) 20 ((and (= y1 y2) (not (= x1 x2))) 21 (loop (append points 22 (zip (range x1 x2) 23 (n-of-v (add1 (abs (- x1 x2))) y1))) 24 (cdr ps))) 25 (else "More than one dim changed"))))))) 26 27 ; [s, ..., f] inclusive 28 (define (range s f) 29 (let ((next (if (<= s f) add1 sub1))) 30 (if (equal? s f) 31 (list f) 32 (cons s (range (next s) f))))) 33 34 (define (n-of-v n v) 35 (if (= n 0) 36 '() 37 (cons v (n-of-v (sub1 n) v)))) 38 39 (define (zip l1 l2) 40 (if (not (= (length l1) (length l2))) 41 (error "Bad zip: lengths not equal")) 42 (if (null? l1) 43 '() 44 (cons (list (car l1) (car l2)) (zip (cdr l1) (cdr l2))))) 45 46 (define (print-grid G) 47 (let* ((keys (hash-table-keys G)) 48 (max-x (apply max (map (lambda (pt) (car pt)) keys))) 49 (min-x (apply min (map (lambda (pt) (car pt)) keys))) 50 (max-y (apply max (map (lambda (pt) (cadr pt)) keys))) 51 (min-y 0)) 52 (let yloop ((y min-y)) 53 (newline) 54 (if (> y max-y) 55 'done 56 (let xloop ((x min-x)) 57 (if (> x max-x) 58 (yloop (add1 y)) 59 (cond ((hash-table-exists? G (list x y)) 60 (display (hash-table-ref G (list x y))) 61 (xloop (add1 x))) 62 (else (display ".") 63 (xloop (add1 x)))))))))) 64 65 ; just for brevity 66 (define (empty? G x y) (not (hash-table-exists? G (list x y)))) 67 68 (define (drop-sand G x y cliff) 69 (cond ((> y cliff) ; fell off the map -> we're done 70 #f) 71 ((empty? G x (add1 y)) 72 (drop-sand G x (add1 y) cliff)) 73 ; we're blocked at this point, try left/right 74 ((empty? G (sub1 x) (add1 y)) 75 (drop-sand G (sub1 x) (add1 y) cliff)) 76 ((empty? G (add1 x) (add1 y)) 77 (drop-sand G (add1 x) (add1 y) cliff)) 78 (else 79 (hash-table-set! G (list x y) 'o)))) 80 81 (define (empty-incl-floor? G x y floor) 82 (not (or (hash-table-exists? G (list x y)) 83 (= y floor)))) 84 85 (define (drop-sand-floor G x y floor) 86 (cond ((empty-incl-floor? G x (add1 y) floor) 87 (drop-sand-floor G x (add1 y) floor)) 88 ; we're blocked at this point, try left/right 89 ((empty-incl-floor? G (sub1 x) (add1 y) floor) 90 (drop-sand-floor G (sub1 x) (add1 y) floor)) 91 ((empty-incl-floor? G (add1 x) (add1 y) floor) 92 (drop-sand-floor G (add1 x) (add1 y) floor)) 93 (else 94 (if (and (= x 500) (= y 0)) 95 #f ; plugged the start -> done 96 (hash-table-set! G (list x y) 'o))))) 97 98 ;; We map the world state as a hash table (effectively a sparse matrix) 99 ;; so that we don't have to guess the vector dimensions first 100 (define (main args) 101 (let ((G (make-hash-table)) (lines (read-lines))) 102 (hash-table-set! G '(500 0) 'V) 103 (for-each (lambda (l) 104 (for-each (lambda (pt) 105 (hash-table-set! G pt 'R)) (parse-line l))) 106 lines) 107 (let* ((cliff (apply max (map (lambda (pt) (cadr pt)) (hash-table-keys G)))) 108 (floor (+ 2 cliff))) 109 ;; note: could also just count the number of 'o values instead of i 110 (let loop ((i 0)) 111 ; (print "------" i "-------") 112 ; (print-grid G) 113 (if (drop-sand G 500 0 cliff) 114 (loop (add1 i)) 115 ;; HACK: we can keep the same grid, since we stopped RIGHT at the point 116 ;; we'd hit the floor anyways--just make sure to sum your numbers together! 117 (let floop ((j 0)) 118 ;; (print "------" j "-------") 119 ;; (print-grid G) 120 (if (drop-sand-floor G 500 0 floor) 121 (floop (add1 j)) 122 (begin 123 (print i) 124 (print (+ i (add1 j))))))))) 125 (print-grid G))) 126 127 ; For repl 128 (define ls '("498,4 -> 498,6 -> 496,6" 129 "503,4 -> 502,4 -> 502,9 -> 494,9"))