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

Can *probably* convert MicroWorld to STL

Browse source 
Code is written. It isn't tested.
This commit is contained in:
Simon Brooke 2024-04-12 22:29:16 +01:00
parent a0b2b93f6b
commit 4187b52c66
6 changed files with 102820 additions and 66411 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

@ -10,6 +10,8 @@ pom.xml.asc
*.svg *.svg
/.lein-* /.lein-*
/.nrepl-port /.nrepl-port
.clj-kondo
.lsp
.hgignore .hgignore
.hg/ .hg/

3
project.clj
View file

@ -15,6 +15,9 @@
[hiccup "1.0.5"] [hiccup "1.0.5"]
[macroz/search "0.3.0"] [macroz/search "0.3.0"]
[me.raynes/fs "1.4.6"] [me.raynes/fs "1.4.6"]
[mw-engine "0.3.0-SNAPSHOT"]
[net.mikera/core.matrix "0.63.0"]
[net.mikera/vectorz-clj "0.48.0"]
[smee/binary "0.5.5"]] [smee/binary "0.5.5"]]
:deploy-repositories [["releases" :clojars] :deploy-repositories [["releases" :clojars]
["snapshots" :clojars]] ["snapshots" :clojars]]

168876
resources/iom/superstructure_20140412.edn
View file

File diff suppressed because it is too large Load diff

50
src/cc/journeyman/walkmap/mw_stl.clj Normal file
View file

@ -0,0 +1,50 @@
(ns cc.journeyman.walkmap.mw-stl
"Convert from Microworld to STL format"
(:require [cc.journeyman.walkmap.ocean :refer [cull-ocean-facets]]
[cc.journeyman.walkmap.polygon :refer [polygon]]
[cc.journeyman.walkmap.vertex :refer [vertex]]
[mw-engine.utils :refer [get-cell map-world]]))
(defn mean-altitude
[cells]
(let [c (remove nil? cells)]
(if (= (count c) 1)
(:altitude (first c))
(/ (reduce + (map :altitude c)) (count c)))))
(defn cell->facets
"Convert a cell into facets.
All facets in an STL file must be triangles, so each MicroWorld cell needs
to be split into two. I am not at present seeing a rational rule for
splitting cells, so at this stage I'm going to do it randomly to prevent
parallel ridge artifacts appearing in the output.
This function is designed to be used with `mw-engint.utils/map-world`, q.v."
[world cell]
(let [;; bounds
n (:y cell)
e (:x cell)
s (inc n)
w (inc e)
;; corner altitudes
nea (mean-altitude [cell (get-cell world (dec n) (dec e))])
nwa (mean-altitude [cell (get-cell world (dec n) (inc e))])
swa (mean-altitude [cell (get-cell world (inc n) (inc e))])
sea (mean-altitude [cell (get-cell world (inc n) (dec e))])]
(if (rand-nth [true false])
[(polygon (vertex n e nea) (vertex n w nwa) (vertex s e sea))
(polygon (vertex n w nwa) (vertex s e sea) (vertex s w swa))]
[(polygon (vertex n e nea) (vertex n w nwa) (vertex s w sea))
(polygon (vertex n e nwa) (vertex s e sea) (vertex s w swa))])))
(defn mw->stl
"Return an STL structure representing the topology of this MicroWorld world
`mw`. If `title` is supplied use that as the title of the STL structure."
([mw]
(mw->stl mw nil))
([mw title]
(let [facets (cull-ocean-facets (flatten (map-world mw cell->facets)))
stl {:facets facets
:count (count facets)}]
(if title (assoc stl :title title) stl))))

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

