Enormous progress on routing, but not there yet.

All existing unit tests still pass, but new code is not instrumented yet.

src/walkmap/edge.clj

@@ -4,15 +4,15 @@
   nodes."
   (:require [clojure.math.numeric-tower :as m]
             [walkmap.utils :as u]
-            [walkmap.vertex :refer [canonicalise ensure2d ensure3d vertex vertex= vertex?]]))
+            [walkmap.vertex :refer [canonicalise check-vertex ensure2d ensure3d vertex vertex= vertex?]]))
 
 (defn edge
   "Return an edge between vertices `v1` and `v2`."
   [v1 v2]
-  (if
-    (and (vertex? v1) (vertex? v2))
-    {:kind :edge :walkmap.id/id (keyword (gensym "edge")) :start v1 :end v2}
-    (throw (IllegalArgumentException. "Must be vertices."))))
+  {:kind :edge
+   :walkmap.id/id (keyword (gensym "edge"))
+   :start (check-vertex v1)
+   :end (check-vertex v2)})
 
 (defn edge?
   "True if `o` satisfies the conditions for a edge. An edge shall be a map

src/walkmap/microworld.clj

@@ -10,7 +10,8 @@
             [walkmap.polygon :as p :only [rectangle]]
             [walkmap.superstructure :refer [store]]
             [walkmap.tag :as t :only [tag]]
-            [walkmap.vertex :as v :only [check-vertex vertex vertex?]]))
+            [walkmap.vertex :as v :only [check-vertex vertex vertex?]]
+            [walkmap.utils :as u :only [truncate]]))
 
 (defn cell->polygon
   "From this MicroWorld `cell`, construct a walkmap polygon (specifically,
@@ -23,7 +24,7 @@
      (assoc
        (merge
          cell
-         (let [w (* (:x cell) (:x (check-vertex scale-vector)))
+         (let [w (* (:x cell) (:x (v/check-vertex scale-vector)))
                s (* (:y cell) (:y scale-vector))
                e (+ w (:x scale-vector))
                n (+ s (:y scale-vector))

src/walkmap/path.clj

@@ -7,7 +7,7 @@
             [walkmap.polygon :refer [check-polygon polygon?]]
             [walkmap.tag :refer [tag tags]]
             [walkmap.utils :refer [check-kind-type check-kind-type-seq kind-type]]
-            [walkmap.vertex :refer [vertex?]]))
+            [walkmap.vertex :refer [check-vertices vertex?]]))
 
 (defn path?
   "True if `o` satisfies the conditions for a path. A path shall be a map
@@ -26,9 +26,8 @@
 (defn path
   "Return a path constructed from these `vertices`."
   [& vertices]
-  (check-kind-type-seq vertices vertex? :vertex)
   (if
-    (> (count vertices) 1)
+    (> (count (check-vertices vertices)) 1)
     {:vertices vertices :walkmap.id/id (keyword (gensym "path")) :kind :path}
     (throw (IllegalArgumentException. "Path must have more than one vertex."))))
 

src/walkmap/polygon.clj

@@ -3,7 +3,10 @@
   (:require [clojure.string :as s]
             [walkmap.edge :as e]
             [walkmap.tag :as t]
-            [walkmap.utils :refer [check-kind-type check-kind-type-seq kind-type]]
+            [walkmap.utils :refer [check-kind-type
+                                   check-kind-type-seq
+                                   kind-type
+                                   not-yet-implemented]]
             [walkmap.vertex :refer [check-vertex check-vertices vertex vertex?]]))
 
 (defn polygon?
@@ -72,10 +75,13 @@
                     (/ (reduce + (map #(or (:z %) 0) [vsw vne])) 2))
         vse (vertex (:x vne)
                     (:y vsw)
-                    (/ (reduce + (map #(or (:z %) 0) [vsw vne])) 2))]
+                    (/ (reduce + (map #(or (:z %) 0) [vsw vne])) 2))
+        height-order (sort-by :z [vsw vne])]
     (t/tag
       (assoc
         (polygon vsw vnw vne vse)
+        :gradient
+        (e/unit-vector (e/edge (first height-order) (last height-order)))
         :centre
         (vertex (+ (:x vsw) (/ (- (:x vne) (:x vsw)) 2))
                 (+ (:x vsw) (/ (- (:y vne) (:y vsw)) 2))
@@ -122,4 +128,28 @@
       (UnsupportedOperationException.
         "The general case of centre for polygons is not yet implemented."))))
 
+(defmacro on2dtriangle?
+  "Is the projection of this `vertex` on the x, y plane within the
+  projection of this triangle on that plane?"
+  [vertex poly]
+  `(not-yet-implemented "on2d? for triangles."))
 
+(defn on2drectangle?
+  "Is the projection of this `vertex` on the x, y plane within the
+  projection of this rectangle on that plane?"
+  [vertex rectangle]
+  (let [xo (sort-by :x (:vertices rectangle))
+        yo (sort-by :x (:vertices rectangle))]
+    (and
+      (< (:x (first xo)) (:x vertex) (:x (last xo)))
+      (< (:y (first yo)) (:y vertex) (:y (last yo))))))
+
+(defmacro on2d?
+  "Is the projection of this `vertex` on the x, y plane within the
+  projection of this polygon `poly` on that plane?"
+  [vertex poly]
+  `(cond
+    (rectangle? ~poly) (on2drectangle? ~vertex ~poly)
+    (triangle? ~poly) (on2dtriangle? ~vertex ~poly)
+    :else
+    (not-yet-implemented "general case of on2d? for polygons.")))

src/walkmap/read_svg.clj

@@ -95,3 +95,6 @@
     (let [xml (x/parse (io/file file-name))
           paths (progeny xml #(= (:tag %) :path))]
       (remove nil? (map path-elt->path paths)))))
+
+;; (read-svg "resources/iom/manual_roads.svg")
+

src/walkmap/routing.clj

@@ -1,6 +1,8 @@
 (ns walkmap.routing
   "Finding optimal routes to traverse a map."
-  (:require [walkman.edge :as e]
+  (:require [clojure.math.numeric-tower :as m :only [expt]]
+            [clojure.set :refer [intersection]]
+            [walkmap.edge :as e]
             [walkmap.path :as p]
             [walkmap.polygon :as q]
             [walkmap.superstructure :as s]
@@ -19,6 +21,20 @@
 ;;
 ;; See https://simon-brooke.github.io/the-great-game/codox/Pathmaking.html
 
+(def ^:dynamic *gradient-exponent*
+  "The exponent to be applied to `(inc (:z (unit-vector from to)))`
+  of a path segment to calculate the gradient-related part of the
+  cost of traversal. Dynamic, because we will want to tune this."
+  2)
+
+(def ^:dynamic *traversals-exponent*
+  "The (expected to be negative) exponent to be applied to the number
+  of traversals of a path to compute the road bonus. Paths more travelled by
+  should have larger bonuses, but not dramatically so - so the increase in
+  bonus needs to scale significantly less than linearly with the number
+  of traversals. Dynamic, because we will want to tune this."
+  -2)
+
 (defn traversable?
   "True if this object can be considered as part of the walkmap."
   [object]
@@ -30,6 +46,107 @@
       (p/path? object))
     (not (t/tagged? object :no-traversal))))
 
+(declare traversal-cost)
+
+(defn vertices-traversal-cost
+  [vertices s]
+  (reduce
+    +
+    (map
+      #(traversal-cost %1 %2 s)
+      (v/check-vertices vertices)
+      (rest vertices))))
+
+(defn path-traversal-cost
+  [path s]
+  (vertices-traversal-cost (:vertices (p/check-path path)) s))
+
+(defn barriers-crossed
+  "Search superstructure `s` and return a sequence of barriers, if any, which
+  obstruct traversal from vertex `from` to vertex `to`."
+  [from to s]
+  ;; TODO: implement
+  '())
+
+(defn crossing-penalty
+  "TODO: should return the cost of crossing this `barrier`, initially mainly
+  a watercourse, on the axis from vertex `from` to vertex `to`. in the context
+  of superstructure `s`. If there's a bridge, ferry or other crossing mechanism
+  in `s` at the intersection of the vertex and the barrier, then the penalty
+  should be substantially less than it would otherwise be."
+  [barrier from to s]
+  ;; TODO: implement
+  0)
+
+(defn gradient-cost
+  "Compute the per-unit-distance cost of traversing this `edge`."
+  [edge]
+  (let [g (:z (e/unit-vector edge))]
+    (if (pos? g)
+      (m/expt (inc g) *gradient-exponent*)
+      1)))
+
+;; (gradient-cost (e/edge (v/vertex 0 0 0) (v/vertex 0 1 0)))
+;; (gradient-cost (e/edge (v/vertex 0 0 0) (v/vertex 0 2 0)))
+;; (gradient-cost (e/edge (v/vertex 0 0 0) (v/vertex 0 1 1)))
+;; (gradient-cost (e/edge (v/vertex 0 0 0) (v/vertex 0 2 1)))
+;; (gradient-cost (e/edge (v/vertex 0 0 0) (v/vertex 0 1 0.0001)))
+
+(defn best-road
+  "Find the best traversable path which links the vertices `from` and `to`
+  in this superstructure `s`, or nil if there are none."
+  [from to s]
+  (let [f (fn [v] (set (s/touching v p/path? s)))]
+    (first
+      (sort-by
+        ;;; I... chose the path more travelled by.
+        #(or (:traversals %) 0)
+        (filter traversable? (intersection (f from) (f to)))))))
+
+(defn road-bonus
+  "Calculate the road bonus of the edge represented by the vertices `from`,
+  `to`, in the context of the superstructure `s`. Obviously there only is
+  such a bonus if there actually is an existing thoroughfare to use. Road
+  bonuses scale with some fractional exponent of the number of traversals
+  which have been made of the road segment in question."
+  [from to s]
+  (let [best (best-road from to s)]
+    (when (:traversals best)
+      (m/expt (:traversals best) *traversals-exponent*))))
+
+(defn traversal-cost
+  "Return the traversal cost of the edge represented by the vertices `from`,
+  `to`, in the context of the superstructure `s`. It is legitimate to pass
+  `nil` as the `to` argument, in which case the result will be zero, in order
+  to allow `reduce` to be used to compute total path costs."
+  [from to s]
+  (if (nil? to)
+    0
+    (let [edge (e/edge from to)
+          distance (e/length edge)]
+      (/
+        (+
+          (* distance
+             (gradient-cost edge))
+          (reduce +
+                  (map
+                    #(crossing-penalty [% from to s])
+                    (barriers-crossed from to s))))
+        (or (road-bonus from to s) 1)))))
+
+;; (def p '({:x 1.40625, :y 0, :kind :vertex, :walkmap.id/id :vert_1-40625_0}
+;;        {:x 1.40625, :y -10.703125, :kind :vertex, :walkmap.id/id :vert_1-40625_-10-703125}
+;;        {:x 7.578125, :y -10.703125, :kind :vertex, :walkmap.id/id :vert_7-578125_-10-703125}
+;;        {:x 7.578125, :y 0, :kind :vertex, :walkmap.id/id :vert_7-578125_0}
+;;        {:x 2.171875, :y -0.765625, :kind :vertex, :walkmap.id/id :vert_2-171875_-0-765625}
+;;        {:x 6.8125, :y -0.765625, :kind :vertex, :walkmap.id/id :vert_6-8125_-0-765625}))
+;; (v/check-vertices p)
+;; (def p' (p/path p))
+
+;; (traversal-cost (first p) (nth p 1) {})
+;; (vertices-traversal-cost p {})
+;; (path-traversal-cost (p/path p))
+
 (defn extend-frontier
   "Return a sequence like `frontier` with all of these `candidates` which are
   not already members either of `frontier` or of `rejects` appended."
@@ -60,7 +177,8 @@
                        (s/nearest s from :centre search-radius)
                        traversable?
                        s))
-          visited nil]
+          visited nil
+          track nil]
      (let [here (s/retrieve (first frontier) s)]
        (cond
          (< (e/length (e/edge (:centre here)) to) search-radius)
@@ -75,7 +193,9 @@
            t
            (extend-frontier
              (rest frontier)
-             (neighbour-ids here traversable? s)
+             (s/neighbour-ids here traversable? s)
              visited)
-           (cons here visited)))))))
+           (cons here visited)
+           ;; this is going to be wrong, and I need to think about how to fix.
+           (cons here track)))))))
 

src/walkmap/superstructure.clj

@@ -29,10 +29,21 @@
 (defn vertices
   "If `o` is an object with vertices, return those vertices, else nil."
   [o]
-  (cond
-    (v/vertex? o) (list o)
-    (q/polygon? o) (:vertices o)
-    (p/path? o) (:vertices o)))
+  (when (map? o)
+    (reduce
+      concat
+      (remove
+        nil?
+        (map
+          #(cond
+             (v/vertex? %) (list %)
+             (and (coll? %) (every? v/vertex? %)) %)
+          (vals o))))))
+;;   (cond
+;;     (v/vertex? o) (list o)
+;;     (q/polygon? o) (:vertices o)
+;;     (p/path? o) (:vertices o))
+;;   )
 
 (defn index-vertex
   "Return a superstructure like `s` in which object `o` is indexed by vertex
@@ -171,7 +182,12 @@
   "Search superstructure `s` for vertices within the box defined by vertices
   `minv` and `maxv`. Every coordinate in `minv` must have a lower value than
   the equivalent coordinate in `maxv`. If `d2?` is supplied and not false,
-  search only in the x,y projection."
+  search only in the x,y projection.
+
+  **NOTE THAT** this depends on the fact that vertices do not currently
+  have properties which will be denormalised by `store`, and therefore do not
+  have to restored with `retrieve`. If properties are added to vertices
+  whose values are objects, then this will have to be rewritten."
   ([s minv maxv]
    (search-vertices s minv maxv false))
   ([s minv maxv d2?]
@@ -219,6 +235,18 @@
                          :walkmap.id/id
                          (search-vertices s minv maxv))))))))))))
 
