shipping.carp

(add-cflag "-O3")
(use-all Array Set)

; Set.filter impl that returns the first viable thing
(defmodule Set
  (defn filter [f s]
    (let-do [a &(zero)]
      (for [i 0 @(n-buckets s)]
        (let [bucket (Array.nth (buckets s) i)
              len (Array.length (SetBucket.entries bucket))
              entries (SetBucket.entries bucket)]
          (for [j 0 len]
            (let [e (Array.nth entries j)]
              (when (f e)
                (do
                  (set! a e)
                  (break)))))))
      @a))
)

(deftype Leg [day Char start String end String])

(defmodule Leg
  ; N.B. we’re throwing away the ID for now
  (defn from-string [s]
    (let [arr (words s)]
      (Leg.init (head (nth &arr 3)) @(nth &arr 1) @(nth &arr 2))))
)

(def days [\M \T \W \R \F])

(defn next-day [d]
  (let [i (index-of &days d)]
    (if (< i 5)
      @(nth &days (Int.inc i))
      \X)))

(deftype Route [identifier Int legs (Array Leg)])

(defmodule Route
  (def ID 0)

  (defn zero []
    (Route.init 0 []))

  (defn singleton [l]
    (do
      (set! ID (Int.inc ID))
      (Route.init ID [@l])))

  (defn viable? [d r s]
    (let [ls (legs r)
          l (nth ls (Int.dec (length ls)))]
      (and (= (next-day @(Leg.day l)) d) (= s (Leg.end l)))))

  (defn add-leg [r l]
    (Route.update-legs r (fn [legs] (push-back legs @l))))

  (defn hash [r]
    @(identifier r))

  (defn = [r1 r2]
    (= (identifier r1) (identifier r2)))

  (defn prn [r]
    (str r))
)

(defn legs-for [legs d]
  (filter (fn [leg] (= (Leg.day leg) d)) @legs))

(defn solve-leg [d routes leg]
  (let [viable (Set.filter (fn [r] (Route.viable? @d r (Leg.start leg))) &routes)]
    (if (= &viable &(zero))
      (put routes &(Route.singleton leg))
      (put (remove routes &viable) &(Route.add-leg viable leg)))))

(defn solve-on [d routes legs]
  (reduce (fn [routes leg] (solve-leg d routes leg)) routes &legs))

(defn solve [legs]
  (let-do [res (Set.create)]
    (for [i 0 (length &days)]
      (let [day (nth &days i)]
        (set! res (solve-on day res (legs-for &legs day)))))
    res))

(defn make-legs [ls]
  (copy-map Leg.from-string &(filter (fn [s] (not (String.empty? s))) ls)))

(defn main []
  (let-do [ls (lines &(IO.read-file "legs.txt"))
           legs (make-legs ls)
           then (System.nanotime)
          ]
    (IO.println &(str (length &(solve @&legs))))
    (println* "Solving took " (/ (- (System.nanotime) then) 1000000l) " milliseconds")))