@ -4,9 +4,9 @@
[cc.journeyman.walkmap.edge :as e] [cc.journeyman.walkmap.edge :as e]
[cc.journeyman.walkmap.tag :as t] [cc.journeyman.walkmap.tag :as t]
[cc.journeyman.walkmap.utils :refer [check-kind-type [cc.journeyman.walkmap.utils :refer [check-kind-type
check-kind-type-seq check-kind-type-seq
kind-type kind-type
not-yet-implemented]] not-yet-implemented]]
[cc.journeyman.walkmap.vertex :refer [check-vertex check-vertices vertex vertex?]])) [cc.journeyman.walkmap.vertex :refer [check-vertex check-vertices vertex vertex?]]))
(defn polygon? (defn polygon?
@ -15,13 +15,13 @@
of vertices." of vertices."
[o] [o]
(let (let
[v (:vertices o)] [v (:vertices o)]
(and (and
(coll? v) (coll? v)
(> (count v) 2) (> (count v) 2)
(every? vertex? v) (every? vertex? v)
(:walkmap.id/id o) (:walkmap.id/id o)
(or (nil? (:kind o)) (= (:kind o) :polygon))))) (or (nil? (:kind o)) (= (:kind o) :polygon)))))
(defmacro check-polygon (defmacro check-polygon
"If `o` is not a polygon, throw an `IllegalArgumentException` with an "If `o` is not a polygon, throw an `IllegalArgumentException` with an
@ -42,8 +42,8 @@
polygon with exactly three vertices." polygon with exactly three vertices."
[o] [o]
(and (and
(coll? o) (coll? o)
(= (count (:vertices o)) 3))) (= (count (:vertices o)) 3)))
(defmacro check-triangle (defmacro check-triangle
"If `o` is not a triangle, throw an `IllegalArgumentException` with an "If `o` is not a triangle, throw an `IllegalArgumentException` with an
@ -52,16 +52,38 @@
[o] [o]
`(check-kind-type ~o triangle? :triangle)) `(check-kind-type ~o triangle? :triangle))
(def recognised-polygon-types #{:triangle
:quadrilateral
:pentagon
:hexagon
:heptagon
:octogon
:polygon})
(defn- poly-kind
"Return a keyword representing the kind of polygon which has this many
`vertices`."
[vertices]
(case (count vertices)
3 :triangle
4 :quadrilateral
5 :pentagon
6 :hexagon
7 :heptagon
8 :octogon
;;else
:polygon))
(defn polygon (defn polygon
"Return a polygon constructed from these `vertices`." "Return a polygon constructed from these `vertices`."
[& vertices] [& vertices]
(if (if
(> (count vertices) 2) (> (count vertices) 2)
{:vertices (check-vertices vertices) {:vertices (check-vertices vertices)
:walkmap.id/id (keyword (gensym "poly")) :walkmap.id/id (keyword (gensym "poly"))
:kind :polygon} :kind (poly-kind vertices)}
(throw (IllegalArgumentException. (throw (IllegalArgumentException.
"A polygon must have at least 3 vertices.")))) "A polygon must have at least 3 vertices."))))
(defn rectangle (defn rectangle
"Return a rectangle, with edges aligned east-west and north-south, whose "Return a rectangle, with edges aligned east-west and north-south, whose
@ -78,15 +100,15 @@
(/ (reduce + (map #(or (:z %) 0) [vsw vne])) 2)) (/ (reduce + (map #(or (:z %) 0) [vsw vne])) 2))
height-order (sort-by :z [vsw vne])] height-order (sort-by :z [vsw vne])]
(t/tag (t/tag
(assoc (assoc
(polygon vsw vnw vne vse) (polygon vsw vnw vne vse)
:gradient :gradient
(e/unit-vector (e/edge (first height-order) (last height-order))) (e/unit-vector (e/edge (first height-order) (last height-order)))
:centre :centre
(vertex (+ (:x vsw) (/ (- (:x vne) (:x vsw)) 2)) (vertex (+ (:x vsw) (/ (- (:x vne) (:x vsw)) 2))
(+ (:x vsw) (/ (- (:y vne) (:y vsw)) 2)) (+ (:y vsw) (/ (- (:y vne) (:y vsw)) 2))
(:z vse))) (:z vse)))
:rectangle))) :rectangle)))
;; (rectangle (vertex 1 2 3) (vertex 7 9 4)) ;; (rectangle (vertex 1 2 3) (vertex 7 9 4))
@ -98,7 +120,7 @@
(:vertices (check-triangle triangle))) (:vertices (check-triangle triangle)))
highest (first order) highest (first order)
lowest (last order)] lowest (last order)]
(assoc triangle :gradient (e/unit-vector (e/edge lowest highest))))) (assoc triangle :gradient (e/unit-vector (e/edge lowest highest)))))
(defn triangle-centre (defn triangle-centre
"Return a canonicalised `facet` (i.e. a triangular polygon) with an added "Return a canonicalised `facet` (i.e. a triangular polygon) with an added
@ -111,13 +133,13 @@
v1 (first vs) v1 (first vs)
opposite (e/edge (nth vs 1) (nth vs 2)) opposite (e/edge (nth vs 1) (nth vs 2))
oc (e/centre opposite)] oc (e/centre opposite)]
(assoc (assoc
facet facet
:centre :centre
(vertex (vertex
(+ (:x v1) (* (- (:x oc) (:x v1)) 2/3)) (+ (:x v1) (* (- (:x oc) (:x v1)) 2/3))
(+ (:y v1) (* (- (:y oc) (:y v1)) 2/3)) (+ (:y v1) (* (- (:y oc) (:y v1)) 2/3))
(+ (:z v1) (* (- (:z oc) (:z v1)) 2/3)))))) (+ (:z v1) (* (- (:z oc) (:z v1)) 2/3))))))
(defn centre (defn centre
[poly] [poly]
@ -125,8 +147,8 @@
3 (triangle-centre poly) 3 (triangle-centre poly)
;; else ;; else
(throw (throw
(UnsupportedOperationException. (UnsupportedOperationException.
"The general case of centre for polygons is not yet implemented.")))) "The general case of centre for polygons is not yet implemented."))))
(defmacro on2dtriangle? (defmacro on2dtriangle?
"Is the projection of this `vertex` on the x, y plane within the "Is the projection of this `vertex` on the x, y plane within the
@ -141,15 +163,15 @@
(let [xo (sort-by :x (:vertices rectangle)) (let [xo (sort-by :x (:vertices rectangle))
yo (sort-by :y (: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))))))
(defmacro on2d? (defmacro on2d?
"Is the projection of this `vertex` on the x, y plane within the "Is the projection of this `vertex` on the x, y plane within the
projection of this polygon `poly` on that plane?" projection of this polygon `poly` on that plane?"
[vertex poly] [vertex poly]
`(cond `(cond
(rectangle? ~poly) (on2drectangle? ~vertex ~poly) (rectangle? ~poly) (on2drectangle? ~vertex ~poly)
(triangle? ~poly) (on2dtriangle? ~vertex ~poly) (triangle? ~poly) (on2dtriangle? ~vertex ~poly)
:else :else
(not-yet-implemented "general case of on2d? for polygons."))) (not-yet-implemented "general case of on2d? for polygons.")))

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

@ -1,19 +1,23 @@
(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 (:require [cc.journeyman.walkmap.ocean :refer [ocean?]]
[cc.journeyman.walkmap.ocean :refer [ocean?]] [cc.journeyman.walkmap.polygon :refer [centre gradient triangle?]]
[cc.journeyman.walkmap.polygon :refer [centre gradient polygon?]] [cc.journeyman.walkmap.superstructure :refer [store]]
[cc.journeyman.walkmap.superstructure :refer [store]] [cc.journeyman.walkmap.tag :refer [tag]]
[cc.journeyman.walkmap.tag :refer [tag]] [cc.journeyman.walkmap.utils :refer [kind-type truncate]]
[cc.journeyman.walkmap.utils :refer [truncate]] [cc.journeyman.walkmap.vertex :as v :refer [vertex]]
[cc.journeyman.walkmap.vertex :as v] [clojure.core.matrix :refer [set-current-implementation sub]]
[clojure.lang.io :refer [input-stream]] [clojure.java.io :refer [input-stream]]
[clojure.string :as s] [clojure.string :as s]
[me.raynes.fs :refer [base-name split-ext]] [me.raynes.fs :refer [base-name split-ext]]
[org.clojars.smee.binary.core :as b] [org.clojars.smee.binary.core :as b]
[taoensso.timbre :refer [debug]]) [taoensso.timbre :refer [debug]])
(:import [clojure.lang Keyword])) (:import [clojure.lang Keyword]))
;; We want to use the `[vectorz](https://github.com/mikera/vectorz-clj)`
;; implementation of core.matrix.
(set-current-implementation :vectorz)
(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
have a key `:facets`, whose value must be a sequence of polygons; and have a key `:facets`, whose value must be a sequence of polygons; and
@ -26,27 +30,27 @@
(stl? o false)) (stl? o false))
([o verify-count?] ([o verify-count?]
(and (and
(map? o) (map? o)
(:facets o) (:facets o)
(every? polygon? (:facets o)) (every? triangle? (:facets o))
(if (:header o) (string? (:header o)) true) (if (:header o) (string? (:header o)) true)
(if (:count o) (integer? (:count o)) true) (if (:count o) (integer? (:count o)) true)
(or (nil? (:kind o)) (= (:kind o) :stl)) (or (nil? (:kind o)) (= (:kind o) :stl))
(if verify-count? (= (:count o) (count (:facets o))) true)))) (if verify-count? (= (:count o) (count (:facets o))) true))))
(def vect (def vect
"A codec for vectors within a binary STL file." "A codec for vectors within a binary STL file."
(b/ordered-map (b/ordered-map
:x :float-le :x :float-le
:y :float-le :y :float-le
:z :float-le)) :z :float-le))
(def facet (def facet
"A codec for a facet (triangle) within a binary STL file." "A codec for a facet (triangle) within a binary STL file."
(b/ordered-map (b/ordered-map
:normal vect :normal vect
:vertices [vect vect vect] :vertices [vect vect vect]
:abc :ushort-le)) :abc :ushort-le))
(def binary-stl (def binary-stl
"A codec for binary STL files" "A codec for binary STL files"
@ -55,6 +59,50 @@
:count :uint-le :count :uint-le
:facets (b/repeated facet))) :facets (b/repeated facet)))
(defn vertex->array
[v]
[(:x v) (:y v) (or (:z v) 0)])
(defn surface-normal
"From https://www.khronos.org/opengl/wiki/Calculating_a_Surface_Normal
```
Begin Function CalculateSurfaceNormal (Input Triangle) Returns Vector
Set Vector U to (Triangle.p2 minus Triangle.p1)
Set Vector V to (Triangle.p3 minus Triangle.p1)
Set Normal.x to (multiply U.y by V.z) minus (multiply U.z by V.y)
Set Normal.y to (multiply U.z by V.x) minus (multiply U.x by V.z)
Set Normal.z to (multiply U.x by V.y) minus (multiply U.y by V.x)
Returning Normal
End Function
```"
[triangle]
(if (triangle? triangle)
(let
[vertices (:vertices triangle)
v1 (vertex->array (nth vertices 0))
u (sub (vertex->array (nth vertices 1)) v1)
v (sub (vertex->array (nth vertices 2)) v1)
x (- (* (nth u 1)(nth v 2)) (* (nth u 2) (nth v 1)))
y (- (* (nth u 2) (nth v 0)) (* (nth u 0) (nth v 2)))
z (- (* (nth u 0) (nth v 1)) (* (nth u 1 (nth v 0))))]
(debug (format "Calculating normal for triangle %s" triangle))
(vertex x y z))
(throw (IllegalArgumentException.
(format "Expected :triangle, found %s" (kind-type triangle))))))
(defn ensure-normal
"Ensure this `triangle` has a normal vector/"
[triangle]
(if (triangle? triangle)
(if (:normal triangle) triangle
(assoc triangle :normal (surface-normal triangle)))
(throw (IllegalArgumentException.
(format "Expected :triangle, found %s" (kind-type triangle))))))
(defn canonicalise (defn canonicalise
"Objects read in from STL won't have all the keys/values we need them to have. "Objects read in from STL won't have all the keys/values we need them to have.
`o` may be a map (representing a facet or a vertex), or a sequence of such maps; `o` may be a map (representing a facet or a vertex), or a sequence of such maps;
@ -67,30 +115,34 @@
(canonicalise o map-kind (v/vertex 1 1 1))) (canonicalise o map-kind (v/vertex 1 1 1)))
([o ^Keyword map-kind scale-vertex] ([o ^Keyword map-kind scale-vertex]
(when-not (when-not
(keyword? map-kind) (keyword? map-kind)
(throw (IllegalArgumentException. (throw (IllegalArgumentException.
(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?`
(:facets o) (assoc o (:facets o) (assoc o
:kind :stl :kind :stl
:walkmap.id/id (or (:walkmap.id/id o) (keyword (gensym "stl"))) :walkmap.id/id (or (:walkmap.id/id o)
:facets (canonicalise (:facets o) map-kind)) (keyword (gensym "stl")))
:facets (canonicalise (:facets o) map-kind))
;; if it's a triangle it's almost a facet. All it needs now is a normal
;; vector
(triangle? o) (ensure-normal o)
;; if it has :vertices it's a polygon, but it may not yet conform to ;; if it has :vertices it's a polygon, but it may not yet conform to
;; `polygon?` ;; `polygon?`
(:vertices o) (let [f (gradient (:vertices o) (let [f (gradient
(centre (centre
(tag (tag
(assoc o (assoc o
:walkmap.id/id (or :walkmap.id/id (or
(:walkmap.id/id o) (:walkmap.id/id o)
(keyword (gensym "poly"))) (keyword (gensym "poly")))
:kind :polygon :kind :polygon
:vertices (canonicalise :vertices (canonicalise
(:vertices o) (:vertices o)
map-kind)) map-kind))
:facet map-kind)))] :facet map-kind)))]
(if (ocean? f) (if (ocean? f)
(tag f :ocean :no-traversal) (tag f :ocean :no-traversal)
f)) f))
@ -131,7 +183,7 @@
(let [in (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)
(store stl superstructure) (store stl superstructure)
stl)))) stl))))
@ -140,13 +192,13 @@
(defn- facet2str [tri] (defn- facet2str [tri]
(str (str
(vect->str "facet normal" (:normal tri)) (vect->str "facet normal" (:normal tri))
"outer loop\n" "outer loop\n"
(s/join (s/join
(map (map
#(vect->str "vertex" %) #(vect->str "vertex" %)
(:vertices tri))) (:vertices tri)))
"endloop\nendfacet\n")) "endloop\nendfacet\n"))
(defn stl->ascii (defn stl->ascii
"Return as a string an ASCII rendering of the `stl` structure." "Return as a string an ASCII rendering of the `stl` structure."
@ -154,17 +206,17 @@
(stl->ascii stl "unknown")) (stl->ascii stl "unknown"))
([stl solidname] ([stl solidname]
(str (str
"solid " "solid "
solidname solidname
(s/trim (:header stl)) (s/trim (:header stl))
"\n" "\n"
(s/join (s/join
(map (map
facet2str facet2str
(:facets stl))) (:facets stl)))
"endsolid " "endsolid "
solidname solidname
"\n"))) "\n")))
(defn write-ascii-stl (defn write-ascii-stl
"Write an `stl` structure as read by `decode-binary-stl` to this "Write an `stl` structure as read by `decode-binary-stl` to this
@ -172,13 +224,13 @@
([filename stl] ([filename stl]
(let [b (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]
(debug "Solid name is " solidname) (debug "Solid name is " solidname)
(spit (spit
filename filename
(stl->ascii stl solidname)))) (stl->ascii stl solidname))))
(defn binary-stl-to-ascii (defn binary-stl-to-ascii
"Convert the binary STL file indicated by `in-filename`, and write it to "Convert the binary STL file indicated by `in-filename`, and write it to
@ -187,15 +239,15 @@
([in-filename] ([in-filename]
(let [[_ ext] (split-ext in-filename)] (let [[_ ext] (split-ext in-filename)]
(binary-stl-to-ascii (binary-stl-to-ascii
in-filename in-filename
(str (str
(subs (subs
in-filename in-filename
0 0
(or (or
(s/last-index-of in-filename ".") (s/last-index-of in-filename ".")
(count in-filename))) (count in-filename)))
".ascii" ".ascii"
ext)))) ext))))
([in-filename out-filename] ([in-filename out-filename]
(write-ascii-stl out-filename (decode-binary-stl in-filename)))) (write-ascii-stl out-filename (decode-binary-stl in-filename))))