001 (ns walkmap.routing
002 "Finding optimal routes to traverse a map."
003 (:require [clojure.math.numeric-tower :as m :only [expt]]
004 [clojure.set :refer [intersection]]
005 [walkmap.edge :as e]
006 [walkmap.path :as p]
007 [walkmap.polygon :as q]
008 [walkmap.superstructure :as s]
009 [walkmap.tag :as t]
010 [walkmap.utils :as u]
011 [walkmap.vertex :as v]))
012
013 ;; Breadth first search is a good algorithm for terrain in which all steps have
014 ;; equal, but in our world (like the real world), they don't.
015
016 ;; Reading list:
017 ;;
018 ;; https://en.wikipedia.org/wiki/A*_search_algorithm
019 ;; https://www.redblobgames.com/pathfinding/a-star/introduction.html
020 ;; https://faculty.nps.edu/ncrowe/opmpaper2.htm
021 ;;
022 ;; See https://simon-brooke.github.io/the-great-game/codox/Pathmaking.html
023
024 (def ^:dynamic *gradient-exponent*
025 "The exponent to be applied to `(inc (:z (unit-vector from to)))`
026 of a path segment to calculate the gradient-related part of the
027 cost of traversal. Dynamic, because we will want to tune this."
028 2)
029
030 (def ^:dynamic *traversals-exponent*
031 "The (expected to be negative) exponent to be applied to the number
032 of traversals of a path to compute the road bonus. Paths more travelled by
033 should have larger bonuses, but not dramatically so - so the increase in
034 bonus needs to scale significantly less than linearly with the number
035 of traversals. Dynamic, because we will want to tune this."
036 -2)
037
038 (defn traversable?
039 "True if this object can be considered as part of the walkmap."
040 [object]
041 (and
042 (or
043 (and
044 (q/polygon? object)
045 (:centre object))
046 (p/path? object))
047 (not (t/tagged? object :no-traversal))))
048
049 (declare traversal-cost)
050
051 (defn vertices-traversal-cost
052 [vertices s]
053 (reduce
054 +
055 (map
056 #(traversal-cost %1 %2 s)
057 (v/check-vertices vertices)
058 (rest vertices))))
059
060 (defn path-traversal-cost
061 [path s]
062 (vertices-traversal-cost (:vertices (p/check-path path)) s))
063
064 (defn barriers-crossed
065 "Search superstructure `s` and return a sequence of barriers, if any, which
066 obstruct traversal from vertex `from` to vertex `to`."
067 [from to s]
068 ;; TODO: implement
069 '())
070
071 (defn crossing-penalty
072 "TODO: should return the cost of crossing this `barrier`, initially mainly
073 a watercourse, on the axis from vertex `from` to vertex `to`. in the context
074 of superstructure `s`. If there's a bridge, ferry or other crossing mechanism
075 in `s` at the intersection of the vertex and the barrier, then the penalty
076 should be substantially less than it would otherwise be."
077 [barrier from to s]
078 ;; TODO: implement
079 0)
080
081 (defn gradient-cost
082 "Compute the per-unit-distance cost of traversing this `edge`."
083 [edge]
084 (let [g (:z (e/unit-vector edge))]
085 (if (pos? g)
086 (m/expt (inc g) *gradient-exponent*)
087 1)))
088
089 ;; (gradient-cost (e/edge (v/vertex 0 0 0) (v/vertex 0 1 0)))
090 ;; (gradient-cost (e/edge (v/vertex 0 0 0) (v/vertex 0 2 0)))
091 ;; (gradient-cost (e/edge (v/vertex 0 0 0) (v/vertex 0 1 1)))
092 ;; (gradient-cost (e/edge (v/vertex 0 0 0) (v/vertex 0 2 1)))
093 ;; (gradient-cost (e/edge (v/vertex 0 0 0) (v/vertex 0 1 0.0001)))
094
095 (defn best-road
096 "Find the best traversable path which links the vertices `from` and `to`
097 in this superstructure `s`, or nil if there are none."
098 [from to s]
099 (let [f (fn [v] (set (s/touching v p/path? s)))]
100 (first
101 (sort-by
102 ;;; I... chose the path more travelled by.
103 #(or (:traversals %) 0)
104 (filter traversable? (intersection (f from) (f to)))))))
105
106 (defn road-bonus
107 "Calculate the road bonus of the edge represented by the vertices `from`,
108 `to`, in the context of the superstructure `s`. Obviously there only is
109 such a bonus if there actually is an existing thoroughfare to use. Road
110 bonuses scale with some fractional exponent of the number of traversals
111 which have been made of the road segment in question."
112 [from to s]
113 (let [best (best-road from to s)]
114 (when (:traversals best)
115 (m/expt (:traversals best) *traversals-exponent*))))
116
117 (defn traversal-cost
118 "Return the traversal cost of the edge represented by the vertices `from`,
119 `to`, in the context of the superstructure `s`. It is legitimate to pass
120 `nil` as the `to` argument, in which case the result will be zero, in order
121 to allow `reduce` to be used to compute total path costs."
122 [from to s]
123 (if (nil? to)
124 0
125 (let [edge (e/edge from to)
126 distance (e/length edge)]
127 (/
128 (+
129 (* distance
130 (gradient-cost edge))
131 (reduce +
132 (map
133 #(crossing-penalty [% from to s])
134 (barriers-crossed from to s))))
135 (or (road-bonus from to s) 1)))))
136
137 ;; (def p '({:x 1.40625, :y 0, :kind :vertex, :walkmap.id/id :vert_1-40625_0}
138 ;; {:x 1.40625, :y -10.703125, :kind :vertex, :walkmap.id/id :vert_1-40625_-10-703125}
139 ;; {:x 7.578125, :y -10.703125, :kind :vertex, :walkmap.id/id :vert_7-578125_-10-703125}
140 ;; {:x 7.578125, :y 0, :kind :vertex, :walkmap.id/id :vert_7-578125_0}
141 ;; {:x 2.171875, :y -0.765625, :kind :vertex, :walkmap.id/id :vert_2-171875_-0-765625}
142 ;; {:x 6.8125, :y -0.765625, :kind :vertex, :walkmap.id/id :vert_6-8125_-0-765625}))
143 ;; (v/check-vertices p)
144 ;; (def p' (p/path p))
145
146 ;; (traversal-cost (first p) (nth p 1) {})
147 ;; (vertices-traversal-cost p {})
148 ;; (path-traversal-cost (p/path p))
149
150 (defn extend-frontier
151 "Return a sequence like `frontier` with all of these `candidates` which are
152 not already members either of `frontier` or of `rejects` appended."
153 ([frontier candidates]
154 (extend-frontier frontier candidates nil))
155 ([frontier candidates rejects]
156 (if
157 (empty? frontier)
158 candidates
159 (let [fs (set (concat frontier rejects))]
160 (concat frontier (remove fs candidates))))))
161
162 ;; (extend-frontier '(1 2 3 4 5) '(7 3 6 2 9 8) '(6 8))
163 ;; (extend-frontier '(1 2 3 4 5) '(7 3 6 2 9 8))
164 ;; (extend-frontier '(1 2 3 4 5) '())
165 ;; (extend-frontier '(1 2 3 4 5) nil)
166 ;; (extend-frontier nil '(1 2 3 4 5))
167
168 (defn route
169 ;; NOT YET GOOD ENOUGH! Simple breadth first, and although it will
170 ;; reach the goal
171 ([from to s search-radius]
172 (loop [f from
173 t to
174 frontier (extend-frontier
175 nil
176 (s/neighbour-ids
177 (s/nearest s from :centre search-radius)
178 traversable?
179 s))
180 visited nil
181 track nil]
182 (let [here (s/retrieve (first frontier) s)]
183 (cond
184 (< (e/length (e/edge (:centre here)) to) search-radius)
185 ;; close enough
186 (apply p/path (cons (:centre here) track))
187 (empty? (rest frontier))
188 ;; failed
189 nil
190 :else
191 (recur
192 f
193 t
194 (extend-frontier
195 (rest frontier)
196 (s/neighbour-ids here traversable? s)
197 visited)
198 (cons here visited)
199 ;; this is going to be wrong, and I need to think about how to fix.
200 (cons here track)))))))
201