From ab4f5bbff03c29dcb8117086852923ca9a2f216d Mon Sep 17 00:00:00 2001 From: Matthew Chadwick Date: Wed, 28 Oct 2015 13:29:13 +0000 Subject: [PATCH] first go at translating loom.graph to cljs --- .gitignore | 3 + src/loom/alg_generic.cljc | 40 ++- src/loom/graph.cljc | 723 ++++++++++++++++++++------------------ 3 files changed, 403 insertions(+), 363 deletions(-) diff --git a/.gitignore b/.gitignore index 35ec846..5949431 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,6 @@ classes /bin /target /.lein-* +.idea +*.iml +.nrepl-port diff --git a/src/loom/alg_generic.cljc b/src/loom/alg_generic.cljc index 2d31965..464283a 100644 --- a/src/loom/alg_generic.cljc +++ b/src/loom/alg_generic.cljc @@ -2,7 +2,7 @@ :author "Justin Kramer"} loom.alg-generic (:refer-clojure :exclude [ancestors]) - (:import [java.util Arrays])) + #?(:clj (:import [java.util Arrays]))) ;;; ;;; Utility functions @@ -192,17 +192,18 @@ (letfn [(step [queue preds] (when-let [[node depth] (peek queue)] (cons - (f node preds depth) - (lazy-seq - (let [nbrs (->> (successors node) - (remove #(contains? preds %)) - (filter #(nbr-pred % node (inc depth))))] - (step (into (pop queue) (for [nbr nbrs] [nbr (inc depth)])) - (reduce #(assoc %1 %2 node) preds nbrs)))))))] - (step (conj clojure.lang.PersistentQueue/EMPTY [start 0]) - (if (map? seen) - (assoc seen start nil) - (into {start nil} (for [s seen] [s nil]))))))) + (f node preds depth) + (lazy-seq + (let [nbrs (->> (successors node) + (remove #(contains? preds %)) + (filter #(nbr-pred % node (inc depth))))] + (step (into (pop queue) (for [nbr nbrs] [nbr (inc depth)])) + (reduce #(assoc %1 %2 node) preds nbrs)))))))] + (step (conj #?(:cljs (.-EMPTY cljs.core/PersistentQueue) + :clj (clojure.lang.PersistentQueue/EMPTY)) [start 0]) + (if (map? seen) + (assoc seen start nil) + (into {start nil} (for [s seen] [s nil]))))))) (defn bf-span "Return a breadth-first spanning tree of the form {node @@ -457,7 +458,7 @@ ;;; Ancestry node-bitmap helper vars/fns -(def ^Long bits-per-long (long (Long/SIZE))) +(def ^Long bits-per-long (long #?(:clj (Long/SIZE) :cljs 64))) (defn ^Long bm-longs "Returns the number of longs required to store bits count bits in a bitmap." @@ -473,7 +474,9 @@ "Set boolean state of bit in 'bitmap at 'idx to true." ^longs [^longs bitmap idx] (let [size (max (count bitmap) (bm-longs (inc idx))) - new-bitmap (Arrays/copyOf bitmap ^Long size) + n-zeros (- size (count bitmap)) + new-bitmap #?(:clj (Arrays/copyOf bitmap ^Long size) + :cljs (.concat (.slice bitmap) (.fill (js/Array. n-zeros) 0))) chunk (quot idx bits-per-long) offset (mod idx bits-per-long) mask (bit-set 0 offset) @@ -498,8 +501,13 @@ ^longs [& bitmaps] (if (empty? bitmaps) (bm-new) - (let [size (apply max (map count bitmaps)) - new-bitmap (Arrays/copyOf ^longs (first bitmaps) ^Long size)] + (let [ + size (apply max (map count bitmaps)) + bitmap (first bitmaps) + n-zeros (- size (count bitmap)) + new-bitmap #?(:clj (Arrays/copyOf bitmap ^Long size) + :cljs (.concat (.slice bitmap) (.fill (js/Array. n-zeros) 0))) + ] (doseq [bitmap (rest bitmaps) [idx value] (map-indexed list bitmap) :let [masked-value (bit-or value (aget new-bitmap idx))]] diff --git a/src/loom/graph.cljc b/src/loom/graph.cljc index 8519b26..249e40d 100644 --- a/src/loom/graph.cljc +++ b/src/loom/graph.cljc @@ -1,32 +1,32 @@ -(ns ^{:doc "Defines protocols for graphs, digraphs, and weighted graphs. +(ns + ^{:doc "Defines protocols for graphs, digraphs, and weighted graphs. Also provides record implementations and constructors for simple graphs -- weighted, unweighted, directed, and undirected. The implementations are based on adjacency lists." - :author "Justin Kramer"} + :author "Justin Kramer"} loom.graph (:require [loom.alg-generic :refer [bf-traverse]])) -;;; -;;; Protocols -;;; (defprotocol Graph (nodes [g] "Returns a collection of the nodes in graph g") (edges [g] "Edges in g. May return each edge twice in an undirected graph") (has-node? [g node] "Returns true when node is in g") (has-edge? [g n1 n2] "Returns true when edge [n1 n2] is in g") - (successors* [g node] "Returns direct successors of node") + (successors [g] [g node] + "Returns direct successors of node, or (partial successors g)") (out-degree [g node] "Returns the number of outgoing edges of node") - (out-edges [g node] "Returns all the outgoing edges of node")) + (out-edges [g] [g node] "Returns all the outgoing edges of node")) (defprotocol Digraph - (predecessors* [g node] "Returns direct predecessors of node") + (predecessors [g] [g node] + "Returns direct predecessors of node, or (partial predecessors g)") (in-degree [g node] "Returns the number of direct predecessors to node") - (in-edges [g node] "Returns all the incoming edges of node") + (in-edges [g] [g node] "Returns all the incoming edges of node") (transpose [g] "Returns a graph with all edges reversed")) (defprotocol WeightedGraph - (weight* [g e] [g n1 n2] "Returns the weight of edge e or edge [n1 n2]")) + (weight [g] [g e] [g n1 n2] "Returns the weight of edge e or edge [n1 n2] or (partial weight g)")) (defprotocol EditableGraph (add-nodes* [g nodes] "Add nodes to graph g. See add-nodes") @@ -40,33 +40,21 @@ on adjacency lists." (dest [edge] "Returns the dest node of the edge")) ; Default implementation for vectors -(extend-type clojure.lang.IPersistentVector +(extend-type #?(:cljs cljs.core.PersistentVector :clj clojure.lang.IPersistentVector) Edge (src [edge] (get edge 0)) (dest [edge] (get edge 1))) ; Default implementation for maps -(extend-type clojure.lang.IPersistentMap +(extend-type #?(:cljs cljs.core.PersistentArrayMap :clj clojure.lang.IPersistentMap) Edge (src [edge] (:src edge)) (dest [edge] (:dest edge))) -;; Curried wrappers -(defn successors - "Returns direct successors of node" - ([g] #(successors g %)) ; faster than partial - ([g node] (successors* g node))) - -(defn predecessors - "Returns direct predecessors of node" - ([g] #(predecessors g %)) - ([g node] (predecessors* g node))) - -(defn weight - "Returns the weight of edge e or edge [n1 n2]" - ([g] (partial weight g)) - ([g e] (weight* g (src e) (dest e))) - ([g n1 n2] (weight* g n1 n2))) +(extend-type #?(:cljs cljs.core.PersistentHashMap :clj clojure.lang.IPersistentMap) + Edge + (src [edge] (:src edge)) + (dest [edge] (:dest edge))) ;; Variadic wrappers @@ -92,282 +80,316 @@ on adjacency lists." [g & edges] (remove-edges* g edges)) -;;; -;;; Records for basic graphs -- one edge per vertex pair/direction, -;;; loops allowed -;;; -;; TODO: allow custom weight fn? -;; TODO: preserve metadata? -;; TODO: leverage zippers for faster record updates? - -(defrecord BasicEditableGraph [nodeset adj]) -(defrecord BasicEditableDigraph [nodeset adj in]) -(defrecord BasicEditableWeightedGraph [nodeset adj]) -(defrecord BasicEditableWeightedDigraph [nodeset adj in]) - (def ^{:dynamic true :doc "Weight used when none is given for edges in weighted graphs"} - *default-weight* 1) +*default-weight* 1) (def default-graph-impls {:all - {:nodes (fn [g] - (:nodeset g)) - :edges (fn [g] - (for [n1 (nodes g) - e (out-edges g n1)] - e)) - :has-node? (fn [g node] - (contains? (:nodeset g) node)) - :has-edge? (fn [g n1 n2] - (contains? (get-in g [:adj n1]) n2)) - :out-degree (fn [g node] - (count (get-in g [:adj node]))) - :out-edges (fn - ([g] (partial out-edges g)) - ([g node] (for [n2 (successors g node)] [node n2])))} + {:nodes '(fn [g] + (:nodeset g)) + :edges '(fn [g] + (for [n1 (nodes g) + e (out-edges g n1)] + e)) + :has-node? '(fn [g node] + (contains? (:nodeset g) node)) + :has-edge? '(fn [g n1 n2] + (contains? (get-in g [:adj n1]) n2)) + :out-degree '(fn [g node] + (count (get-in g [:adj node]))) + :out-edges '(fn + ([g] (partial out-edges g)) + ([g node] (for [n2 (successors g node)] [node n2])))} ;; Unweighted graphs store adjacencies as {node #{neighbor}} :unweighted - {:add-nodes* (fn [g nodes] - (reduce - (fn [g n] - (-> g + {:add-nodes* '(fn [g nodes] + (reduce + (fn [g n] + (-> g (update-in [:nodeset] conj n) (assoc-in [:adj n] (or ((:adj g) n) #{})))) - g nodes)) - :successors* (fn + g nodes)) + :successors '(fn ([g] (partial successors g)) ([g node] (get-in g [:adj node])))} ;; Weighted graphs store adjacencies as {node {neighbor weight}} :weighted - {:add-nodes* (fn [g nodes] - (reduce - (fn [g n] - (-> g + {:add-nodes* '(fn [g nodes] + (reduce + (fn [g n] + (-> g (update-in [:nodeset] conj n) (assoc-in [:adj n] (or ((:adj g) n) {})))) - g nodes)) - :successors* (fn + g nodes)) + :successors '(fn ([g] (partial successors g)) ([g node] (keys (get-in g [:adj node]))))}}) (def default-digraph-impl - {:predecessors* (fn + {:predecessors '(fn ([g] (partial predecessors g)) ([g node] (get-in g [:in node]))) - :in-degree (fn [g node] - (count (get-in g [:in node]))) - :in-edges (fn - ([g] (partial in-edges g)) - ([g node] (for [n2 (predecessors g node)] [n2 node])))}) + :in-degree '(fn [g node] + (count (get-in g [:in node]))) + :in-edges '(fn + ([g] (partial in-edges g)) + ([g node] (for [n2 (predecessors g node)] [n2 node])))}) (def default-weighted-graph-impl - {:weight* (fn + {:weight '(fn ([g] (partial weight g)) ([g e] (weight g (src e) (dest e))) ([g n1 n2] (get-in g [:adj n1 n2])))}) (defn- remove-adj-nodes [m nodes adjacents remove-fn] (reduce - (fn [m n] - (if (m n) - (update-in m [n] #(apply remove-fn % nodes)) - m)) - (apply dissoc m nodes) - adjacents)) - -(extend BasicEditableGraph - Graph - (let [{:keys [all unweighted]} default-graph-impls] - (merge all unweighted)) - - EditableGraph - {:add-nodes* - (fn [g nodes] - (reduce - (fn [g node] (update-in g [:nodeset] conj node)) - g nodes)) - - :add-edges* - (fn [g edges] - (reduce - (fn [g [n1 n2]] - (-> g - (update-in [:nodeset] conj n1 n2) - (update-in [:adj n1] (fnil conj #{}) n2) - (update-in [:adj n2] (fnil conj #{}) n1))) - g edges)) - - :remove-nodes* - (fn [g nodes] - (let [nbrs (mapcat #(successors g %) nodes)] - (-> g - (update-in [:nodeset] #(apply disj % nodes)) - (assoc :adj (remove-adj-nodes (:adj g) nodes nbrs disj))))) - - :remove-edges* - (fn [g edges] - (reduce - (fn [g [n1 n2]] - (-> g - (update-in [:adj n1] disj n2) - (update-in [:adj n2] disj n1))) - g edges)) - - :remove-all - (fn [g] - (assoc g :nodeset #{} :adj {}))}) - -(extend BasicEditableDigraph - Graph - (let [{:keys [all unweighted]} default-graph-impls] - (merge all unweighted)) - - EditableGraph - {:add-nodes* - (fn [g nodes] - (reduce - (fn [g node] (update-in g [:nodeset] conj node)) - g nodes)) - - :add-edges* - (fn [g edges] - (reduce - (fn [g [n1 n2]] - (-> g - (update-in [:nodeset] conj n1 n2) - (update-in [:adj n1] (fnil conj #{}) n2) - (update-in [:in n2] (fnil conj #{}) n1))) - g edges)) - - :remove-nodes* - (fn [g nodes] - (let [ins (mapcat #(predecessors g %) nodes) - outs (mapcat #(successors g %) nodes)] - (-> g - (update-in [:nodeset] #(apply disj % nodes)) - (assoc :adj (remove-adj-nodes (:adj g) nodes ins disj)) - (assoc :in (remove-adj-nodes (:in g) nodes outs disj))))) - - :remove-edges* - (fn [g edges] - (reduce - (fn [g [n1 n2]] - (-> g - (update-in [:adj n1] disj n2) - (update-in [:in n2] disj n1))) - g edges)) - - :remove-all - (fn [g] - (assoc g :nodeset #{} :adj {} :in {}))} - - Digraph - (assoc default-digraph-impl - :transpose (fn [g] - (assoc g :adj (:in g) :in (:adj g))))) - -(extend BasicEditableWeightedGraph - Graph - (let [{:keys [all weighted]} default-graph-impls] - (merge all weighted)) - - EditableGraph - {:add-nodes* - (fn [g nodes] - (reduce - (fn [g node] (update-in g [:nodeset] conj node)) - g nodes)) - - :add-edges* - (fn [g edges] - (reduce - (fn [g [n1 n2 & [w]]] - (-> g - (update-in [:nodeset] conj n1 n2) - (assoc-in [:adj n1 n2] (or w *default-weight*)) - (assoc-in [:adj n2 n1] (or w *default-weight*)))) - g edges)) - - :remove-nodes* - (fn [g nodes] - (let [nbrs (mapcat #(successors g %) nodes)] - (-> g - (update-in [:nodeset] #(apply disj % nodes)) - (assoc :adj (remove-adj-nodes (:adj g) nodes nbrs dissoc))))) - - :remove-edges* - (fn [g edges] - (reduce - (fn [g [n1 n2]] - (-> g - (update-in [:adj n1] dissoc n2) - (update-in [:adj n2] dissoc n1))) - g edges)) - - :remove-all - (fn [g] - (assoc g :nodeset #{} :adj {}))} - - WeightedGraph - default-weighted-graph-impl) - -(extend BasicEditableWeightedDigraph - Graph - (let [{:keys [all weighted]} default-graph-impls] - (merge all weighted)) - - EditableGraph - {:add-nodes* - (fn [g nodes] - (reduce - (fn [g node] (update-in g [:nodeset] conj node)) - g nodes)) - - :add-edges* - (fn [g edges] - (reduce - (fn [g [n1 n2 & [w]]] - (-> g - (update-in [:nodeset] conj n1 n2) - (assoc-in [:adj n1 n2] (or w *default-weight*)) - (update-in [:in n2] (fnil conj #{}) n1))) - g edges)) - - :remove-nodes* - (fn [g nodes] - (let [ins (mapcat #(predecessors g %) nodes) - outs (mapcat #(successors g %) nodes)] - (-> g - (update-in [:nodeset] #(apply disj % nodes)) - (assoc :adj (remove-adj-nodes (:adj g) nodes ins dissoc)) - (assoc :in (remove-adj-nodes (:in g) nodes outs disj))))) - - :remove-edges* - (fn [g edges] - (reduce - (fn [g [n1 n2]] - (-> g - (update-in [:adj n1] dissoc n2) - (update-in [:in n2] disj n1))) - g edges)) - - :remove-all - (fn [g] - (assoc g :nodeset #{} :adj {} :in {}))} - - Digraph - (assoc default-digraph-impl - :transpose (fn [g] - (reduce (fn [tg [n1 n2]] - (add-edges* tg [[n2 n1 (weight g n1 n2)]])) - (assoc g :adj {} :in {}) - (edges g)))) - - WeightedGraph - default-weighted-graph-impl) + (fn [m n] + (if (m n) + (update-in m [n] #(apply remove-fn % nodes)) + m)) + (apply dissoc m nodes) + adjacents)) + +(comment (defmacro extended-record [rn fv & spec] + (concat `(defrecord ~rn ~fv) + (mapcat + (fn [[pn pm]] + ;(println pm) + (cons pn + (mapcat + (fn [[fk fv]] + ;(println " " pn " " `~(cons (symbol (name fk)) (rest fv))) + (if (vector? (second fv)) + (list `~(cons (symbol (name fk)) (rest fv))) + (map (fn [fa] `~(cons (symbol (name fk)) fa)) (rest fv))) + ) + (if (map? pm) pm (eval pm))))) + (partition 2 spec))))) + +;;; +;;; Records for basic graphs -- one edge per vertex pair/direction, +;;; loops allowed +;;; +;; TODO: allow custom weight fn? +;; TODO: preserve metadata? +;; TODO: leverage zippers for faster record updates? + +(comment + (defrecord BasicEditableGraph [nodeset adj]) + (defrecord BasicEditableDigraph [nodeset adj in]) + (defrecord BasicEditableWeightedGraph [nodeset adj]) + (defrecord BasicEditableWeightedDigraph [nodeset adj in])) + +(defrecord BasicEditableGraph [nodeset adj] Graph (nodes [g] (:nodeset g)) (edges [g] (for [n1 (nodes g) e (out-edges g n1)] e)) (has-node? [g node] (contains? (:nodeset g) node)) (has-edge? [g n1 n2] (contains? (get-in g [:adj n1]) n2)) (out-degree [g node] (count (get-in g [:adj node]))) (out-edges [g] (partial out-edges g)) (out-edges [g node] (for [n2 (successors g node)] [node n2])) (successors [g] (partial successors g)) (successors [g node] (get-in g [:adj node])) EditableGraph (add-nodes* [g nodes] (reduce (fn [g node] (update-in g [:nodeset] conj node)) g nodes)) (add-edges* [g edges] (reduce (fn [g [n1 n2]] (-> g (update-in [:nodeset] conj n1 n2) (update-in [:adj n1] (fnil conj #{}) n2) (update-in [:adj n2] (fnil conj #{}) n1))) g edges)) (remove-nodes* [g nodes] (let [nbrs (mapcat (fn* [p1__66951#] (successors g p1__66951#)) nodes)] (-> g (update-in [:nodeset] (fn* [p1__66952#] (apply disj p1__66952# nodes))) (assoc :adj (remove-adj-nodes (:adj g) nodes nbrs disj))))) (remove-edges* [g edges] (reduce (fn [g [n1 n2]] (-> g (update-in [:adj n1] disj n2) (update-in [:adj n2] disj n1))) g edges)) (remove-all [g] (assoc g :nodeset #{} :adj {}))) + + +(comment (macroexpand-1 '(extended-record BasicEditableGraph [nodeset adj] + + Graph + (let [{:keys [all unweighted]} default-graph-impls] + (merge all (dissoc unweighted :add-nodes*))) + + EditableGraph + {:add-nodes* + (fn [g nodes] + (reduce + (fn [g node] (update-in g [:nodeset] conj node)) + g nodes)) + + :add-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:nodeset] conj n1 n2) + (update-in [:adj n1] (fnil conj #{}) n2) + (update-in [:adj n2] (fnil conj #{}) n1))) + g edges)) + + :remove-nodes* + (fn [g nodes] + (let [nbrs (mapcat #(successors g %) nodes)] + (-> g + (update-in [:nodeset] #(apply disj % nodes)) + (assoc :adj (remove-adj-nodes (:adj g) nodes nbrs disj))))) + + :remove-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:adj n1] disj n2) + (update-in [:adj n2] disj n1))) + g edges)) + + :remove-all + (fn [g] + (assoc g :nodeset #{} :adj {}))}))) + + +(defrecord BasicEditableDigraph [nodeset adj in] Graph (nodes [g] (:nodeset g)) (edges [g] (for [n1 (nodes g) e (out-edges g n1)] e)) (has-node? [g node] (contains? (:nodeset g) node)) (has-edge? [g n1 n2] (contains? (get-in g [:adj n1]) n2)) (out-degree [g node] (count (get-in g [:adj node]))) (out-edges [g] (partial out-edges g)) (out-edges [g node] (for [n2 (successors g node)] [node n2])) (successors [g] (partial successors g)) (successors [g node] (get-in g [:adj node])) EditableGraph (add-nodes* [g nodes] (reduce (fn [g node] (update-in g [:nodeset] conj node)) g nodes)) (add-edges* [g edges] (reduce (fn [g [n1 n2]] (-> g (update-in [:nodeset] conj n1 n2) (update-in [:adj n1] (fnil conj #{}) n2) (update-in [:in n2] (fnil conj #{}) n1))) g edges)) (remove-nodes* [g nodes] (let [ins (mapcat (fn* [p1__69718#] (predecessors g p1__69718#)) nodes) outs (mapcat (fn* [p1__69719#] (successors g p1__69719#)) nodes)] (-> g (update-in [:nodeset] (fn* [p1__69720#] (apply disj p1__69720# nodes))) (assoc :adj (remove-adj-nodes (:adj g) nodes ins disj)) (assoc :in (remove-adj-nodes (:in g) nodes outs disj))))) (remove-edges* [g edges] (reduce (fn [g [n1 n2]] (-> g (update-in [:adj n1] disj n2) (update-in [:in n2] disj n1))) g edges)) (remove-all [g] (assoc g :nodeset #{} :adj {} :in {})) Digraph (predecessors [g] (partial predecessors g)) (predecessors [g node] (get-in g [:in node])) (in-degree [g node] (count (get-in g [:in node]))) (in-edges [g] (partial in-edges g)) (in-edges [g node] (for [n2 (predecessors g node)] [n2 node])) (transpose [g] (assoc g :adj (:in g) :in (:adj g)))) + +(comment (macroexpand-1 '(extended-record BasicEditableDigraph [nodeset adj in] + + Graph + (let [{:keys [all unweighted]} default-graph-impls] + ; CompilerException java.lang.ClassFormatError: Duplicate method name&signature in class file + (merge all (dissoc unweighted :add-nodes*))) + + + EditableGraph + {:add-nodes* + (fn [g nodes] + (reduce + (fn [g node] (update-in g [:nodeset] conj node)) + g nodes)) + + :add-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:nodeset] conj n1 n2) + (update-in [:adj n1] (fnil conj #{}) n2) + (update-in [:in n2] (fnil conj #{}) n1))) + g edges)) + + :remove-nodes* + (fn [g nodes] + (let [ins (mapcat #(predecessors g %) nodes) + outs (mapcat #(successors g %) nodes)] + (-> g + (update-in [:nodeset] #(apply disj % nodes)) + (assoc :adj (remove-adj-nodes (:adj g) nodes ins disj)) + (assoc :in (remove-adj-nodes (:in g) nodes outs disj))))) + + :remove-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:adj n1] disj n2) + (update-in [:in n2] disj n1))) + g edges)) + + :remove-all + (fn [g] + (assoc g :nodeset #{} :adj {} :in {}))} + + + Digraph + (assoc default-digraph-impl + :transpose '(fn [g] + (assoc g :adj (:in g) :in (:adj g))))))) + +(defrecord BasicEditableWeightedGraph [nodeset adj] Graph (nodes [g] (:nodeset g)) (edges [g] (for [n1 (nodes g) e (out-edges g n1)] e)) (has-node? [g node] (contains? (:nodeset g) node)) (has-edge? [g n1 n2] (contains? (get-in g [:adj n1]) n2)) (out-degree [g node] (count (get-in g [:adj node]))) (out-edges [g] (partial out-edges g)) (out-edges [g node] (for [n2 (successors g node)] [node n2])) (successors [g] (partial successors g)) (successors [g node] (keys (get-in g [:adj node]))) EditableGraph (add-nodes* [g nodes] (reduce (fn [g node] (update-in g [:nodeset] conj node)) g nodes)) (add-edges* [g edges] (reduce (fn [g [n1 n2 & [w]]] (-> g (update-in [:nodeset] conj n1 n2) (assoc-in [:adj n1 n2] (or w *default-weight*)) (assoc-in [:adj n2 n1] (or w *default-weight*)))) g edges)) (remove-nodes* [g nodes] (let [nbrs (mapcat (fn* [p1__70923#] (successors g p1__70923#)) nodes)] (-> g (update-in [:nodeset] (fn* [p1__70924#] (apply disj p1__70924# nodes))) (assoc :adj (remove-adj-nodes (:adj g) nodes nbrs dissoc))))) (remove-edges* [g edges] (reduce (fn [g [n1 n2]] (-> g (update-in [:adj n1] dissoc n2) (update-in [:adj n2] dissoc n1))) g edges)) (remove-all [g] (assoc g :nodeset #{} :adj {})) WeightedGraph (weight [g] (partial weight g)) (weight [g e] (weight g (src e) (dest e))) (weight [g n1 n2] (get-in g [:adj n1 n2]))) + +(comment (macroexpand-1 '(extended-record BasicEditableWeightedGraph [nodeset adj] + Graph + (let [{:keys [all weighted]} default-graph-impls] + (merge all (dissoc weighted :add-nodes*))) + + EditableGraph + {:add-nodes* + (fn [g nodes] + (reduce + (fn [g node] (update-in g [:nodeset] conj node)) + g nodes)) + + :add-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2 & [w]]] + (-> g + (update-in [:nodeset] conj n1 n2) + (assoc-in [:adj n1 n2] (or w *default-weight*)) + (assoc-in [:adj n2 n1] (or w *default-weight*)))) + g edges)) + + :remove-nodes* + (fn [g nodes] + (let [nbrs (mapcat #(successors g %) nodes)] + (-> g + (update-in [:nodeset] #(apply disj % nodes)) + (assoc :adj (remove-adj-nodes (:adj g) nodes nbrs dissoc))))) + + :remove-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:adj n1] dissoc n2) + (update-in [:adj n2] dissoc n1))) + g edges)) + + :remove-all + (fn [g] + (assoc g :nodeset #{} :adj {}))} + + WeightedGraph + default-weighted-graph-impl + ))) + +(defrecord BasicEditableWeightedDigraph [nodeset adj in] Graph (nodes [g] (:nodeset g)) (edges [g] (for [n1 (nodes g) e (out-edges g n1)] e)) (has-node? [g node] (contains? (:nodeset g) node)) (has-edge? [g n1 n2] (contains? (get-in g [:adj n1]) n2)) (out-degree [g node] (count (get-in g [:adj node]))) (out-edges [g] (partial out-edges g)) (out-edges [g node] (for [n2 (successors g node)] [node n2])) (successors [g] (partial successors g)) (successors [g node] (keys (get-in g [:adj node]))) EditableGraph (add-nodes* [g nodes] (reduce (fn [g node] (update-in g [:nodeset] conj node)) g nodes)) (add-edges* [g edges] (reduce (fn [g [n1 n2 & [w]]] (-> g (update-in [:nodeset] conj n1 n2) (assoc-in [:adj n1 n2] (or w *default-weight*)) (update-in [:in n2] (fnil conj #{}) n1))) g edges)) (remove-nodes* [g nodes] (let [ins (mapcat (fn* [p1__72122#] (predecessors g p1__72122#)) nodes) outs (mapcat (fn* [p1__72123#] (successors g p1__72123#)) nodes)] (-> g (update-in [:nodeset] (fn* [p1__72124#] (apply disj p1__72124# nodes))) (assoc :adj (remove-adj-nodes (:adj g) nodes ins dissoc)) (assoc :in (remove-adj-nodes (:in g) nodes outs disj))))) (remove-edges* [g edges] (reduce (fn [g [n1 n2]] (-> g (update-in [:adj n1] dissoc n2) (update-in [:in n2] disj n1))) g edges)) (remove-all [g] (assoc g :nodeset #{} :adj {} :in {})) Digraph (predecessors [g] (partial predecessors g)) (predecessors [g node] (get-in g [:in node])) (in-degree [g node] (count (get-in g [:in node]))) (in-edges [g] (partial in-edges g)) (in-edges [g node] (for [n2 (predecessors g node)] [n2 node])) (transpose [g] (reduce (fn [tg [n1 n2]] (add-edges* tg [[n2 n1 (weight g n1 n2)]])) (assoc g :adj {} :in {}) (edges g))) WeightedGraph (weight [g] (partial weight g)) (weight [g e] (weight g (src e) (dest e))) (weight [g n1 n2] (get-in g [:adj n1 n2]))) + + +(comment (macroexpand-1 '(extended-record BasicEditableWeightedDigraph [nodeset adj in] + Graph + (let [{:keys [all weighted]} default-graph-impls] + (merge all (dissoc weighted :add-nodes*))) + + EditableGraph + {:add-nodes* + (fn [g nodes] + (reduce + (fn [g node] (update-in g [:nodeset] conj node)) + g nodes)) + + :add-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2 & [w]]] + (-> g + (update-in [:nodeset] conj n1 n2) + (assoc-in [:adj n1 n2] (or w *default-weight*)) + (update-in [:in n2] (fnil conj #{}) n1))) + g edges)) + + :remove-nodes* + (fn [g nodes] + (let [ins (mapcat #(predecessors g %) nodes) + outs (mapcat #(successors g %) nodes)] + (-> g + (update-in [:nodeset] #(apply disj % nodes)) + (assoc :adj (remove-adj-nodes (:adj g) nodes ins dissoc)) + (assoc :in (remove-adj-nodes (:in g) nodes outs disj))))) + + :remove-edges* + (fn [g edges] + (reduce + (fn [g [n1 n2]] + (-> g + (update-in [:adj n1] dissoc n2) + (update-in [:in n2] disj n1))) + g edges)) + + :remove-all + (fn [g] + (assoc g :nodeset #{} :adj {} :in {}))} + + Digraph + (assoc default-digraph-impl + :transpose '(fn [g] + (reduce (fn [tg [n1 n2]] + (add-edges* tg [[n2 n1 (weight g n1 n2)]])) + (assoc g :adj {} :in {}) + (edges g)))) + + WeightedGraph + default-weighted-graph-impl))) ;;; ;;; FlyGraph -- a read-only, ad-hoc graph which uses provided functions to @@ -378,66 +400,73 @@ on adjacency lists." (defn- call-or-return [f & args] (if (or (fn? f) - (and (instance? clojure.lang.IFn f) (seq args))) + (and (instance? clojure.lang.IFn f) (seq args))) (apply f args) f)) (def ^{:private true} default-flygraph-graph-impl - {:nodes (fn [g] - (if (or (:fnodes g) (not (:start g))) - (call-or-return (:fnodes g)) - (bf-traverse (successors g) (:start g)))) - :edges (fn [g] - (if (:fedges g) - (call-or-return (:fedges g)) - (for [n (nodes g) - nbr (successors g n)] - [n nbr]))) - :successors* (fn + {:nodes '(fn [g] + (if (or (:fnodes g) (not (:start g))) + (call-or-return (:fnodes g)) + (bf-traverse (successors g) (:start g)))) + :edges '(fn [g] + (if (:fedges g) + (call-or-return (:fedges g)) + (for [n (nodes g) + nbr (successors g n)] + [n nbr]))) + :successors '(fn ([g] (partial successors g)) ([g node] (call-or-return (:fsuccessors g) node))) - :out-degree (fn [g node] - (count (successors g node))) + :out-degree '(fn [g node] + (count (successors g node))) :out-edges (get-in default-graph-impls [:all :out-edges]) - :has-node? (fn [g node] - ;; cannot use contains? here because (nodes g) need not be a set. - (some #{node} (nodes g)))}) + :has-node? '(fn [g node] + ;; cannot use contains? here because (nodes g) need not be a set. + (some #{node} (nodes g)))}) (def ^{:private true} default-flygraph-digraph-impl - {:predecessors* (fn [g node] (call-or-return (:fpredecessors g) node)) - :in-degree (fn [g node] (count (predecessors g node))) + {:predecessors '(fn [g node] (call-or-return (:fpredecessors g) node)) + :in-degree '(fn [g node] (count (predecessors g node))) :in-edges (get-in default-digraph-impl [:all :in-edges])}) (def ^{:private true} default-flygraph-weighted-impl - {:weight* (fn + {:weight '(fn ([g] (partial weight g)) ([g e] (weight g (src e) (dest e))) ([g n1 n2] (call-or-return (:fweight g) n1 n2)))}) -(defrecord FlyGraph [fnodes fedges fsuccessors start]) -(defrecord FlyDigraph [fnodes fedges fsuccessors fpredecessors start]) -(defrecord WeightedFlyGraph [fnodes fedges fsuccessors fweight start]) -(defrecord WeightedFlyDigraph - [fnodes fedges fsuccessors fpredecessors fweight start]) +(comment + (defrecord FlyGraph [fnodes fedges fsuccessors start]) + (defrecord FlyDigraph [fnodes fedges fsuccessors fpredecessors start]) + (defrecord WeightedFlyGraph [fnodes fedges fsuccessors fweight start]) + (defrecord WeightedFlyDigraph + [fnodes fedges fsuccessors fpredecessors fweight start])) ;; Deprecate the flygraphs? Instead provide interfaces on algorithms to ;; run the algorithm on -(extend FlyGraph - Graph default-flygraph-graph-impl) +(defrecord FlyGraph [fnodes fedges fsuccessors start] Graph (nodes [g] (if (or (:fnodes g) (not (:start g))) (call-or-return (:fnodes g)) (bf-traverse (successors g) (:start g)))) (edges [g] (if (:fedges g) (call-or-return (:fedges g)) (for [n (nodes g) nbr (successors g n)] [n nbr]))) (successors [g] (partial successors g)) (successors [g node] (call-or-return (:fsuccessors g) node)) (out-degree [g node] (count (successors g node))) (out-edges [g] (partial out-edges g)) (out-edges [g node] (for [n2 (successors g node)] [node n2])) (has-node? [g node] (some #{node} (nodes g)))) +(defrecord FlyDigraph [fnodes fedges fsuccessors fpredecessors start] Graph (nodes [g] (if (or (:fnodes g) (not (:start g))) (call-or-return (:fnodes g)) (bf-traverse (successors g) (:start g)))) (edges [g] (if (:fedges g) (call-or-return (:fedges g)) (for [n (nodes g) nbr (successors g n)] [n nbr]))) (successors [g] (partial successors g)) (successors [g node] (call-or-return (:fsuccessors g) node)) (out-degree [g node] (count (successors g node))) (out-edges [g] (partial out-edges g)) (out-edges [g node] (for [n2 (successors g node)] [node n2])) (has-node? [g node] (some #{node} (nodes g))) Digraph (predecessors [g node] (call-or-return (:fpredecessors g) node)) (in-degree [g node] (count (predecessors g node)))) +(defrecord WeightedFlyGraph [fnodes fedges fsuccessors fweight start] Graph (nodes [g] (if (or (:fnodes g) (not (:start g))) (call-or-return (:fnodes g)) (bf-traverse (successors g) (:start g)))) (edges [g] (if (:fedges g) (call-or-return (:fedges g)) (for [n (nodes g) nbr (successors g n)] [n nbr]))) (successors [g] (partial successors g)) (successors [g node] (call-or-return (:fsuccessors g) node)) (out-degree [g node] (count (successors g node))) (out-edges [g] (partial out-edges g)) (out-edges [g node] (for [n2 (successors g node)] [node n2])) (has-node? [g node] (some #{node} (nodes g))) WeightedGraph (weight [g] (partial weight g)) (weight [g e] (weight g (src e) (dest e))) (weight [g n1 n2] (call-or-return (:fweight g) n1 n2))) +(defrecord WeightedFlyDigraph [fnodes fedges fsuccessors fpredecessors fweight start] Graph (nodes [g] (if (or (:fnodes g) (not (:start g))) (call-or-return (:fnodes g)) (bf-traverse (successors g) (:start g)))) (edges [g] (if (:fedges g) (call-or-return (:fedges g)) (for [n (nodes g) nbr (successors g n)] [n nbr]))) (successors [g] (partial successors g)) (successors [g node] (call-or-return (:fsuccessors g) node)) (out-degree [g node] (count (successors g node))) (out-edges [g] (partial out-edges g)) (out-edges [g node] (for [n2 (successors g node)] [node n2])) (has-node? [g node] (some #{node} (nodes g))) Digraph (predecessors [g node] (call-or-return (:fpredecessors g) node)) (in-degree [g node] (count (predecessors g node))) WeightedGraph (weight [g] (partial weight g)) (weight [g e] (weight g (src e) (dest e))) (weight [g n1 n2] (call-or-return (:fweight g) n1 n2))) + +(comment (macroexpand-1 '(extended-record FlyGraph [fnodes fedges fsuccessors start] + Graph default-flygraph-graph-impl))) + +(comment (macroexpand-1 '(extended-record FlyDigraph [fnodes fedges fsuccessors fpredecessors start] + Graph default-flygraph-graph-impl + Digraph default-flygraph-digraph-impl))) -(extend FlyDigraph - Graph default-flygraph-graph-impl - Digraph default-flygraph-digraph-impl) +(comment (macroexpand-1 '(extended-record WeightedFlyGraph [fnodes fedges fsuccessors fweight start] + Graph default-flygraph-graph-impl + WeightedGraph default-flygraph-weighted-impl))) -(extend WeightedFlyGraph - Graph default-flygraph-graph-impl - WeightedGraph default-flygraph-weighted-impl) +(comment (macroexpand-1 '(extended-record WeightedFlyDigraph [fnodes fedges fsuccessors fpredecessors fweight start] + Graph default-flygraph-graph-impl + Digraph default-flygraph-digraph-impl + WeightedGraph default-flygraph-weighted-impl))) -(extend WeightedFlyDigraph - Graph default-flygraph-graph-impl - Digraph default-flygraph-digraph-impl - WeightedGraph default-flygraph-weighted-impl) ;;; ;;; Utility functions and constructors @@ -486,35 +515,35 @@ on adjacency lists." [g & inits] (letfn [(build [g init] (cond - ;; graph - (graph? init) - (if (and (weighted? g) (weighted? init)) - (assoc - (reduce add-edges - (add-nodes* g (nodes init)) - (for [[n1 n2] (edges init)] - [n1 n2 (weight init n1 n2)])) - :attrs (merge (:attrs g) (:attrs init))) - (-> g - (add-nodes* (nodes init)) - (add-edges* (edges init)) - (assoc :attrs (merge (:attrs g) (:attrs init))))) - ;; adacency map - (map? init) - (let [es (if (map? (val (first init))) - (for [[n nbrs] init - [nbr wt] nbrs] - [n nbr wt]) - (for [[n nbrs] init - nbr nbrs] - [n nbr]))] - (-> g - (add-nodes* (keys init)) - (add-edges* es))) - ;; edge - (sequential? init) (add-edges g init) - ;; node - :else (add-nodes g init)))] + ;; graph + (graph? init) + (if (and (weighted? g) (weighted? init)) + (assoc + (reduce add-edges + (add-nodes* g (nodes init)) + (for [[n1 n2] (edges init)] + [n1 n2 (weight init n1 n2)])) + :attrs (merge (:attrs g) (:attrs init))) + (-> g + (add-nodes* (nodes init)) + (add-edges* (edges init)) + (assoc :attrs (merge (:attrs g) (:attrs init))))) + ;; adacency map + (map? init) + (let [es (if (map? (val (first init))) + (for [[n nbrs] init + [nbr wt] nbrs] + [n nbr wt]) + (for [[n nbrs] init + nbr nbrs] + [n nbr]))] + (-> g + (add-nodes* (keys init)) + (add-edges* es))) + ;; edge + (sequential? init) (add-edges g init) + ;; node + :else (add-nodes g init)))] (reduce build g inits))) (defn graph @@ -549,11 +578,11 @@ on adjacency lists." start are provided." [& {:keys [nodes edges successors predecessors weight start]}] (cond - (and predecessors weight) - (WeightedFlyDigraph. nodes edges successors predecessors weight start) - predecessors - (FlyDigraph. nodes edges successors predecessors start) - weight - (WeightedFlyGraph. nodes edges successors weight start) - :else - (FlyGraph. nodes edges successors start))) + (and predecessors weight) + (WeightedFlyDigraph. nodes edges successors predecessors weight start) + predecessors + (FlyDigraph. nodes edges successors predecessors start) + weight + (WeightedFlyGraph. nodes edges successors weight start) + :else + (FlyGraph. nodes edges successors start))) \ No newline at end of file