simon/walkmap
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Massive code clean-up, all tests still pass.

Browse source 
...but I'm still struggling to understand how it works and how I use it. Memo to self: document your code better.
This commit is contained in:
Simon Brooke 2024-04-08 22:36:10 +01:00
parent 156775fc79
commit cb5041e684
11 changed files with 235 additions and 250 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
src/cc/journeyman/walkmap/edge.clj
View file

@ -3,7 +3,6 @@
An edge is a line segment having just a start and an end, with no intervening An edge is a line segment having just a start and an end, with no intervening
nodes." nodes."
(:require [clojure.math.numeric-tower :as m] (:require [clojure.math.numeric-tower :as m]
[cc.journeyman.walkmap.utils :as u]
[cc.journeyman.walkmap.vertex :refer [canonicalise check-vertex ensure2d ensure3d vertex vertex= vertex?]])) [cc.journeyman.walkmap.vertex :refer [canonicalise check-vertex ensure2d ensure3d vertex vertex= vertex?]]))
(defn edge (defn edge
@ -149,7 +148,7 @@
not an edge." not an edge."
([e1 e2] ([e1 e2]
(intersection2d e1 e2 :x :y :z)) (intersection2d e1 e2 :x :y :z))
([e1 e2 c1 c2 c3] ([e1 e2 c1 c2 _c3]
(if (and (edge? e1) (edge? e2)) (if (and (edge? e1) (edge? e2))
(when (when
(overlaps2d? e1 e2) ;; relatively cheap check (overlaps2d? e1 e2) ;; relatively cheap check

52
src/cc/journeyman/walkmap/microworld.clj
View file

@ -2,36 +2,36 @@
"An interface between walkmap and microworld, to allow use of microworld "An interface between walkmap and microworld, to allow use of microworld
functionality to model things like rainfall, soil fertility, settlement functionality to model things like rainfall, soil fertility, settlement
and so on." and so on."
(:require [clojure.edn :as edn :only [read]] (:require [cc.journeyman.walkmap.polygon :refer [rectangle]]
[clojure.java.io :as io]
[clojure.string :as s]
[taoensso.timbre :as l]
[cc.journeyman.walkmap.edge :as e]
[cc.journeyman.walkmap.polygon :as p :only [rectangle]]
[cc.journeyman.walkmap.superstructure :refer [store]] [cc.journeyman.walkmap.superstructure :refer [store]]
[cc.journeyman.walkmap.tag :as t :only [tag]] [cc.journeyman.walkmap.tag :refer [tag]]
[cc.journeyman.walkmap.vertex :as v :only [check-vertex vertex vertex?]] [cc.journeyman.walkmap.vertex :refer [check-vertex vertex]]
[cc.journeyman.walkmap.utils :as u :only [truncate]])) [cc.journeyman.walkmap.utils :refer [truncate]]
[clojure.edn :as edn :only [read]]
[clojure.java.io :refer [reader]]
[taoensso.timbre :refer [error]])
(:import [clojure.lang Keyword Map]
[java.io PushbackReader]))
(defn cell->polygon (defn cell->polygon
"From this MicroWorld `cell`, construct a walkmap polygon (specifically, "From this MicroWorld `cell`, construct a walkmap polygon (specifically,
a rectangle. If `scale-vector` passed and is a vertex, scale all the vertices a rectangle). If `scale-vector` passed and is a vertex, scale all the vertices
in the cell by that vector." in the cell by that vector."
([cell] ([cell]
(cell->polygon cell (v/vertex 1 1 1))) (cell->polygon cell (vertex 1 1 1)))
([cell scale-vector] ([cell scale-vector]
(t/tag (tag
(assoc (assoc
(merge (merge
cell cell
(let [w (* (:x cell) (:x (v/check-vertex scale-vector))) (let [w (* (:x cell) (:x (check-vertex scale-vector)))
s (* (:y cell) (:y scale-vector)) s (* (:y cell) (:y scale-vector))
e (+ w (:x scale-vector)) e (+ w (:x scale-vector))
n (+ s (:y scale-vector)) n (+ s (:y scale-vector))
z (* (:altitude cell) (:z scale-vector))] z (* (:altitude cell) (:z scale-vector))]
(p/rectangle (rectangle
(v/vertex s w z) (vertex s w z)
(v/vertex n e z)))) (vertex n e z))))
:walkmap.id/id :walkmap.id/id
(keyword (gensym "mw-cell"))) (keyword (gensym "mw-cell")))
(:state cell)))) (:state cell))))
@ -42,23 +42,23 @@
compute-heavy that it's much more sensible to do it in batch mode. So the compute-heavy that it's much more sensible to do it in batch mode. So the
better plan is to be able to pull the output from MicroWorld - as an EDN better plan is to be able to pull the output from MicroWorld - as an EDN
structure - into a walkmap superstructure." structure - into a walkmap superstructure."
([filename] ([^String filename]
(load-microworld-edn filename :mw)) (load-microworld-edn filename :mw))
([filename map-kind] ([^String filename ^Keyword map-kind]
(when-not (when-not
(keyword? map-kind) (keyword? map-kind)
(throw (IllegalArgumentException. (throw (IllegalArgumentException.
(u/truncate (truncate
(str "Must be a keyword: " (or map-kind "nil")) 80)))) (format "Must be a keyword: %s." (or map-kind "nil")) 80))))
(load-microworld-edn filename map-kind nil)) (load-microworld-edn filename map-kind nil))
([filename mapkind superstucture] ([^String filename ^Keyword mapkind ^Map superstucture]
(load-microworld-edn filename mapkind superstucture (v/vertex 1 1 1))) (load-microworld-edn filename mapkind superstucture (vertex 1 1 1)))
([filename map-kind superstructure scale-vertex] ([^String filename ^Keyword _map-kind ^Map superstructure ^Map _scale-vertex]
(let [mw (try (let [mw (try
(with-open [r (io/reader filename)] (with-open [r (reader filename)]
(edn/read (java.io.PushbackReader. r))) (edn/read (PushbackReader. r)))
(catch RuntimeException e (catch RuntimeException e
(l/error "Error parsing edn file '%s': %s\n" (error "Error parsing edn file '%s': %s\n"
filename (.getMessage e)))) filename (.getMessage e))))
polys (reduce polys (reduce
concat concat

8
src/cc/journeyman/walkmap/path.clj
View file

@ -2,11 +2,9 @@
"Essentially the specification for things we shall consider to be path. "Essentially the specification for things we shall consider to be path.
**Note that** for these purposes `path` means any continuous linear **Note that** for these purposes `path` means any continuous linear
feature, where such features specifically include watercourses." feature, where such features specifically include watercourses."
(:require [clojure.string :as s] (:require [cc.journeyman.walkmap.edge :as e]
[cc.journeyman.walkmap.edge :as e] [cc.journeyman.walkmap.polygon :refer [polygon?]]
[cc.journeyman.walkmap.polygon :refer [check-polygon polygon?]] [cc.journeyman.walkmap.utils :refer [check-kind-type check-kind-type-seq]]
[cc.journeyman.walkmap.tag :refer [tag tags]]
[cc.journeyman.walkmap.utils :refer [check-kind-type check-kind-type-seq kind-type]]
[cc.journeyman.walkmap.vertex :refer [check-vertices vertex?]])) [cc.journeyman.walkmap.vertex :refer [check-vertices vertex?]]))
(defn path? (defn path?

2
src/cc/journeyman/walkmap/polygon.clj
View file

@ -139,7 +139,7 @@
projection of this rectangle on that plane?" projection of this rectangle on that plane?"
[vertex rectangle] [vertex rectangle]
(let [xo (sort-by :x (:vertices rectangle)) (let [xo (sort-by :x (:vertices rectangle))
yo (sort-by :x (:vertices rectangle))] yo (sort-by :y (:vertices rectangle))]
(and (and
(< (:x (first xo)) (:x vertex) (:x (last xo))) (< (:x (first xo)) (:x vertex) (:x (last xo)))
(< (:y (first yo)) (:y vertex) (:y (last yo)))))) (< (:y (first yo)) (:y vertex) (:y (last yo))))))

9
src/cc/journeyman/walkmap/read_svg.clj
View file

@ -1,16 +1,11 @@
(ns cc.journeyman.walkmap.read-svg (ns cc.journeyman.walkmap.read-svg
"Utility functions for scalable vector graphics (SVG) into walkmap "Utility functions for scalable vector graphics (SVG) into walkmap
structures." structures."
(:require [clojure.data.zip :as dz] (:require [clojure.java.io :as io]
[clojure.data.zip.xml :as zx]
[clojure.java.io :as io]
[clojure.string :as s] [clojure.string :as s]
[clojure.xml :as x] [clojure.xml :as x]
[clojure.zip :as z]
[taoensso.timbre :as l]
[cc.journeyman.walkmap.path :refer [path]] [cc.journeyman.walkmap.path :refer [path]]
[cc.journeyman.walkmap.tag :refer [tag]] [cc.journeyman.walkmap.tag :refer [tag]]
[cc.journeyman.walkmap.utils :refer [kind-type truncate]]
[cc.journeyman.walkmap.vertex :refer [vertex vertex?]])) [cc.journeyman.walkmap.vertex :refer [vertex vertex?]]))
(defn upper-case? (defn upper-case?
@ -91,7 +86,7 @@
;; quite small XML files. So I've implemented my own solution. ;; quite small XML files. So I've implemented my own solution.
([file-name] ([file-name]
(read-svg file-name nil)) (read-svg file-name nil))
([file-name map-kind] ([file-name _map-kind]
(let [xml (x/parse (io/file file-name)) (let [xml (x/parse (io/file file-name))
paths (progeny xml #(= (:tag %) :path))] paths (progeny xml #(= (:tag %) :path))]
(remove nil? (map path-elt->path paths))))) (remove nil? (map path-elt->path paths)))))

81
src/cc/journeyman/walkmap/routing.clj
View file

@ -1,16 +1,15 @@
(ns cc.journeyman.walkmap.routing (ns cc.journeyman.walkmap.routing
"Finding optimal routes to traverse a map." "Finding optimal routes to traverse a map."
(:require [clojure.math.numeric-tower :as m :only [expt]] (:require [clojure.math.numeric-tower :refer [expt]]
[clojure.set :refer [intersection]] [clojure.set :refer [intersection]]
[clojure.string :as cs :only [join]]
[search.core :refer [a*]]
[cc.journeyman.walkmap.edge :as e] [cc.journeyman.walkmap.edge :as e]
[cc.journeyman.walkmap.path :as p] [cc.journeyman.walkmap.path :as p]
[cc.journeyman.walkmap.polygon :as q] [cc.journeyman.walkmap.polygon :as q]
[cc.journeyman.walkmap.superstructure :as s] [cc.journeyman.walkmap.superstructure :as s]
[cc.journeyman.walkmap.tag :as t] [cc.journeyman.walkmap.tag :refer [tags]]
[cc.journeyman.walkmap.utils :as u] [cc.journeyman.walkmap.vertex :as v]
[cc.journeyman.walkmap.vertex :as v])) [search.core :refer [a*]]
[taoensso.timbre :refer [debug]]))
;; Breadth first search is a good algorithm for terrain in which all steps have ;; Breadth first search is a good algorithm for terrain in which all steps have
;; equal, but in our world (like the real world), they don't. ;; equal, but in our world (like the real world), they don't.
@ -37,25 +36,30 @@
of traversals. Dynamic, because we will want to tune this." of traversals. Dynamic, because we will want to tune this."
-2) -2)
(def ^:dynamic *untraversable*
"The set of all tags which may indicate that a polygon should not be
traversed."
#{:no-traversal})
(defn traversable? (defn traversable?
"True if this `object` is a polygon which can be considered as part of "True if this `object` is a polygon which can be considered as part of
the walkmap." the walkmap."
[object] [object]
(and (and
(q/polygon? object) (q/polygon? object)
(:centre object) (:centre object)
(not (t/tagged? object :no-traversal)))) (empty? (intersection (tags object) *untraversable*))))
(declare traversal-cost) (declare traversal-cost)
(defn vertices-traversal-cost (defn vertices-traversal-cost
[vertices s] [vertices s]
(reduce (reduce
+ +
(map (map
#(traversal-cost %1 %2 s) #(traversal-cost %1 %2 s)
(v/check-vertices vertices) (v/check-vertices vertices)
(rest vertices)))) (rest vertices))))
(defn path-traversal-cost (defn path-traversal-cost
[path s] [path s]
@ -64,7 +68,8 @@
(defn barriers-crossed (defn barriers-crossed
"Search superstructure `s` and return a sequence of barriers, if any, which "Search superstructure `s` and return a sequence of barriers, if any, which
obstruct traversal from vertex `from` to vertex `to`." obstruct traversal from vertex `from` to vertex `to`."
[from to s] [from to _s]
(debug (format "barriers-crossed called with vertices\n\tfrom: %s\n\tto: %s" from to))
;; TODO: implement ;; TODO: implement
'()) '())
@ -74,7 +79,8 @@
of superstructure `s`. If there's a bridge, ferry or other crossing mechanism 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 in `s` at the intersection of the vertex and the barrier, then the penalty
should be substantially less than it would otherwise be." should be substantially less than it would otherwise be."
[barrier from to s] [barrier from to _s]
(debug (format "crossing-penalty called with arguments\n\tbarrier: %s\n\tfrom: %s\n\tto: %s" barrier from to))
;; TODO: implement ;; TODO: implement
0) 0)
@ -83,7 +89,7 @@
[edge] [edge]
(let [g (:z (e/unit-vector edge))] (let [g (:z (e/unit-vector edge))]
(if (pos? g) (if (pos? g)
(m/expt (inc g) *gradient-exponent*) (expt (inc g) *gradient-exponent*)
1))) 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 1 0)))
@ -98,10 +104,10 @@
[from to s] [from to s]
(let [f (fn [v] (set (s/touching v p/path? s)))] (let [f (fn [v] (set (s/touching v p/path? s)))]
(first (first
(sort-by (sort-by
;;; I... chose the path more travelled by. ;;; I... chose the path more travelled by.
#(or (:traversals %) 0) #(or (:traversals %) 0)
(filter traversable? (intersection (f from) (f to))))))) (filter traversable? (intersection (f from) (f to)))))))
(defn road-bonus (defn road-bonus
"Calculate the road bonus of the edge represented by the vertices `from`, "Calculate the road bonus of the edge represented by the vertices `from`,
@ -112,7 +118,7 @@
[from to s] [from to s]
(let [best (best-road from to s)] (let [best (best-road from to s)]
(when (:traversals best) (when (:traversals best)
(m/expt (:traversals best) *traversals-exponent*)))) (expt (:traversals best) *traversals-exponent*))))
(defn traversal-cost (defn traversal-cost
"Return the traversal cost of the edge represented by the vertices `from`, "Return the traversal cost of the edge represented by the vertices `from`,
@ -125,14 +131,14 @@
(let [edge (e/edge from to) (let [edge (e/edge from to)
distance (e/length edge)] distance (e/length edge)]
(/ (/
(+ (+
(* distance (* distance
(gradient-cost edge)) (gradient-cost edge))
(reduce + (reduce +
(map (map
#(crossing-penalty [% from to s]) #(crossing-penalty % from to s)
(barriers-crossed from to s)))) (barriers-crossed from to s))))
(or (road-bonus from to s) 1))))) (or (road-bonus from to s) 1)))))
;; (def p '({:x 1.40625, :y 0, :kind :vertex, :walkmap.id/id :vert_1-40625_0} ;; (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 1.40625, :y -10.703125, :kind :vertex, :walkmap.id/id :vert_1-40625_-10-703125}
@ -154,11 +160,11 @@
([frontier candidates] ([frontier candidates]
(extend-frontier frontier candidates nil)) (extend-frontier frontier candidates nil))
([frontier candidates rejects] ([frontier candidates rejects]
(if (if
(empty? frontier) (empty? frontier)
candidates candidates
(let [fs (set (concat frontier rejects))] (let [fs (set (concat frontier rejects))]
(concat frontier (remove fs candidates)))))) (concat frontier (remove fs candidates))))))
;; (extend-frontier '(1 2 3 4 5) '(7 3 6 2 9 8) '(6 8)) ;; (extend-frontier '(1 2 3 4 5) '(7 3 6 2 9 8) '(6 8))
;; (extend-frontier '(1 2 3 4 5) '(7 3 6 2 9 8)) ;; (extend-frontier '(1 2 3 4 5) '(7 3 6 2 9 8))
@ -176,11 +182,10 @@
[target search-radius s] [target search-radius s]
(let [r (s/nearest s target traversable? search-radius)] (let [r (s/nearest s target traversable? search-radius)]
(when-not r (throw (when-not r (throw
(Exception. (Exception.
(cs/join " " ["Unable to find walkable facet within" (format "Unable to find walkable facet within %s of %s"
search-radius search-radius
"of" target))))
target]))))
r)) r))
(defn route (defn route

57
src/cc/journeyman/walkmap/stl.clj
View file

@ -1,19 +1,18 @@
(ns cc.journeyman.walkmap.stl (ns cc.journeyman.walkmap.stl
"Utility functions dealing with stereolithography (STL) files. Not a stable API yet!" "Utility functions dealing with stereolithography (STL) files. Not a stable API yet!"
(:require [clojure.java.io :as io :refer [file output-stream input-stream]] (:require
[clojure.string :as s] [cc.journeyman.walkmap.ocean :refer [ocean?]]
[me.raynes.fs :as fs] [cc.journeyman.walkmap.polygon :refer [centre gradient polygon?]]
[org.clojars.smee.binary.core :as b] [cc.journeyman.walkmap.superstructure :refer [store]]
[taoensso.timbre :as l] [cc.journeyman.walkmap.tag :refer [tag]]
[cc.journeyman.walkmap.edge :as e] [cc.journeyman.walkmap.utils :refer [truncate]]
[cc.journeyman.walkmap.ocean :as o] [cc.journeyman.walkmap.vertex :as v]
[cc.journeyman.walkmap.polygon :refer [centre gradient polygon?]] [clojure.lang.io :refer [input-stream]]
[cc.journeyman.walkmap.superstructure :refer [store]] [clojure.string :as s]
[cc.journeyman.walkmap.tag :refer [tag]] [me.raynes.fs :refer [base-name split-ext]]
[cc.journeyman.walkmap.utils :as u] [org.clojars.smee.binary.core :as b]
[cc.journeyman.walkmap.vertex :as v]) [taoensso.timbre :refer [debug]])
(:import org.clojars.smee.binary.core.BinaryIO (:import [clojure.lang Keyword]))
java.io.DataInput))
(defn stl? (defn stl?
"True if `o` is recogniseable as an STL structure. An STL structure must "True if `o` is recogniseable as an STL structure. An STL structure must
@ -64,13 +63,13 @@
(defaults to `:height`). It is an error, and an exception will be thrown, if (defaults to `:height`). It is an error, and an exception will be thrown, if
`map-kind` is not a keyword." `map-kind` is not a keyword."
([o] (canonicalise o :height)) ([o] (canonicalise o :height))
([o map-kind] ([o ^Keyword map-kind]
(canonicalise o map-kind (v/vertex 1 1 1))) (canonicalise o map-kind (v/vertex 1 1 1)))
([o map-kind scale-vertex] ([o ^Keyword map-kind scale-vertex]
(when-not (when-not
(keyword? map-kind) (keyword? map-kind)
(throw (IllegalArgumentException. (throw (IllegalArgumentException.
(u/truncate (str "Must be a keyword: " (or map-kind "nil")) 80)))) (truncate (str "Must be a keyword: " (or map-kind "nil")) 80))))
(cond (cond
(and (coll? o) (not (map? o))) (map #(canonicalise % map-kind) o) (and (coll? o) (not (map? o))) (map #(canonicalise % map-kind) o)
;; if it has :facets it's an STL structure, but it doesn't yet conform to `stl?` ;; if it has :facets it's an STL structure, but it doesn't yet conform to `stl?`
@ -92,13 +91,13 @@
(:vertices o) (:vertices o)
map-kind)) map-kind))
:facet map-kind)))] :facet map-kind)))]
(if (o/ocean? f) (if (ocean? f)
(tag f :ocean :no-traversal) (tag f :ocean :no-traversal)
f)) f))
;; if it has a value for :x it's a vertex, but it may not yet conform ;; if it has a value for :x it's a vertex, but it may not yet conform
;; to `vertex?`; it should also be scaled using the scale-vertex, if any. ;; to `vertex?`; it should also be scaled using the scale-vertex, if any.
(:x o) (let [c (v/canonicalise o)] (:x o) (let [c (v/canonicalise o)]
(if scale-vertex (if (v/vertex? scale-vertex)
(v/vertex* c scale-vertex) (v/vertex* c scale-vertex)
c)) c))
;; shouldn't happen ;; shouldn't happen
@ -122,18 +121,14 @@
**NOTE** that we've no way of verifying that the input file is binary STL **NOTE** that we've no way of verifying that the input file is binary STL
data, if it is not this will run but will return garbage." data, if it is not this will run but will return garbage."
([filename] ([^String filename]
(decode-binary-stl filename :height)) (decode-binary-stl filename :height))
([filename map-kind] ([^String filename ^Keyword map-kind]
(when-not
(keyword? map-kind)
(throw (IllegalArgumentException.
(u/truncate (str "Must be a keyword: " (or map-kind "nil")) 80))))
(decode-binary-stl filename map-kind nil)) (decode-binary-stl filename map-kind nil))
([filename mapkind superstucture] ([^String filename ^Keyword mapkind superstucture]
(decode-binary-stl filename mapkind superstucture (v/vertex 1 1 1))) (decode-binary-stl filename mapkind superstucture (v/vertex 1 1 1)))
([filename map-kind superstructure scale-vertex] ([^String filename ^Keyword map-kind superstructure scale-vertex]
(let [in (io/input-stream filename) (let [in (input-stream filename)
stl (canonicalise (b/decode binary-stl in) map-kind scale-vertex)] stl (canonicalise (b/decode binary-stl in) map-kind scale-vertex)]
(if (if
(map? superstructure) (map? superstructure)
@ -175,12 +170,12 @@
"Write an `stl` structure as read by `decode-binary-stl` to this "Write an `stl` structure as read by `decode-binary-stl` to this
`filename` as ASCII encoded STL." `filename` as ASCII encoded STL."
([filename stl] ([filename stl]
(let [b (fs/base-name filename true)] (let [b (base-name filename true)]
(write-ascii-stl (write-ascii-stl
filename stl filename stl
(subs b 0 (or (s/index-of b ".") (count b)))))) (subs b 0 (or (s/index-of b ".") (count b))))))
([filename stl solidname] ([filename stl solidname]
(l/debug "Solid name is " solidname) (debug "Solid name is " solidname)
(spit (spit
filename filename
(stl->ascii stl solidname)))) (stl->ascii stl solidname))))
@ -190,7 +185,7 @@
`out-filename`, if specified; otherwise, to a file with the same basename `out-filename`, if specified; otherwise, to a file with the same basename
as `in-filename` but the extension `.ascii.stl`." as `in-filename` but the extension `.ascii.stl`."
([in-filename] ([in-filename]
(let [[_ ext] (fs/split-ext in-filename)] (let [[_ ext] (split-ext in-filename)]
(binary-stl-to-ascii (binary-stl-to-ascii
in-filename in-filename
(str (str

167
src/cc/journeyman/walkmap/superstructure.clj
View file

@ -3,15 +3,16 @@
(:require [clojure.walk :refer [postwalk]] (:require [clojure.walk :refer [postwalk]]
[taoensso.timbre :as l] [taoensso.timbre :as l]
[cc.journeyman.walkmap.edge :refer [edge length]] [cc.journeyman.walkmap.edge :refer [edge length]]
[cc.journeyman.walkmap.path :as p] ;; [cc.journeyman.walkmap.path :as p]
[cc.journeyman.walkmap.polygon :as q] ;; [cc.journeyman.walkmap.polygon :as q]
[cc.journeyman.walkmap.utils :as u] [cc.journeyman.walkmap.utils :as u]
[cc.journeyman.walkmap.vertex :as v])) [cc.journeyman.walkmap.vertex :as v])
(:import [clojure.lang IFn Map]))
;; TODO: Think about reification/dereification. How can we cull a polygon, if ;; TODO: Think about reification/dereification. How can we cull a polygon, if
;; some vertices still index it? I *think* that what's needed is that when ;; some vertices still index it? I *think* that what's needed is that when
;; we store something in the superstructure, we replace all its vertices (and ;; we store something in the superstructure, we replace all its vertices (and
;; other dependent structures, if any with their ids - as well as, obviously, ;; other dependent structures, if any) with their ids - as well as, obviously,
;; adding/merging those vertices/dependent structures into the superstructure ;; adding/merging those vertices/dependent structures into the superstructure
;; as first class objects in themselves. That means, for each identified thing, ;; as first class objects in themselves. That means, for each identified thing,
;; the superstructure only contains one copy of it. ;; the superstructure only contains one copy of it.
@ -31,14 +32,14 @@
[o] [o]
(when (map? o) (when (map? o)
(reduce (reduce
concat concat
(remove (remove
nil? nil?
(map (map
#(cond #(cond
(v/vertex? %) (list %) (v/vertex? %) (list %)
(and (coll? %) (every? v/vertex? %)) %) (and (coll? %) (every? v/vertex? %)) %)
(vals o)))))) (vals o))))))
;; (cond ;; (cond
;; (v/vertex? o) (list o) ;; (v/vertex? o) (list o)
;; (q/polygon? o) (:vertices o) ;; (q/polygon? o) (:vertices o)
@ -53,7 +54,7 @@
2. `o` is not a map; 2. `o` is not a map;
3. `o` does not have a value for the key `:walkmap.id/id`; 3. `o` does not have a value for the key `:walkmap.id/id`;
4. `v` is not a vertex." 4. `v` is not a vertex."
[s o v] [^Map s ^Map o ^Map v]
(if-not (v/vertex? o) (if-not (v/vertex? o)
(if (:walkmap.id/id o) (if (:walkmap.id/id o)
(if (v/vertex? v) (if (v/vertex? v)
@ -77,14 +78,14 @@
3. `o` does not have a value for the key `:walkmap.id/id`." 3. `o` does not have a value for the key `:walkmap.id/id`."
[s o] [s o]
(u/deep-merge (u/deep-merge
s s
{::vertex-index {::vertex-index
(reduce (reduce
u/deep-merge u/deep-merge
{} {}
(map (map
#(index-vertex s o %) #(index-vertex s o %)
(:vertices o)))})) (:vertices o)))}))
(defn in-retrieve (defn in-retrieve
"Internal guts of `retrieve`, q.v. `x` can be anything; `s` must be a "Internal guts of `retrieve`, q.v. `x` can be anything; `s` must be a
@ -99,17 +100,17 @@
x) x)
;; if it's a map, for every key which is not `:walkmap.id/id`, recurse. ;; if it's a map, for every key which is not `:walkmap.id/id`, recurse.
(map? x) (let [v (reduce (map? x) (let [v (reduce
(fn [m k] (fn [m k]
(assoc m k (in-retrieve (x k) s))) (assoc m k (in-retrieve (x k) s)))
{} {}
(keys (dissoc x :walkmap.id/id))) (keys (dissoc x :walkmap.id/id)))
id (:walkmap.id/id x)] id (:walkmap.id/id x)]
;; if it has an id, bind it to that id in the returned value. ;; if it has an id, bind it to that id in the returned value.
(if id (if id
(assoc (assoc
v v
:walkmap.id/id :walkmap.id/id
(:walkmap.id/id x)) (:walkmap.id/id x))
v)) v))
(set? x) x ;; TODO: should I search in sets for objects when storing? (set? x) x ;; TODO: should I search in sets for objects when storing?
(coll? x) (map #(in-retrieve % s) x) (coll? x) (map #(in-retrieve % s) x)
@ -132,9 +133,9 @@
(set? o) s ;; TODO: should I search in sets for objects when storing? (set? o) s ;; TODO: should I search in sets for objects when storing?
(map? o) (if (:walkmap.id/id o) (map? o) (if (:walkmap.id/id o)
(assoc (assoc
(in-store-find-objects (vals o) s) (in-store-find-objects (vals o) s)
(:walkmap.id/id o) (:walkmap.id/id o)
o) o)
(in-store-find-objects (vals o) s)) (in-store-find-objects (vals o) s))
(coll? o) (reduce merge s (map #(in-store-find-objects % s) o)) (coll? o) (reduce merge s (map #(in-store-find-objects % s) o))
:else s))) :else s)))
@ -145,9 +146,9 @@
`in-store`, q.v. Use at your own peril." `in-store`, q.v. Use at your own peril."
[o] [o]
(assoc (assoc
(postwalk #(or (:walkmap.id/id %) %) (dissoc o :walkmap.id/id)) (postwalk #(or (:walkmap.id/id %) %) (dissoc o :walkmap.id/id))
:walkmap.id/id :walkmap.id/id
(:walkmap.id/id o))) (:walkmap.id/id o)))
;; (in-store-replace-with-keys (p/path (v/vertex 0 0 0) (v/vertex 0 1 2) (v/vertex 3 3 3))) ;; (in-store-replace-with-keys (p/path (v/vertex 0 0 0) (v/vertex 0 1 2) (v/vertex 3 3 3)))
;; (in-store-find-objects (p/path (v/vertex 0 0 0) (v/vertex 0 1 2) (v/vertex 3 3 3))) ;; (in-store-find-objects (p/path (v/vertex 0 0 0) (v/vertex 0 1 2) (v/vertex 3 3 3)))
@ -161,22 +162,22 @@
1. `s` is not a map; 1. `s` is not a map;
2. `o` is not a recognisable walkmap object" 2. `o` is not a recognisable walkmap object"
([o] ([^Map o]
(store o {})) (store o {}))
([o s] ([^Map o ^Map s]
(when-not (:walkmap.id/id o) (when-not (:walkmap.id/id o)
(throw (throw
(IllegalArgumentException. (IllegalArgumentException.
(str "Not a walkmap object: no value for `:walkmap.id/id`: " (str "Not a walkmap object: no value for `:walkmap.id/id`: "
(u/kind-type o))))) (u/kind-type o)))))
(when-not (map? s) (when-not (map? s)
(throw (throw
(IllegalArgumentException. (IllegalArgumentException.
(str "Superstructure must be a map: " (u/kind-type s))))) (str "Superstructure must be a map: " (u/kind-type s)))))
(assoc (assoc
(u/deep-merge s (in-store-find-objects o) (index-vertices s o)) (u/deep-merge s (in-store-find-objects o) (index-vertices s o))
(:walkmap.id/id o) (:walkmap.id/id o)
(in-store-replace-with-keys o)))) (in-store-replace-with-keys o))))
(defn search-vertices (defn search-vertices
"Search superstructure `s` for vertices within the box defined by vertices "Search superstructure `s` for vertices within the box defined by vertices
@ -188,14 +189,14 @@
have properties which will be denormalised by `store`, and therefore do not have properties which will be denormalised by `store`, and therefore do not
have to restored with `retrieve`. If properties are added to vertices have to restored with `retrieve`. If properties are added to vertices
whose values are objects, then this will have to be rewritten." whose values are objects, then this will have to be rewritten."
([s minv maxv] ([^Map s ^Map minv ^Map maxv]
(search-vertices s minv maxv false)) (search-vertices s minv maxv false))
([s minv maxv d2?] ([s minv maxv d2?]
(let [minv' (if d2? (assoc minv :z Double/NEGATIVE_INFINITY) minv) (let [minv' (if d2? (assoc minv :z Double/NEGATIVE_INFINITY) minv)
maxv' (if d2? (assoc maxv :z Double/POSITIVE_INFINITY) maxv)] maxv' (if d2? (assoc maxv :z Double/POSITIVE_INFINITY) maxv)]
(filter (filter
#(v/within-box? % minv maxv) #(v/within-box? % minv' maxv')
(filter #(= (:kind %) :vertex) (vals s)))))) (filter #(= (:kind %) :vertex) (vals s))))))
(defn nearest (defn nearest
"Search superstructure `s` for the nearest object matching `filter-fn` to "Search superstructure `s` for the nearest object matching `filter-fn` to
@ -205,68 +206,72 @@
WARNING: currently only returns objects which have a defined `:centre` WARNING: currently only returns objects which have a defined `:centre`
(but most of the significant objects we have do)." (but most of the significant objects we have do)."
[s target filter-fn radius] ([^Map s ^Map target ^Number radius]
(let [minv (v/vertex (nearest s target :centre radius))
([^Map s ^Map target ^IFn filter-fn ^Number radius]
(let [minv (v/vertex
(- (:x (v/check-vertex target)) radius) (- (:x (v/check-vertex target)) radius)
(- (:y target) radius) (- (or (:z target) 0) radius)) (- (:y target) radius) (- (or (:z target) 0) radius))
maxv (v/vertex maxv (v/vertex
(+ (:x target) 0.5) (+ (:y target) 0.5) (+ (:x target) 0.5) (+ (:y target) 0.5)
(+ (or (:z target) 0) 0.5))] (+ (or (:z target) 0) 0.5))]
;; filter those objects with the filter function, then sort that list ;; filter those objects with the filter function, then sort that list
;; by the edge distance from the target to the `:centre` of the object ;; by the edge distance from the target to the `:centre` of the object
;; and take the first ;; and take the first
(first (first
(sort-by (sort-by
#(length (edge target (:centre %))) #(length (edge target (:centre %)))
(filter
filter-fn
(filter (filter
:centre :centre
(map #(retrieve % s) (map #(retrieve % s)
;; for each vertex id in vids, get the objects associated with that id ;; for each vertex id in vids, get the objects associated with that id
;; in the vertex index as a single flat list ;; in the vertex index as a single flat list
(reduce (reduce
concat concat
(remove (remove
nil? nil?
(map (map
#(-> s ::vertex-index % keys) #(-> s ::vertex-index % keys)
;; get all the vertex ids within radius of the target ;; get all the vertex ids within radius of the target
(set (set
(map (map
:walkmap.id/id :walkmap.id/id
(search-vertices s minv maxv)))))))))))) (search-vertices s minv maxv))))))))))))))
(defn touching (defn touching
"Return a sequence of all objects in superstructure `s` which are "Return a sequence of all objects in superstructure `s` which are
indexed as touching the vertex `v`." indexed as touching the vertex `v`."
([vertex s] ([^Map vertex ^Map s]
(map (map
#(retrieve % s) #(retrieve % s)
(set (-> s :vertex-index (:walkmap.id/id (v/check-vertex vertex)) keys)))) (set (-> s :vertex-index (:walkmap.id/id (v/check-vertex vertex)) keys))))
([vertex filter-fn s] ([^Map vertex ^IFn filter-fn ^Map s]
(filter (filter
filter-fn filter-fn
(touching vertex s)))) (touching vertex s))))
(defn neighbours (defn neighbours
"Return a sequence of all those objects in superstructure `s` which share "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` at least one vertex with `target`, and which are matched by `filter-fn`
if supplied." if supplied."
([target s] ([^Map target ^Map s]
(neighbours identity s)) (neighbours target identity s))
([target filter-fn s] ([^Map target ^IFn filter-fn ^Map s]
(remove (remove
#(= target %) #(= target %)
(reduce (reduce
concat concat
(remove (remove
nil? nil?
(map #(touching % filter-fn s) (vertices target))))))) (map #(touching % filter-fn s) (vertices target)))))))
(defn neighbour-ids (defn neighbour-ids
"Return a sequence of the ids all those objects in superstructure `s` which "Return a sequence of the ids all those objects in superstructure `s` which
share at least one vertex with `target`, and which are matched by share at least one vertex with `target`, and which are matched by
`filter-fn` if supplied." `filter-fn` if supplied."
([target s] ([^Map target ^Map s]
(neighbour-ids target identity s)) (neighbour-ids target identity s))
([target filter-fn s] ([^Map target ^IFn filter-fn ^Map s]
(map :walkmap.id/id (neighbours target filter-fn s)))) (map :walkmap.id/id (neighbours target filter-fn s))))

14
src/cc/journeyman/walkmap/svg.clj
View file

@ -2,16 +2,12 @@
"Utility functions for writing stereolithography (STL) files (and possibly, "Utility functions for writing stereolithography (STL) files (and possibly,
later, other geometry files of interest to us) as scalable vector graphics later, other geometry files of interest to us) as scalable vector graphics
(SVG)." (SVG)."
(:require [clojure.java.io :as io] (:require [clojure.string :as s]
[clojure.string :as s]
[clojure.xml :as x]
[dali.io :as neatly-folded-clock] [dali.io :as neatly-folded-clock]
[hiccup.core :refer [html]] [hiccup.core :refer [html]]
[taoensso.timbre :as l :refer [info error spy]] [taoensso.timbre :refer [info]]
[cc.journeyman.walkmap.ocean :refer [cull-ocean-facets]] [cc.journeyman.walkmap.ocean :refer [cull-ocean-facets]]
[cc.journeyman.walkmap.polygon :refer [polygon?]] [cc.journeyman.walkmap.stl :refer [decode-binary-stl]]))
[cc.journeyman.walkmap.stl :refer [decode-binary-stl]]
[cc.journeyman.walkmap.vertex :refer [vertex?]]))
(def ^:dynamic *preferred-svg-render* (def ^:dynamic *preferred-svg-render*
"Mainly for debugging dali; switch SVG renderer to use. Expected values: "Mainly for debugging dali; switch SVG renderer to use. Expected values:
@ -88,7 +84,7 @@
(map (map
#(reduce max (map :y (:vertices %))) #(reduce max (map :y (:vertices %)))
(:facets stl)))] (:facets stl)))]
(l/info "Generating SVG for " *preferred-svg-render* " renderer") (info "Generating SVG for " *preferred-svg-render* " renderer")
(case *preferred-svg-render* (case *preferred-svg-render*
:hiccup (hiccup-stl->svg stl minx maxx miny maxy) :hiccup (hiccup-stl->svg stl minx maxx miny maxy)
:dali (dali-stl->svg stl minx maxx miny maxy) :dali (dali-stl->svg stl minx maxx miny maxy)
@ -102,7 +98,7 @@
(stl->svg (cull-ocean-facets (decode-binary-stl in-filename)))) (stl->svg (cull-ocean-facets (decode-binary-stl in-filename))))
([in-filename out-filename] ([in-filename out-filename]
(let [s (binary-stl-file->svg in-filename)] (let [s (binary-stl-file->svg in-filename)]
(l/info "Emitting SVG with " *preferred-svg-render* " renderer") (info "Emitting SVG with " *preferred-svg-render* " renderer")
(case *preferred-svg-render* (case *preferred-svg-render*
:dali (neatly-folded-clock/render-svg s out-filename) :dali (neatly-folded-clock/render-svg s out-filename)
:hiccup (spit out-filename (html s)) :hiccup (spit out-filename (html s))

18
src/cc/journeyman/walkmap/tag.clj
View file

@ -4,7 +4,8 @@
This is in an attempt to avoid name clashes with other uses of this key." This is in an attempt to avoid name clashes with other uses of this key."
(:require [clojure.set :refer [difference union]] (:require [clojure.set :refer [difference union]]
[taoensso.timbre :as l] [taoensso.timbre :as l]
[cc.journeyman.walkmap.utils :refer [kind-type]])) [cc.journeyman.walkmap.utils :refer [kind-type]])
(:import [clojure.lang Map]))
(defn tagged? (defn tagged?
"True if this `object` is tagged with each of these `tags`. It is an error "True if this `object` is tagged with each of these `tags`. It is an error
@ -12,10 +13,7 @@
1. `object` is not a map; 1. `object` is not a map;
2. any of `tags` is not a keyword." 2. any of `tags` is not a keyword."
[object & tags] [^Map object & tags]
(when-not (map? object)
(throw (IllegalArgumentException.
(str "Must be a map: " (kind-type object)))))
(let [tags' (flatten tags)] (let [tags' (flatten tags)]
(when-not (every? keyword? tags') (when-not (every? keyword? tags')
(throw (IllegalArgumentException. (throw (IllegalArgumentException.
@ -35,11 +33,8 @@
It's legal to include sequences of keywords in `tags`, so that users can do It's legal to include sequences of keywords in `tags`, so that users can do
useful things like `(tag obj (map keyword some-strings))`." useful things like `(tag obj (map keyword some-strings))`."
[object & tags] [^Map object & tags]
(l/debug "Tagging" (kind-type object) "with" tags) (l/debug "Tagging" (kind-type object) "with" tags)
(when-not (map? object)
(throw (IllegalArgumentException.
(str "Must be a map: " (kind-type object)))))
(let [tags' (flatten tags)] (let [tags' (flatten tags)]
(when-not (every? keyword? tags') (when-not (every? keyword? tags')
(throw (IllegalArgumentException. (throw (IllegalArgumentException.
@ -57,10 +52,7 @@
1. `object` is not a map; 1. `object` is not a map;
2. any of `tags` is not a keyword or sequence of keywords." 2. any of `tags` is not a keyword or sequence of keywords."
[object & tags] [^Map object & tags]
(when-not (map? object)
(throw (IllegalArgumentException.
(str "Must be a map: " (kind-type object)))))
(let [tags' (flatten tags)] (let [tags' (flatten tags)]
(when-not (every? keyword? tags') (when-not (every? keyword? tags')
(throw (IllegalArgumentException. (throw (IllegalArgumentException.

74
src/cc/journeyman/walkmap/utils.clj
View file

@ -3,16 +3,16 @@
(:require [clojure.edn :as edn :only [read]] (:require [clojure.edn :as edn :only [read]]
[clojure.java.io :as io] [clojure.java.io :as io]
[clojure.math.numeric-tower :as m] [clojure.math.numeric-tower :as m]
[clojure.set :refer [union]]
[clojure.string :as s])) [clojure.string :as s]))
(defn deep-merge (defn deep-merge
"Recursively merges maps. If vals are not maps, the last value wins." "Recursively merges maps. If vals are not maps, the last value wins."
;; TODO: not my implementation, not sure I entirely trust it. ;; TODO: not my implementation, not sure I entirely trust it.
;; TODO TODO: if we are to successfully merge walkmap objects, we must
;; return, on each object, the union of its tags if any.
[& vals] [& vals]
(if (every? map? vals) (if (every? map? vals)
(apply merge-with deep-merge vals) (let [tags (apply union (map :cc.journeyman.walkmap.tag/tags vals))]
(assoc (apply merge-with deep-merge vals) :cc.journeyman.walkmap.tag/tags tags))
(last vals))) (last vals)))
(defn truncate (defn truncate
@ -27,20 +27,20 @@
"Identify the type of an `object`, e.g. for logging. If it has a `:kind` key, "Identify the type of an `object`, e.g. for logging. If it has a `:kind` key,
it's one of ours, and that's what we want. Otherwise, we want its type; but it's one of ours, and that's what we want. Otherwise, we want its type; but
the type of `nil` is `nil`, which doesn't get printed when assembling error the type of `nil` is `nil`, which doesn't get printed when assembling error
,essages, so return \"nil\"." messages, so return \"nil\"."
[object] [object]
(or (:kind object) (type object) "nil")) (or (:kind object) (type object) "nil"))
(defn =ish (defn =ish
"True if numbers `n1`, `n2` are roughly equal; that is to say, equal to "True if numbers `n1`, `n2` are roughly equal; that is to say, equal to
within `tolerance` (defaults to one part in one hundred thousand)." within `tolerance` (defaults to one part in one hundred thousand)."
([n1 n2] ([^Number n1 ^Number n2]
(if (and (number? n1) (number? n2)) (if (and (number? n1) (number? n2))
(let [m (m/abs (min n1 n2)) (let [m (m/abs (min n1 n2))
t (if (zero? m) 0.00001 (* 0.00001 m))] t (if (zero? m) 0.00001 (* 0.00001 m))]
(=ish n1 n2 t)) (=ish n1 n2 t))
(= n1 n2))) (= n1 n2)))
([n1 n2 tolerance] ([^Number n1 ^Number n2 ^Number tolerance]
(if (and (number? n1) (number? n2)) (if (and (number? n1) (number? n2))
(< (m/abs (- n1 n2)) tolerance) (< (m/abs (- n1 n2)) tolerance)
(= n1 n2)))) (= n1 n2))))
@ -55,18 +55,18 @@
([object expected] ([object expected]
`(if-not (= (kind-type ~object) ~expected) `(if-not (= (kind-type ~object) ~expected)
(throw (throw
(IllegalArgumentException. (IllegalArgumentException.
(s/join (s/join
" " " "
["Expected" ~expected "but found" (kind-type ~object)]))) ["Expected" ~expected "but found" (kind-type ~object)])))
~object)) ~object))
([object checkfn expected] ([object checkfn expected]
`(if-not (~checkfn ~object) `(if-not (~checkfn ~object)
(throw (throw
(IllegalArgumentException. (IllegalArgumentException.
(s/join (s/join
" " " "
["Expected" ~expected "but found" (kind-type ~object)]))) ["Expected" ~expected "but found" (kind-type ~object)])))
~object))) ~object)))
(defmacro check-kind-type-seq (defmacro check-kind-type-seq
@ -77,29 +77,29 @@
Macro, so that the exception is thrown from the calling function." Macro, so that the exception is thrown from the calling function."
([s expected] ([s expected]
`(if-not (every? #(= (kind-type %) ~expected) ~s) `(if-not (every? #(= (kind-type %) ~expected) ~s)
(throw (throw
(IllegalArgumentException. (IllegalArgumentException.
(s/join (s/join
" " " "
["Expected sequence of" ["Expected sequence of"
~expected ~expected
"but found (" "but found ("
(s/join ", " (remove #(= ~expected %) (map kind-type ~s))) (s/join ", " (remove #(= ~expected %) (map kind-type ~s)))
")"]))) ")"])))
~s)) ~s))
([s checkfn expected] ([s checkfn expected]
`(if-not (every? #(~checkfn %) ~s) `(if-not (every? #(~checkfn %) ~s)
(throw (throw
(IllegalArgumentException. (IllegalArgumentException.
(s/join (s/join
" " " "
["Expected sequence of" ["Expected sequence of"
~expected ~expected
"but found (" "but found ("
(s/join ", " (remove #(= ~expected %) (map kind-type ~s))) (s/join ", " (remove #(= ~expected %) (map kind-type ~s)))
")"]))) ")"])))
~s))) ~s)))
(defn load-edn (defn load-edn
"Load edn from an io/reader source (filename or io/resource)." "Load edn from an io/reader source (filename or io/resource)."
@ -115,5 +115,5 @@
(defn not-yet-implemented (defn not-yet-implemented
[message] [message]
(throw (throw
(UnsupportedOperationException. (UnsupportedOperationException.
(str "Not yet implemented: " message)))) (str "Not yet implemented: " message))))