From cfd27965fbdc3b7d1c994d309f11d5af3acc0fe8 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sun, 18 Dec 2016 11:05:34 -0800
Subject: [PATCH] y17

---
 2016/day17/input.rkt |  2 ++
 2016/day17/lang.rkt  | 76 ++++++++++++++++++++++++++++++++++++++++++++
 2016/day17/test.rkt  |  2 ++
 3 files changed, 80 insertions(+)
 create mode 100644 2016/day17/input.rkt
 create mode 100644 2016/day17/lang.rkt
 create mode 100644 2016/day17/test.rkt

diff --git a/2016/day17/input.rkt b/2016/day17/input.rkt
new file mode 100644
index 0000000..dcdb925
--- /dev/null
+++ b/2016/day17/input.rkt
@@ -0,0 +1,2 @@
+#lang reader "lang.rkt"
+hhhxzeay
\ No newline at end of file
diff --git a/2016/day17/lang.rkt b/2016/day17/lang.rkt
new file mode 100644
index 0000000..3ade62a
--- /dev/null
+++ b/2016/day17/lang.rkt
@@ -0,0 +1,76 @@
+#lang br/quicklang ;; http://adventofcode.com/2016/day/17
+(require openssl/md5 sugar/cache)
+(provide read-syntax
+         (rename-out [mb #%module-begin]))
+
+(define (read-syntax path port)
+  (strip-bindings
+   #`(module mod "lang.rkt"
+       #,(string-trim (port->string port)))))
+
+(define-macro (mb STR)
+  #'(#%module-begin
+     (displayln (solve-shortest STR))
+     (displayln (solve-longest STR))))
+
+(define (path->dirs path)
+  (regexp-match* #rx"[UDLR]" path))
+
+(define (on-grid? pos)
+  (and (<= 0 (real-part pos) 3)
+       (<= 0 (imag-part pos) 3)))
+
+(define/caching (follow-path path)
+  (define result (regexp-match #rx"^(.*)([UDLR])$" path))
+  (define end
+    (cond
+      [result
+       (match-define (list _ prefix suffix) result)
+       (+ (follow-path prefix) (case suffix
+                                 [("D") +i]
+                                 [("U") -i]
+                                 [("L") -1]
+                                 [("R") 1]))]
+      [else 0]))
+  (and (on-grid? end) end))
+
+(define/caching (get-hash str)
+  (md5 (open-input-string str)))
+
+(define (take-step path)
+  (define hash (get-hash path))
+  (define prefix (car (regexp-match #rx"^...." hash)))
+  (define possible-dirs
+    (for/list ([dir (in-list (list "U" "D" "L" "R"))]
+               [c (in-string prefix)]
+               #:when (member c '(#\b #\c #\d #\e #\f)))
+      dir))
+  (for*/list ([dir (in-list possible-dirs)]
+              [path+dir (in-value (string-append path dir))]
+              #:when (follow-path path+dir))
+    path+dir))
+
+(define vault 3+3i)
+
+(define (solve-shortest str)
+  (let loop ([paths (list str)])
+     (define stepped-paths (append-map take-step paths))
+     (if (empty? stepped-paths)
+         'no-solution
+         (or (for/first ([sp (in-list stepped-paths)]
+                         #:when (= vault (follow-path sp)))
+               (apply string-append (path->dirs sp)))
+             (loop stepped-paths)))))
+
+(define (solve-longest str)
+  (length
+   (path->dirs
+    (argmax string-length
+            (let loop ([paths (list str)][vault-paths empty][i 0])
+              (cond
+                [(empty? paths) vault-paths]
+                [else
+                 (define stepped-paths (append-map take-step paths))
+                 (define-values (new-vault-paths other-paths)
+                   (partition (λ(sp) (= vault (follow-path sp))) stepped-paths))
+                 (loop other-paths (if (pair? new-vault-paths) new-vault-paths vault-paths) (add1 i))]))))))
diff --git a/2016/day17/test.rkt b/2016/day17/test.rkt
new file mode 100644
index 0000000..f797a45
--- /dev/null
+++ b/2016/day17/test.rkt
@@ -0,0 +1,2 @@
+#lang reader "lang.rkt"
+hijkl
\ No newline at end of file