+(defn touching
+  "Return a sequence of all objects in superstructure `s` which are
+  indexed as touching the vertex `v`."
+  ([vertex s]
+   (map
+     #(retrieve % s)
+     (set (-> s :vertex-index (:walkmap.id/id (v/check-vertex vertex)) keys))))
+  ([vertex filter-fn s]
+   (filter
+     filter-fn
+     (touching vertex s))))
+
 (defn neighbours
   "Return a sequence of all those objects in superstructure `s` which share
   at least one vertex with `target`, and which are matched by `filter-fn`
@@ -226,8 +254,13 @@
   ([target s]
    (neighbours identity s))
   ([target filter-fn s]
-  ;; TODO: write it.
-  nil))
+   (remove
+     #(= target %)
+     (reduce
+       concat
+       (remove
+         nil?
+         (map #(touching % filter-fn s) (vertices target)))))))
 
 (defn neighbour-ids
   "Return a sequence of the ids all those objects in superstructure `s` which

src/walkmap/utils.clj

@@ -111,3 +111,9 @@
       (printf "Couldn't open '%s': %s\n" source (.getMessage e)))
     (catch RuntimeException e
       (printf "Error parsing edn file '%s': %s\n" source (.getMessage e)))))
+
+(defn not-yet-implemented
+  [message]
+  (throw
+    (UnsupportedOperationException.
+      (str "Not yet implemented: " message))))