graph-distance-wip.clj

graph-distance-wip.clj

(defn paths
    "Returns a lazy seq of all non-looping path vectors starting with
  [<start-node>]"
    [nodes-fn path]
    (let [this-node (peek path)]
      (->> (nodes-fn this-node)
           (filter #(not-any? (fn [edge] (= edge [this-node %]))
                              (partition 2 1 path)))
           (mapcat #(paths nodes-fn (conj path %)))
           (cons path))))

  (defn trace-paths [m start]
    (remove #(m (peek %)) (paths m [start])))

  (defn- find-paths [from-map to-map matches]
    (for [n matches
          from (map reverse (trace-paths from-map n))
          to (map rest (trace-paths to-map n))]
      (vec (concat from to))))

  (defn- neighbor-pairs [neighbors q coll]
    (for [node q
          nbr (neighbors node)
          :when (not (contains? coll nbr))]
      [nbr node]))

  (defn bidirectional-bfs [start end neighbors]
    (let [find-pairs (partial neighbor-pairs neighbors)
          overlaps (fn [coll q] (seq (filter #(contains? coll %) q)))
          map-set-pairs (fn [map pairs]
                          (persistent! (reduce (fn [map [key val]]
                                                 (assoc! map key (conj (get map key #{}) val)))
                                               (transient map) pairs)))]
      (loop [preds {start nil} ; map of outgoing nodes to where they came from
             succs {end nil}   ; map of incoming nodes to where they came from
             q1 (list start)   ; queue of outgoing things to check
             q2 (list end)]    ; queue of incoming things to check
        (when (and (seq q1) (seq q2))
          (if (<= (count q1) (count q2))
            (let [pairs (find-pairs q1 preds)
                  preds (map-set-pairs preds pairs)
                  q1 (map first pairs)]
              (if-let [all (overlaps succs q1)]
                (find-paths preds succs (set all))
                (recur preds succs q1 q2)))
            (let [pairs (find-pairs q2 succs)
                  succs (map-set-pairs succs pairs)
                  q2 (map first pairs)]
              (if-let [all (overlaps preds q2)]
                (find-paths preds succs (set all))
                (recur preds succs q1 q2))))))))


  ;; =============================================================================

  (defn connected-movies
    [db snapshot person-id]
    (map first
         (xt/q db
               {:find '[movie-id]
                :where '[[?p :tmdb.person/id person-id]
                         [?p :tmdb.cast/character]
                         [?p :tmdb.movie/id movie-id]]
                :args [{:person-id person-id}]})))

  (defn connected-people
    [db snapshot movie-id]
    (map first
         (xt/q db
               {:find '[person-id]
                :where '[[?p :tmdb.person/id person-id]
                         [?p :tmdb.cast/character]
                         [?p :tmdb.movie/id movie-id]]
                :args [{:movie-id movie-id}]})))

  (defn connected-to
    [db snapshot id]
    (concat
     (connected-movies db snapshot id)
     (connected-people db snapshot id)))

  (defn find-id-paths [db snapshot source target]
    (bidirectional-bfs source target (partial connected-to db snapshot)))

  (defn ids->docs
    [db snapshot ids]
    (vec
     (for [id ids]
       (or
        (first
         (xt/q db #_snapshot
               {:find '[id title]
                :where '[[id :tmdb.movie/title title]
                         ]
                :args [{:id id}]}))
        (first
         (xt/q db #_snapshot
               {:find '[id title]
                :where '[[id :tmdb.person/name title]
                         ]
                :args [{:id id}]}))
        id))))

  ;; :tmdb/person-32747 :tmdb/person-10205

  (time (with-open [db (xt/open-db rocks-node)]
          (let [paths (find-id-paths db :snapshot
                                     :tmdb/person-5344
                                     :tmdb/person-4724)]
            (doall (map
                    ;;count #_
                    (partial ids->docs db :snapshot) paths)))))