luv

Workshop wiki

mesh.lisp

luft/mesh.lisp

system luft · 152 definitions · on GitHub

in-package#:luft

Integer site-stream surface materialization

Geometry is a sum over lattice sites. Face records select a fixed inset square, edge records select flat collars or crease bands, and vertex records select flat corner patches or Arc junction fans. Records contain only a lattice base coordinate, a stock, local ambient accessibility, and a template index. Template vertices are exact small integer offsets from that base; vertex-owned offsets stay inside the configured bevel-width domain around the lattice site.

The mesher speaks the same packed-integer language as the chain substrate. Its working representations, and the identities they preserve:

  • Occupancy is materialized once per build into an EQL table keyed by the

packed positive cell sites of the solid; every probe is one lookup.

  • Lattice keys (edge anchors, vertex sites, boundary anchors) pack as

axis<<59 | (x+1)<<34 | (y+1)<<9 | (z+1), so numeric order is the (axis, x, y, z) lexicographic order the streams are deterministically sorted by.

  • Template vertices pack as one fixnum each: three 5-bit biased local

coordinates plus the ABI attribute bits. Templates intern by content.

  • Instances append to columnar (unsigned-byte 32) streams whose fourth

word is already the final ABI meta word (template | stock | ambient).

  • The open boundary is parity-counted over packed canonical edges

(anchor key + two 12-bit anchor-local endpoints); each surviving open edge becomes a single fixnum of site-local endpoints and stock, and the whole fan phase runs on those.

thirteen bits and are read from tables built once at load.

defconstant+mesh-cell-size+8
defconstant+mesh-bevel-width+2"Default bevel width in eighth-cell integer ticks (one quarter cell)."
defstruct
surface-mesh
:constructor%make-surface-mesh
domainbevel-widthtemplate-vertex-wordstemplate-rangesface-instance-wordsface-drawsband-instance-wordsband-drawsfan-instance-wordsfan-drawsface-triangle-countband-triangle-countfan-triangle-countsingular-star-count
:copiernil
domainnil:typeworld-domain:read-onlyt
bevel-width+mesh-bevel-width+:type
integer14
:read-onlyt
template-vertex-words
:type
simple-array
unsigned-byte32
:read-onlyt
template-ranges
:type
simple-array
unsigned-byte32
:read-onlyt
face-instance-words
:type
simple-array
unsigned-byte32
:read-onlyt
face-drawsnil:typelist:read-onlyt
band-instance-words
:type
simple-array
unsigned-byte32
:read-onlyt
band-drawsnil:typelist:read-onlyt
fan-instance-words
:type
simple-array
unsigned-byte32
:read-onlyt
fan-drawsnil:typelist:read-onlyt
face-triangle-count0:type
integer0*
:read-onlyt
band-triangle-count0:type
integer0*
:read-onlyt
fan-triangle-count0:type
integer0*
:read-onlyt
singular-star-count0:type
integer0*
:read-onlyt
defunsurface-mesh-template-count
mesh
/
length
surface-mesh-template-rangesmesh
2
defunsurface-mesh-face-instance-count
mesh
/
length
surface-mesh-face-instance-wordsmesh
+mesh-instance-word-count+
defunsurface-mesh-band-instance-count
mesh
/
length
surface-mesh-band-instance-wordsmesh
+mesh-instance-word-count+
defunsurface-mesh-fan-instance-count
mesh
/
length
surface-mesh-fan-instance-wordsmesh
+mesh-instance-word-count+
defunsurface-mesh-triangle-count
mesh
+
surface-mesh-face-triangle-countmesh
surface-mesh-band-triangle-countmesh
surface-mesh-fan-triangle-countmesh
defun%read-arc-junction-table
let
table
make-array256:initial-elementnil
pathname
asdf:system-relative-pathname"luft"#P"luft/blender-arc-stars.sexp"
with-open-file
streampathname:direction:input
let
corpus
readstreamnilnil
unlesscorpus
error"The Blender Arc corpus is empty: ~A"pathname
dolist
case
getfcorpus:cases
let
mask
getfcase:mask
setf
areftablemask
list:regular-star
getf
getfcase:input
:regular-star
:faces
getf
getfcase:junction
:faces
unless
every#'identitytable
error"The Blender Arc corpus does not contain all 256 stars."
table
defun%sample-direction-component
sampleaxis-number
if
logbitpaxis-numbersample
1-1
defun%cube-edge-key
ab
when
>ab
rotatefab
logiora
ashb3
defun%cube-edge-low
edge
ldb
byte30
edge
defun%cube-edge-high
edge
ldb
byte33
edge
defparameter*star-cube-edges*
loopforsamplebelow8append
loopforaxis-numberbelow3unless
logbitpaxis-numbersample
collect
%cube-edge-keysample
logxorsample
ash1axis-number
"The twelve edges of the cube whose vertices are the eight incident cells."
defun%boundary-edge-p
maskedge
not
eq
logbitpmask
logbitpmask
defun%star-boundary-edges
mask
remove-if-not
lambda
edge
*star-cube-edges*
defun%other-axis-numbers
axis-number
loopforcandidatebelow3unless
=candidateaxis-number
collectcandidate
defun%radial-samples
axis-numbersign
destructuring-bind
uv
let
base
if
pluspsign
ash1axis-number
0
vectorbase
logiorbase
ash1u
logiorbase
ash1u
ash1v
logiorbase
ash1v
defun%radial-transition-groups
maskaxis-numbersign

Pair link edges at one signed lattice-edge ray.

The ordinary two transitions are one pair. A checkerboard has four transitions; occupied-side topology pairs the two transitions surrounding each occupied quadrant, producing two independent surface sheets.

let*
samples
%radial-samplesaxis-numbersign
transitions
loopforindexbelow4fornext=
mod
1+index
4
unless
eq
logbitp
arefsamplesindex
mask
logbitp
arefsamplesnext
mask
collectindex
case
lengthtransitions
0nil
2
list
mapcar
lambda
index
%cube-edge-key
arefsamplesindex
arefsamples
mod
1+index
4
transitions
4
loopforindexbelow4when
logbitp
arefsamplesindex
mask
collect
list
%cube-edge-key
arefsamples
mod
+index3
4
arefsamplesindex
%cube-edge-key
arefsamplesindex
arefsamples
mod
1+index
4
t
error"Impossible radial transition count ~D."
lengthtransitions
defun%add-link-neighbors
neighborsleftright
pushright
gethashleftneighbors
pushleft
gethashrightneighbors
defun%star-sheet-cycles
mask
let
neighbors
make-hash-table:test#'eql
dolist
setf
gethashedgeneighbors
nil
dotimes
axis-number3
dolist
sign'
-11
dolist
pair
%radial-transition-groupsmaskaxis-numbersign
%add-link-neighborsneighbors
firstpair
secondpair
maphash
lambda
edgeadjacent
unless
=2
lengthadjacent
error"Resolved star ~2,'0X leaves link edge ~D with degree ~D."maskedge
lengthadjacent
neighbors
let
unseen
make-hash-table:test#'eql
cycles'
maphash
lambda
edgevalue
declare
ignorevalue
setf
gethashedgeunseen
t
neighbors
loopwhile
plusp
hash-table-countunseen
do
let*
start
loopforedgebeingthehash-keysofunseenreturnedge
previousnil
currentstart
cycle'
loop
pushcurrentcycle
remhashcurrentunseen
let*
adjacent
gethashcurrentneighbors
next
if
eql
firstadjacent
previous
secondadjacent
firstadjacent
setfpreviouscurrentcurrentnext
when
eqlcurrentstart
push
nreversecycle
cycles
sortcycles#'<:key#'first
defun%cycle-virtual-mask
original-maskcycle

Return the occupied side of one resolved link cycle as a regular star.

let*
first-edge
firstcycle
low
%cube-edge-lowfirst-edge
high
%cube-edge-highfirst-edge
start
if
logbitploworiginal-mask
lowhigh
barrier
make-hash-table:test#'eql
seen
make-hash-table:test#'eql
queue
liststart
mask0
dolist
edgecycle
setf
gethashedgebarrier
t
setf
gethashstartseen
t
loopwhilequeuedo
let
sample
popqueue
setfmask
logiormask
ash1sample
dotimes
axis-number3
let*
neighbor
logxorsample
ash1axis-number
unless
or
gethashedgebarrier
gethashneighborseen
setf
gethashneighborseen
t
pushneighborqueue
mask
defundecompose-star-mask
mask

Resolve mask into the regular occupied-side masks supported by this spike.

The returned list has one regular mask per simple boundary-link cycle. Empty and full stars have no boundary and therefore return NIL. A cycle which needs duplicated radial vertices cannot yet be represented by the Blender regular star corpus; signal that boundary explicitly instead of silently welding it.

check-typemask
integer0255
mapcar
lambda
cycle
let
virtual-mask
unless
getf
aref*arc-junction-table*virtual-mask
:regular-star
error"Sheet cycle from ~2,'0X needs a covered junction; its ordinary mask is ~2,'0X."maskvirtual-mask
virtual-mask
defun%checkerboard-ray-p
maskaxis-numbersign
defunstar-singular-p
mask

Whether mask's unsplit cubical boundary fails to be one manifold sheet.

check-typemask
integer0255
or
loopforaxis-numberbelow3thereis
loopforsignin'
-11
thereis
%checkerboard-ray-pmaskaxis-numbersign
defparameter*star-singular-bits*
let
bits
make-array256:element-type'bit
dotimes
mask256bits
setf
sbitbitsmask
"STAR-SINGULAR-P of every eight-bit star, computed once."

--------------------------------------------------------------------------- Exact list-vector helpers retained for cold construction and tests

defun%point-
leftright
mapcar#'-leftright
defun%cross
leftright
list
-
*
secondleft
thirdright
*
thirdleft
secondright
-
*
thirdleft
firstright
*
firstleft
thirdright
-
*
firstleft
secondright
*
secondleft
firstright
defun%dot
leftright
reduce#'+
mapcar#'*leftright
defun%normal-direction-code
normal

Reduce an exact polygon normal to the trit direction stored by the ABI.

unless
and
=3
lengthnormal
every#'integerpnormal
some
complement#'zerop
normal
error"Mesh normal is not a nonzero integer direction: ~S."normal
mapcar#'signumnormal
defun%pack-template-attributes
normalbarycentric-indexkindboundary-edge-mask
let
unless
<=0barycentric-index2
error"Unpackable barycentric index: ~S."barycentric-index
let
kind-code
ecasekind
:face0
:band1
:junction2
logior
+1
firstnormal
ash
+1
secondnormal
2
ash
+1
thirdnormal
4
ashbarycentric-index6
ashkind-code8
ashboundary-edge-mask10
defun%directional-star-ambient-occlusion
masknormal

Quantize occupancy in normal's outward local hemisphere to two AO bits.

check-typemask
unsigned-byte8
let
samples0
occupied0
dotimes
when
loopforcomponentinnormalforaxis-numberbelow3always
or
zeropcomponent
=
signumcomponent
if
logbitpaxis-numbersample
1-1
incfsamples
when
logbitpsamplemask
incfoccupied
floor
+
*3occupied
floorsamples2
samples
defparameter*directional-ambient-occlusion-table*
let
table
make-array
*27256
:element-type'
unsigned-byte2
dotimes
trit-key27table
let
normal
list
-
modtrit-key3
1
-
mod
floortrit-key3
3
1
-
floortrit-key9
1
dotimes
mask256
setf
areftable
+
*trit-key256
mask
"Directional AO for every (normal trit key, star mask) pair, built once."
defun%normal-trit-key
nxnynz
+
1+
*3
1+
*9
1+

--------------------------------------------------------------------------- Packed lattice keys

Unwrapped mesher coordinates: X and Y lie in [-1, 2^18], Z in [-1, 256]. The +1 bias keeps boundary anchors one step below zero packable. Numeric key order is (axis, x, y, z) lexicographic order.

defconstant+mesh-key-x-shift+34
defconstant+mesh-key-y-shift+9
defun%lattice-key
xyz
declare
optimize
speed3
safety1
type
integer-1#.
ash118
xy
type
integer-1511
z
defun%lattice-key-z
key
-
ldb
byte90
key
1

--------------------------------------------------------------------------- Materialized occupancy

A field binds one solid's occupancy to a cell-coordinate box. Probes inside an ordinary-size box are one dense bit-vector lookup; probes outside it signal outside-domain with the boundary restarts, so the caller's policy (whole-world air, a chunk store, a strict test) decides the edge.

defstruct
occupancy-field
:constructor%make-occupancy-field
domainbitstablex0x1y0y1y-span
domainnil:typeworld-domain:read-onlyt

Resident occupancy is dense unless the horizontal box would make an unreasonable allocation. The sparse fallback preserves whole-domain meshing for very large, lightly populated worlds.

bitsnil:type
ornullsimple-bit-vector
:read-onlyt
tablenil:type
ornullhash-table
:read-onlyt

Half-open cell-coordinate bounds of the resident box.

x00:typefixnum:read-onlyt
x10:typefixnum:read-onlyt
y00:typefixnum:read-onlyt
y10:typefixnum:read-onlyt
y-span1:type
integer1#.
ash118
:read-onlyt

Resolutions of probes past the box but inside the world: chunk key to :AIR, :SOLID, or a cell table, each obtained from one missing-chunk signal and cached for every later probe into that chunk.

resolutions
make-hash-table:test#'eql
:typehash-table:read-onlyt
defun%chunk-cells-table
chain

Index chain's cells by packed lattice key, validating them as positive.

let
table
make-hash-table:test#'eql:size
loopforcellacross
%chain-siteschain
do
unless
error"A solid mesh requires positive cells, not ~S."cell
table
defun%materialize-occupancy
solidx0x1y0y1

Validate solid's cells and materialize them over the given cell box.

declare
typefixnumx0x1y0y1
let*
y-span
-y1y0
volume
*
-x1x0
y-span+top-z+
dense-p
<=volume
*12810241024
bits
whendense-p
make-arrayvolume:element-type'bit:initial-element0
table
unlessdense-p
make-hash-table:test#'eql:size
loopforcellacross
%chain-sitessolid
do
unless
error"A solid mesh requires positive cells, not ~S."cell
let
unless
and
<=x0x
<xx1
<=y0y
<yy1
<=0z
error"Cell ~S lies outside its occupancy box."cell
ifbits
setf
sbitbits
+z
*+top-z+
+
-yy0
*y-span
-xx0
1
setft
%make-occupancy-fieldbitstablex0x1y0y1y-span
defun%resolve-chunk
fieldkey

Signal missing-chunk once for key and cache the handler's resolution.

let
resolution
restart-case
error'missing-chunk:domain
occupancy-field-domainfield
:keykey
use-chunk
chain
:report"Supply the chunk's chain."
treat-as-air
:report"Treat the whole chunk as air.":air
treat-as-solid
:report"Treat the whole chunk as solid.":solid
setf
gethashkey
occupancy-field-resolutionsfield
resolution
defun%field-chunk-resolution
fieldkey
or
gethashkey
occupancy-field-resolutionsfield
declaim
defun%dense-occupancy-index
fieldxyz
declare
optimize
speed3
safety1
typeoccupancy-fieldfield
typefixnumxyz
thefixnum
+z
thefixnum
*+top-z+
thefixnum
+
thefixnum
-y
occupancy-field-y0field
thefixnum
*
occupancy-field-y-spanfield
thefixnum
-x
occupancy-field-x0field
defun%occupied-bit
fielddomainxyz

Occupancy of one cell: air beyond Z, a lookup inside the field's box, one cached missing-chunk resolution per non-resident chunk inside the world, and an outside-domain signal past the world's own edges.

declare
optimize
speed3
safety1
typeoccupancy-fieldfield
typeworld-domaindomain
typefixnumxyz
cond
and
<=
occupancy-field-x0field
x
<x
occupancy-field-x1field
<=
occupancy-field-y0field
y
<y
occupancy-field-y1field
let
bits
occupancy-field-bitsfield
ifbits
sbitbits
if
gethash
occupancy-field-tablefield
10
t
let
caseresolution
:air0
:solid1
t
if
gethashresolution
10
defun%star-mask-at
fielddomainxyz

Pack the eight-cell occupancy star of the lattice vertex at X Y Z.

Bit conventions match site-star-occupancy-mask on a vertex site.

declare
optimize
speed3
safety1
typeoccupancy-fieldfield
typeworld-domaindomain
typefixnumxyz
let
mask0
dotimes
sample8mask
when
=1
%occupied-bitfielddomain
-x
if
logbitp0sample
01
-y
if
logbitp1sample
01
-z
if
logbitp2sample
01
setfmask
logiormask
ash1sample

--------------------------------------------------------------------------- Templates, instance streams, and the builder

defstruct
mesh-template
:constructor%make-mesh-template
idvertices
id0:type
integer0*
:read-onlyt

Packed vertices: (x+16) | (y+16)<<5 | (z+16)<<10 | attributes<<15.

vertices
make-array0:element-type'fixnum
:type
simple-arrayfixnum
:read-onlyt
defstruct
instance-stream
:constructor%make-instance-stream

Four ABI words per instance in emission order: base x, y, z, meta.

words
make-array4096:element-type'
unsigned-byte32
:adjustablet:fill-pointer0
:type
vector
unsigned-byte32
defuninstance-stream-count
stream
/
fill-pointer
instance-stream-wordsstream
+mesh-instance-word-count+
defstruct
surface-mesh-builder
:constructor%make-surface-mesh-builder
domainbevel-width
domainnil:typeworld-domain:read-onlyt
bevel-width+mesh-bevel-width+:type
integer14
:read-onlyt
templates
make-array64:adjustablet:fill-pointer0
:type
vectort
:read-onlyt

Content hash of the packed vertices to a bucket of template candidates.

template-index
make-hash-table:test#'eql
:typehash-table:read-onlyt
vertex-scratch
make-array6:element-type'fixnum
:type
simple-arrayfixnum
6
:read-onlyt
face-stream
%make-instance-stream
:typeinstance-stream:read-onlyt
band-stream
%make-instance-stream
:typeinstance-stream:read-onlyt
fan-stream
%make-instance-stream
:typeinstance-stream:read-onlyt

When configured for bevel construction, face and band emission update this shared parity table directly from the already-oriented scratch vertices. Builders without it retain the general replay path used by mesh transformations elsewhere in this file.

boundary-packingnil
boundary-observationsnil
singular-star-count0:type
integer0*
defun%intern-template
builderscratchcount
declare
optimize
speed3
safety1
type
simple-arrayfixnum
scratch
type
integer06
count
let
hashcount
declare
typefixnumhash
dotimes
icount
setfhash
logand
+
*
logandhash#xffffffffffff
67
arefscratchi
most-positive-fixnum
let
index
surface-mesh-builder-template-indexbuilder
dolist
template
gethashhashindex
let
vertices
mesh-template-verticestemplate
when
and
=
lengthvertices
count
loopforibelowcountalways
=
arefverticesi
arefscratchi
return-from%intern-templatetemplate
let*
templates
surface-mesh-builder-templatesbuilder
vertices
make-arraycount:element-type'fixnum
template
%make-mesh-template
fill-pointertemplates
vertices
replaceverticesscratch:end2count
vector-push-extendtemplatetemplates
pushtemplate
gethashhashindex
template
defun%builder-stream
builderkind
ecasekind
:face
surface-mesh-builder-face-streambuilder
:band
surface-mesh-builder-band-streambuilder
:junction
surface-mesh-builder-fan-streambuilder
defun%emit-instance
builderkindbase-xbase-ybase-zstockambient-occlusioncount

Intern the vertex scratch prefix and append one columnar instance.

check-typestock
check-typeambient-occlusion
unsigned-byte2
unless
and
typepbase-x'
unsigned-byte32
typepbase-y'
unsigned-byte32
typepbase-z'
unsigned-byte32
error"Instance base coordinate is unsigned: ~S."
listbase-xbase-ybase-z
when
and
memberkind'
:face:band
surface-mesh-builder-boundary-observationsbuilder
%observe-scratch-boundary-edgesbuilderbase-xbase-ybase-zstockcount
let*
template
%intern-templatebuilder
surface-mesh-builder-vertex-scratchbuilder
count
words
instance-stream-words
%builder-streambuilderkind
vector-push-extendbase-xwords
vector-push-extendbase-ywords
vector-push-extendbase-zwords
vector-push-extendwords
template

--------------------------------------------------------------------------- Scalar triangle assembly

defun%scratch-triangle
scratchoffsetkind-codeboundary-edge-maskaxayazbxbybzcxcycznxnynz

Write one oriented triangle of template-local vertices; return next offset.

declare
optimize
speed3
safety1
type
simple-arrayfixnum
scratch
typefixnumoffsetaxayazbxbybzcxcycznxnynz
let*
ux
-bxax
uy
-byay
uz
-bzaz
vx
-cxax
vy
-cyay
vz
-czaz
px
-
*uyvz
*uzvy
py
-
*uzvx
*uxvz
pz
-
*uxvy
*uyvx
orientation
+
*pxnx
*pyny
*pznz
when
zeroporientation
error"Degenerate ~[face~;band~;junction~] triangle ~S ~S ~S."kind-code
listaxayaz
listbxbybz
listcxcycz
when
minusporientation
rotatefbxcx
rotatefbycy
rotatefbzcz
let
attributes
logior
1+
ash
1+
2
ash
1+
4
ashkind-code8
ashboundary-edge-mask10
setf
arefscratchoffset
%pack-template-vertexaxayazattributes
arefscratch
+offset1
%pack-template-vertexbxbybz
logiorattributes
ash16
arefscratch
+offset2
%pack-template-vertexcxcycz
logiorattributes
ash26
+offset3
defun%emit-quad
builderkindbase-xbase-ybase-zp0p1p2p3nxnynzstockambient-occlusion

Emit one instance for the quad p0 p1 p2 p3 (global ticks, simple-vectors).

let
scratch
surface-mesh-builder-vertex-scratchbuilder
kind-code
ecasekind
:face0
:band1
let
offset
%scratch-trianglescratch0kind-code#b101
-
svrefp00
ox
-
svrefp01
oy
-
svrefp02
oz
-
svrefp10
ox
-
svrefp11
oy
-
svrefp12
oz
-
svrefp20
ox
-
svrefp21
oy
-
svrefp22
oz
nxnynz
%scratch-trianglescratchoffsetkind-code#b011
-
svrefp00
ox
-
svrefp01
oy
-
svrefp02
oz
-
svrefp20
ox
-
svrefp21
oy
-
svrefp22
oz
-
svrefp30
ox
-
svrefp31
oy
-
svrefp32
oz
nxnynz
%emit-instancebuilderkindbase-xbase-ybase-zstockambient-occlusion6
defun%emit-fan-triangle
builderbase-xbase-ybase-zboundary-edge-maskaxayazbxbybzcxcycznxnynzstockstar-mask

Emit one junction triangle whose coordinates are already site-local.

let
scratch
surface-mesh-builder-vertex-scratchbuilder
%scratch-trianglescratch02boundary-edge-maskaxayazbxbybzcxcycznxnynz
%emit-instancebuilder:junctionbase-xbase-ybase-zstock3

--------------------------------------------------------------------------- Cell faces

Tangent axis numbers (u v) for each normal axis number.

defconstant+axis-u+
if
boundp'+axis-u+
symbol-value'+axis-u+
100
defconstant+axis-v+
if
boundp'+axis-v+
symbol-value'+axis-v+
221
defun%emit-cell-face
builderfielddomaincellaxis-numbersidestock-functionchamfer-stock-function
declare
optimize
speed3
safety1
let*
bevel-width
surface-mesh-builder-bevel-widthbuilder
u
svref+axis-u+axis-number
v
svref+axis-v+axis-number
face
stock
funcallstock-functionface

The central square remains face-owned. Its four collars are the planar part of the chamfer, so they must take the same one-stock policy as bevel bands and vertex closures.

chamfer-stock
funcallchamfer-stock-function
liststock
nx
if
=axis-number0
side0
ny
if
=axis-number1
side0
nz
if
=axis-number2
side0
coords
make-array3
u-cuts
make-array4
v-cuts
make-array4
p0
make-array3
p1
make-array3
p2
make-array3
p3
make-array3
declare
dynamic-extentcoordsu-cutsv-cutsp0p1p2p3
setf
svrefcoords0
cx
svrefcoords1
cy
svrefcoords2
cz
labels
crease-p
tangent-axistangent-side

A crease insets the face edge unless the coplanar tangent neighbor continues the surface flat.

let
xcx
ycy
zcz
casetangent-axis
0
incfxtangent-side
1
incfytangent-side
t
incfztangent-side
let
neighbor
%occupied-bitfielddomainxyz
caseaxis-number
0
incfxside
1
incfyside
t
incfzside
not
and
=1neighbor
=0
%occupied-bitfielddomainxyz
let*
plane
*+mesh-cell-size+
+
svrefcoordsaxis-number
if
pluspside
10
u-anchor
*+mesh-cell-size+
svrefcoordsu
v-anchor
*+mesh-cell-size+
svrefcoordsv
setf
svrefu-cuts0
+u-anchor
if
crease-pu-1
bevel-width0
svrefu-cuts1
+u-anchorbevel-width
svrefu-cuts2
-bevel-width
svrefu-cuts3
-
if
crease-pu1
bevel-width0
svrefv-cuts0
+v-anchor
if
crease-pv-1
bevel-width0
svrefv-cuts1
+v-anchorbevel-width
svrefv-cuts2
-bevel-width
svrefv-cuts3
-
if
crease-pv1
bevel-width0
flet
set-point
pointuuvv
setf
svrefpointaxis-number
plane
svrefpointu
uu
svrefpointv
vv

Uniformly partition the exact old face rectangle. Its 6x6 heart is face-owned and its nonempty side cells are edge-owned. Leave the four corner cells open: the lattice-site fan closes their actual boundary after every face and edge instance is present.

dotimes
u-cell3
dotimes
v-cell3
let
u0
svrefu-cutsu-cell
u1
svrefu-cuts
1+u-cell
v0
svrefv-cutsv-cell
v1
svrefv-cuts
1+v-cell
when
and
<u0u1
<v0v1
or
=u-cell1
=v-cell1
let
kind
if
and
=u-cell1
=v-cell1
:face:band
base-xcx
base-ycy
base-zcz
macrolet
bump
axis-formamount
`
let
axis,axis-form
caseaxis
0
incfbase-x,amount
1
incfbase-y,amount
t
incfbase-z,amount
bumpaxis-number
if
pluspside
10
bumpu
if
=u-cell2
10
bumpv
if
=v-cell2
10
set-pointp0u0v0
set-pointp1u1v0
set-pointp2u1v1
set-pointp3u0v1
%emit-quadbuilderkindbase-xbase-ybase-zp0p1p2p3nxnynz
if
eqkind:face
stockchamfer-stock
0

--------------------------------------------------------------------------- Edge bands

Quadrant (u v) components around a lattice edge, in cyclic order.

defconstant+quadrant-u+
if
symbol-value'+quadrant-u+
-111-1
defconstant+quadrant-v+
if
symbol-value'+quadrant-v+
-1-111
defun%edge-run-transition-groups
states

Group the transition indices of one four-bit quadrant occupancy run.

let
transitions
loopforindexbelow4unless
eq
logbitpindexstates
logbitp
mod
1+index
4
states
collectindex
case
lengthtransitions
0nil
2
listtransitions
4
loopforindexbelow4when
logbitpindexstates
collect
list
mod
+index3
4
index
t
error"Impossible edge transition count ~D."
lengthtransitions
defparameter*edge-transition-group-table*
let
table
make-array16
dotimes
states16table
"Transition groups for every quadrant occupancy pattern, built once."
defun%make-edge-candidates
cell-count

An emission-order buffer of packed lattice edges discovered at faces.

make-array
max64cell-count
:element-type'
unsigned-byte64
:adjustablet:fill-pointer0
defun%append-face-edge-keys
candidatescell-xcell-ycell-zaxis-numberside

Append the four lattice edges of one exposed cell face.

declare
optimize
speed3
safety1
type
vector
unsigned-byte64
candidates
typefixnumcell-xcell-ycell-zaxis-numberside
let
xcell-x
ycell-y
zcell-z
u
svref+axis-u+axis-number
v
svref+axis-v+axis-number
macrolet
bump
axisamount
`
case,axis
0
incfx,amount
1
incfy,amount
t
incfz,amount
edge
edge-axis
`
vector-push-extend
logior
candidates
when
pluspside
bumpaxis-number1
edgeu
bumpv1
edgeu
bumpv-1
edgev
bumpu1
edgev
candidates
defun%unique-edge-candidates
candidates

Sort and compact candidates into an exact simple packed edge vector.

declare
optimize
speed3
safety1
type
vector
unsigned-byte64
candidates
sortcandidates#'<
let*
count
fill-pointercandidates
unique-count
if
zeropcount
0
let
write1
previous
arefcandidates0
loopforreadfrom1belowcountforkey=
arefcandidatesread
unless
=keyprevious
do
setf
arefcandidateswrite
key
previouskey
incfwrite
write
result
make-arrayunique-count:element-type'
unsigned-byte64
replaceresultcandidates:end2unique-count
result
defun%chain-cell-keys
chain

The packed lattice keys of chain's cells, in chain order.

let*
sites
%chain-siteschain
keys
make-array
lengthsites
:element-type'
unsigned-byte64
loopforcellacrosssitesforindexfrom0do
keys
defun%emit-edge-bands
builderfielddomainkeystock-functionchamfer-stock-function
declare
optimize
speed3
safety1
let*
bevel-width
surface-mesh-builder-bevel-widthbuilder
axis-number
u
svref+axis-u+axis-number
v
svref+axis-v+axis-number
states0
flet
quadrant-cell-x
index
let
xax
when
and
=u0
minusp
svref+quadrant-u+index
decfx
when
and
=v0
minusp
svref+quadrant-v+index
decfx
x
quadrant-cell-y
index
let
yay
when
and
=u1
minusp
svref+quadrant-u+index
decfy
when
and
=v1
minusp
svref+quadrant-v+index
decfy
y
quadrant-cell-z
index
let
zaz
when
and
=u2
minusp
svref+quadrant-u+index
decfz
when
and
=v2
minusp
svref+quadrant-v+index
decfz
z
dotimes
index4
when
=1
%occupied-bitfielddomain
quadrant-cell-xindex
quadrant-cell-yindex
quadrant-cell-zindex
setfstates
logiorstates
ash1index
flet
transition
transition-index

Resolve one occupancy transition into its face normal axis and sign, the occupied side's cross-axis offset sign, and the oriented boundary face carrying the stock.

let*
next-index
mod
1+transition-index
4
occupied-index
if
logbitptransition-indexstates
transition-indexnext-index
empty-index
if
=occupied-indextransition-index
next-indextransition-index
qu-occupied
svref+quadrant-u+occupied-index
qv-occupied
svref+quadrant-v+occupied-index
qu-empty
svref+quadrant-u+empty-index
qv-empty
svref+quadrant-v+empty-index
normal-axis
if
/=qu-occupiedqu-empty
uv
other-axis
if
=normal-axisu
vu
normal-sign
if
=normal-axisu
qu-emptyqv-empty
other-sign
if
=other-axisu
qu-occupiedqv-occupied
cell
make-sitedomain
quadrant-cell-xoccupied-index
quadrant-cell-yoccupied-index
quadrant-cell-zoccupied-index
+cell-extent+1
face
if
minuspnormal-sign
valuesnormal-axisnormal-signother-axisother-signface
dolist
multiple-value-bind
left-axisleft-signleft-otherleft-other-signleft-face
transition
firstgroup
multiple-value-bind
right-axisright-signright-otherright-other-signright-face
transition
secondgroup

Equal normals are one flat face continued across a cell boundary; opposite normals are two sheets touching at the lattice edge. Neither relation owns a bevel band.

unless
=left-axisright-axis
let
nx0
ny0
nz0
left-rail
make-array3
right-rail
make-array3
p0
make-array3
p1
make-array3
p2
make-array3
p3
make-array3
declare
dynamic-extentleft-railright-railp0p1p2p3
macrolet
add-normal
axis-formsign-form
`
let
axis,axis-form
caseaxis
0
incfnx,sign-form
1
incfny,sign-form
t
incfnz,sign-form
add-normalleft-axisleft-sign
add-normalright-axisright-sign
setf
svrefleft-rail0
svrefleft-rail1
svrefleft-rail2
replaceright-railleft-rail
incf
svrefleft-railleft-other
*bevel-widthleft-other-sign
incf
svrefright-railright-other
*bevel-widthright-other-sign
let*
axis-low
*+mesh-cell-size+
ecaseaxis-number
0ax
1ay
2az
low
+axis-lowbevel-width
high
-bevel-width
stock
funcallchamfer-stock-function
list
funcallstock-functionleft-face
funcallstock-functionright-face
flet
rail-point
pointrailcoordinate
replacepointrail
setf
svrefpointaxis-number
coordinate

The edge owns the middle after both vertex-site domains are removed. Those width-sized ends belong to the two fans.

rail-pointp0left-raillow
rail-pointp1right-raillow
rail-pointp2right-railhigh
rail-pointp3left-railhigh
%emit-quadbuilder:bandaxayazp0p1p2p3nxnynzstockambient-occlusion

--------------------------------------------------------------------------- Singular vertex stars

defun%count-singular-vertex-stars
builderfielddomaincellsox0ox1oy0oy1

Count singular stars at the owned lattice vertices incident to cells.

Ownership is the half-open box [ox0, ox1) x [oy0, oy1) of site coordinates.

declare
optimize
speed3
safety1
type
simple-array
unsigned-byte64
cells
let
seen
make-hash-table:test#'eql:size
*4
max8
lengthcells
count0
loopforcell-keyacrosscellsdo
let
cx
cy
cz
dotimes
setf
gethash
%lattice-key
+cx
if
logbitp0sample
10
+cy
if
logbitp1sample
10
+cz
if
logbitp2sample
10
seen
t
loopforkeybeingthehash-keysofseendo
let
when
and
<=ox0x
<xox1
<=oy0y
<yoy1
incfcount
incf
surface-mesh-builder-singular-star-countbuilder
count

--------------------------------------------------------------------------- Open-boundary parity scan

Every face and band triangle edge is counted against a canonical key: the per-axis floor-of-eighths anchor of its two endpoints, plus both endpoints as 12-bit anchor-local coordinates. Edges observed once are the open boundary; each is then attributed to the lattice vertex whose bevel domain contains it and packed as one fixnum of biased site-local endpoints: left12<<24 | right12<<12 | stock12, where a point12 is (x+4)<<8|(y+4)<<4|(z+4).

The key itself is one fixnum, because a boundary packing states the horizontal anchor box the scan covers -- one chunk plus its halo, or a whole solid's own extent -- and stores anchors relative to that box's origin: ((x * y-span + y) * 257 + (z + 1)) << 24 | undirected edge. A solid too wide for that product to stay a fixnum has to be meshed by chunks; mesh-chunk's boxes are always small enough.

defconstant+fan-local-bias+4
defun%fan-record-undirected
record
let
if
<leftright
logior
ashleft12
right
logior
ashright12
left
defconstant+boundary-z-span+257"Anchor Z values run from -1 through 255 inclusive."
defstruct
boundary-packing
:constructor%make-boundary-packing
origin-xorigin-yy-span

The anchor box one parity scan covers, and thus its fixnum key layout.

origin-x0:typefixnum:read-onlyt
origin-y0:typefixnum:read-onlyt
y-span1:type
integer1*
:read-onlyt
defun%make-boundary-packing-for-box
x0x1y0y1

Pack anchors of the cell box [x0, x1) x [y0, y1).

Instance bases lie inside the box and template offsets reach at most one eighth-cell anchor beyond it, so the packed anchor box is widened by two.

let*
origin-x
-x02
origin-y
-y02
x-span
+
-x1x0
4
y-span
+
-y1y0
4
unless
typep
ash
*x-spany-span+boundary-z-span+
24
'fixnum
error

A solid spanning ~Dx~D cells is too wide for one boundary ~ scan; mesh it by chunks.

x-spany-span
%make-boundary-packingorigin-xorigin-yy-span
defun%boundary-edge-key
packinganchor-xanchor-yanchor-zedge
logior
ash
+
*
+
*
-anchor-x
boundary-packing-origin-xpacking
boundary-packing-y-spanpacking
-anchor-y
boundary-packing-origin-ypacking
+boundary-z-span+
1+anchor-z
24
edge
defun%boundary-key-anchor-x
packingkey
+
boundary-packing-origin-xpacking
truncate
ashkey-24
*
boundary-packing-y-spanpacking
+boundary-z-span+
defun%boundary-key-anchor-y
packingkey
+
boundary-packing-origin-ypacking
mod
truncate
ashkey-24
+boundary-z-span+
boundary-packing-y-spanpacking
defun%stream-triangle-count
streamtemplates
declare
optimize
speed3
safety1
let
words
instance-stream-wordsstream
count0
loopforoffsetfrom3below
fill-pointerwords
by+mesh-instance-word-count+do
incfcount
truncate
length
mesh-template-vertices
areftemplates
ldb
byte160
arefwordsoffset
3
count
defun%builder-open-boundary-table
builderspacking

Parity-count the builders' face and band streams' directed triangle edges.

Returns a table from packing's fixnum edge keys to count<<36 | left12<<24 | right12<<12 | stock12, where the 12-bit points are anchor-local.

declare
optimize
speed3
safety1
let
observations
surface-mesh-builder-boundary-observations
firstbuilders
whenobservations
unless
every
lambda
builder
and
eqobservations
surface-mesh-builder-boundary-observationsbuilder
eqpacking
surface-mesh-builder-boundary-packingbuilder
builders
error"Sheet builders do not share one boundary observation table."
return-from%builder-open-boundary-tableobservations
let*
triangles
loopforbuilderinbuildersfortemplates=
surface-mesh-builder-templatesbuilder
sum
%stream-triangle-count
surface-mesh-builder-face-streambuilder
templates
sum
%stream-triangle-count
surface-mesh-builder-band-streambuilder
templates

Each triangle contributes three directed edges, and an interior edge is observed twice, so the table holds about 3/2 keys per triangle. Sizing it now spares a long chain of rehashes.

observations
make-hash-table:test#'eql:size
max4096
ceiling
*3triangles
2
dolist
builderbuildersobservations
let
templates
surface-mesh-builder-templatesbuilder
%scan-stream-boundary-edges
surface-mesh-builder-face-streambuilder
templatespackingobservations
%scan-stream-boundary-edges
surface-mesh-builder-band-streambuilder
templatespackingobservations
defun%enable-boundary-observations
builderspackingestimated-cells

Make builders update one boundary parity table during sheet emission.

let
observations
make-hash-table:test#'eql:size
max4096
*4estimated-cells
dolist
builderbuildersobservations
setf
surface-mesh-builder-boundary-packingbuilder
packing
surface-mesh-builder-boundary-observationsbuilder
observations
defun%observe-scratch-boundary-edges
builderbase-xbase-ybase-zstockcount

Parity-count oriented SCRATCH triangles before template interning.

declare
optimize
speed3
safety1
typefixnumbase-xbase-ybase-zcount
let
packing
surface-mesh-builder-boundary-packingbuilder
observations
surface-mesh-builder-boundary-observationsbuilder
vertices
surface-mesh-builder-vertex-scratchbuilder
flet
loopfortrianglefrom0belowcountby3do
dotimes
index3
let*
left
+triangleindex
right
+triangle
mod
1+index
3
lx
global-xleft
ly
global-yleft
lz
global-zleft
rx
global-xright
ry
global-yright
rz
global-zright
anchor-x
ash
minlxrx
-3
anchor-y
ash
minlyry
-3
anchor-z
ash
minlzrz
-3
left12
logior
ash
-lx
*8anchor-x
8
ash
-ly
*8anchor-y
4
-lz
*8anchor-z
right12
logior
ash
-rx
*8anchor-x
8
ash
-ry
*8anchor-y
4
-rz
*8anchor-z
key
%boundary-edge-keypackinganchor-xanchor-yanchor-z
if
<left12right12
logior
ashleft1212
right12
logior
ashright1212
left12
existing
gethashkeyobservations
ifexisting
let
when
>next-count2
error"Face and edge streams meet ~D times at ~S."next-countkey
setf
gethashkeyobservations
dpbnext-countexisting
setf
gethashkeyobservations
defun%scan-stream-boundary-edges
streamtemplatespackingobservations
declare
optimize
speed3
safety1
let
words
instance-stream-wordsstream
loopforoffsetfrom0below
fill-pointerwords
by+mesh-instance-word-count+do
let*
base-x
arefwordsoffset
base-y
arefwords
+offset1
base-z
arefwords
+offset2
meta
arefwords
+offset3
template
areftemplates
ldb
byte160
meta
vertices
mesh-template-verticestemplate
flet
loopfortrianglefrom0below
lengthvertices
by3do
dotimes
index3
let*
left
+triangleindex
right
+triangle
mod
1+index
3
lx
global-xleft
ly
global-yleft
lz
global-zleft
rx
global-xright
ry
global-yright
rz
global-zright
anchor-x
ash
minlxrx
-3
anchor-y
ash
minlyry
-3
anchor-z
ash
minlzrz
-3
left12
logior
ash
-lx
*8anchor-x
8
ash
-ly
*8anchor-y
4
-lz
*8anchor-z
right12
logior
ash
-rx
*8anchor-x
8
ash
-ry
*8anchor-y
4
-rz
*8anchor-z
key
%boundary-edge-keypackinganchor-xanchor-yanchor-z
if
<left12right12
logior
ashleft1212
right12
logior
ashright1212
left12
existing
gethashkeyobservations
cond
nullexisting
setf
gethashkeyobservations
t
let
when
>count2
error"Face and edge streams meet ~D times at ~S."countkey
setf
gethashkeyobservations
defun%attribute-open-edges-to-sites
builderspackingbevel-widthdrop-nonlocal-p

Group the open boundary's directed edges by owning lattice vertex.

Returns a table from packed site keys to packed vectors of fan records whose 12-bit points are site-local with the fan bias. An open edge not contained in any vertex's bevel domain is an invariant violation for a whole solid; for a chunk's witness scan it is the witness truncation boundary, provably outside every owned site's bevel domain, and drop-nonlocal-p discards it.

declare
optimize
speed3
safety1
let
observations
by-site
make-hash-table:test#'eql:size1024
maphash
lambda
keyvalue
when
blockattribute
let*
anchor-x
anchor-y
right12
lx
+
*8anchor-x
ldb
byte48
left12
ly
+
*8anchor-y
ldb
byte44
left12
lz
+
*8anchor-z
ldb
byte40
left12
rx
+
*8anchor-x
ldb
byte48
right12
ry
+
*8anchor-y
ldb
byte44
right12
rz
+
*8anchor-z
ldb
byte40
right12
flet
site-coordinate
lr

Find the lattice vertex whose bevel domain contains the edge, exactly as the exact-rational original did.

let
coordinate
unless
and
<=bevel-width
<=bevel-width
whendrop-nonlocal-p
return-fromattribute
error"Open edge ~S--~S is not local to a lattice vertex."
listlxlylz
listrxryrz
coordinate
let*
site-x
site-coordinatelxrx
site-y
site-coordinatelyry
site-z
site-coordinatelzrz
let*
records
or
gethashkeyby-site
setf
gethashkeyby-site
make-array8:element-type'
unsigned-byte64
:adjustablet:fill-pointer0
vector-push-extendrecordrecords
observations
by-site
defun%fan-record-cycles

Order consistently directed fan records into loops at the site.

let
used
make-array
lengthrecords
:element-type'bit:initial-element0
cyclesnil
dotimes
start
lengthrecords
when
zerop
sbitusedstart
let*
first-record
arefrecordsstart
first-point
%fan-record-leftfirst-record
next-point
%fan-record-rightfirst-record
cycle
listfirst-record
setf
sbitusedstart
1
loopuntil
=next-pointfirst-point
do
let
next-indexnil
dotimes
index
lengthrecords
when
and
zerop
sbitusedindex
=next-point
%fan-record-left
arefrecordsindex
setfnext-indexindex
unlessnext-index
error"Open boundary at lattice site ~S stops at ~S."
list
%fan-point-xnext-point
%fan-point-ynext-point
%fan-point-znext-point
let
next-record
arefrecordsnext-index
setf
sbitusednext-index
1
cycle
consnext-recordcycle
next-point
push
nreversecycle
cycles
nreversecycles
defun%rescale-fan-record
recordsite-xsite-ysite-zsource-widthtarget-width

Evaluate record's site-local affine bevel coordinates at target-width.

flet
rescale
coordinateglobal
let
numerator
*coordinatetarget-width
unless
zerop
remnumeratorsource-width
error"Boundary coordinate ~S at site ~S has no integer ~D/~D limit."globaltarget-widthsource-width
truncatenumeratorsource-width
let
flet
rescale-point
point
let
let
global
%fan-point
rescalexglobal
rescaleyglobal
rescalezglobal
logior
ash
rescale-pointleft
+fan-record-left-shift+
ash
rescale-pointright
+fan-record-right-shift+
defun%cycle-planar-through-site-p
cycle

Whether every left endpoint of cycle is coplanar with the site origin.

let*
count
lengthcycle
xs
make-arraycount
ys
make-arraycount
zs
make-arraycount
declare
dynamic-extentxsyszs
loopforrecordincycleforindexfrom0forpoint=do
setf
svrefxsindex
svrefysindex
svrefzsindex
let
nx0
ny0
nz0
loopnamedsearchforifrom0belowcountdo
loopforjfrom
1+i
belowcountdo
let
cx
-
*
svrefysi
svrefzsj
*
svrefzsi
svrefysj
cy
-
*
svrefzsi
svrefxsj
*
svrefxsi
svrefzsj
cz
-
*
svrefxsi
svrefysj
*
svrefysi
svrefxsj
unless
and
zeropcx
zeropcy
zeropcz
setfnxcxnycynzcz
return-fromsearch
and
not
and
zeropnx
zeropny
zeropnz
loopforindexbelowcountalways
zerop
+
*nx
svrefxsindex
*ny
svrefysindex
*nz
svrefzsindex
defun%vertex-fan-uses-center-p
cyclestar-mask
or

The ordinary five-cell concave corner and its upside-down three-cell complement both pass through the site. The six- and seven-cell chamfer/fillet runs do not; coning those creates the ornaments.

member
logcountstar-mask
'
35
defun%emit-triangular-boundary-cap
buildersite-xsite-ysite-zcyclestockstar-mask
let*
a
c
ux
-cxax
uy
-cyay
uz
-czaz
vx
-bxax
vy
-byay
vz
-bzaz
nx
-
*uyvz
*uzvy
ny
-
*uzvx
*uxvz
nz
-
*uxvy
*uyvx

The observed loop follows the existing surface winding. Reverse its order so the cap pairs every boundary edge with opposite winding.

%emit-fan-trianglebuildersite-xsite-ysite-z#b111axayazcxcyczbxbybznxnynzstockstar-mask
defun%emit-boundary-strip
buildersite-xsite-ysite-zcyclestockstar-mask

Triangulate cycle without introducing its lattice-site origin as geometry.

let
points
mapcar#'%fan-record-leftcycle
boundary-stocks
make-hash-table:test#'eql
dolist
recordcycle
setf
gethashboundary-stocks
labels
undirected
ab
if
<ab
logior
asha12
b
logior
ashb12
a
strip-triangle
abc
let*
ux
-bxax
uy
-byay
uz
-bzaz
vx
-cxax
vy
-cyay
vz
-czaz
nx
-
*uyvz
*uzvy
ny
-
*uzvx
*uxvz
nz
-
*uxvy
*uyvx
mask
logior
if
gethash
undirectedbc
boundary-stocks
#b0010
if
gethash
undirectedca
boundary-stocks
#b0100
if
gethash
undirectedab
boundary-stocks
#b1000
%emit-fan-trianglebuildersite-xsite-ysite-zmaskaxayazbxbybzcxcycznxnynzstockstar-mask

Repeatedly remove the end whose replacement diagonal is shorter. The remaining vertices stay a contiguous interval of the boundary, giving a deterministic local triangle strip rather than a long fan of spokes.

loopwhile
>
lengthpoints
3
do
let*
first
firstpoints
last
car
lastpoints
penultimate
car
lastpoints2
if
<=
squared-distancesecondlast
squared-distancefirstpenultimate
progn
strip-trianglefirstlastsecond
setfpoints
restpoints
progn
strip-trianglefirstlastpenultimate
setfpoints
butlastpoints
destructuring-bind
abc
points
strip-triangleacb
defun%emit-centered-boundary-fan
buildersite-xsite-ysite-zcyclestockstar-mask
dolist
recordcycle
let

A boundary edge incident on the center is already a radial edge of this fan. Its neighboring non-radial segment emits the triangle.

unless
let*
nx
-
*rylz
*rzly
ny
-
*rzlx
*rxlz
nz
-
*rxly
*rylx
when
and
zeropnx
zeropny
zeropnz
error"Open edge ~S--~S is radial to lattice site ~S."
listlxlylz
listrxryrz

Bit zero denotes the outer RIGHT--LEFT edge. The other two edges are triangulation diagonals inside the complete fan. Keep each sector as its own instance because the construction mask varies around the junction, even though stock is uniform for this whole chamfer.

%emit-fan-trianglebuildersite-xsite-ysite-z#b001000rxryrzlxlylznxnynzstockstar-mask
defun%emit-boundary-derived-fans
builderfielddomainchamfer-stock-functionsheet-builderspackingox0ox1oy0oy1drop-nonlocal-p

Close the sheet-builders' open loops with site-local templates in builder.

Only lattice sites inside the half-open [ox0, ox1) x [oy0, oy1) box get fans; a chunk's neighbor owns the rest and closes them from its own witness scan.

let*
source-width
surface-mesh-builder-bevel-width
firstsheet-builders
target-width
surface-mesh-builder-bevel-widthbuilder
by-site
%attribute-open-edges-to-sitessheet-builderspackingsource-widthdrop-nonlocal-p
site-keys
make-array
hash-table-countby-site
:element-type'
unsigned-byte64
write0
loopforkeybeingthehash-keysofby-sitedo
setf
arefsite-keyswrite
key
incfwrite
sortsite-keys#'<
loopforkeyacrosssite-keyswhen
let
and
<=ox0x
<xox1
<=oy0y
<yoy1
do
let*
dolist
let*
cycle
if
=source-widthtarget-width
cycle
mapcar
lambda
record
%rescale-fan-recordrecordsite-xsite-ysite-zsource-widthtarget-width
cycle
stock
funcallchamfer-stock-function
mapcar#'%fan-record-stockcycle

--------------------------------------------------------------------------- Finishing

defun%template-words
builder
let*
templates
surface-mesh-builder-templatesbuilder
template-count
fill-pointertemplates
vertex-count
loopforindexbelowtemplate-countsum
length
mesh-template-vertices
areftemplatesindex
words
make-array:element-type'
unsigned-byte32
ranges
make-array
*2template-count
:element-type'
unsigned-byte32
vertex-start0
write0
dotimes
indextemplate-count
let*
template
areftemplatesindex
vertices
mesh-template-verticestemplate
setf
arefranges
*2
mesh-template-idtemplate
vertex-start
arefranges
1+
*2
mesh-template-idtemplate
lengthvertices
incfvertex-start
lengthvertices
valueswordsranges
defun%finish-instance-stream
streamranges

Counting-scatter one columnar stream by template and derive its draws.

let*
source
instance-stream-wordsstream
template-count
truncate
lengthranges
2
counts
make-arraytemplate-count:element-type'
unsigned-byte32
:initial-element0
starts
make-arraytemplate-count:element-type'
unsigned-byte32
writes
make-arraytemplate-count:element-type'
unsigned-byte32
words
make-array:element-type'
unsigned-byte32
drawsnil
triangle-count0
flet
template-id
index
ldb
byte160
dotimes
incf
arefcounts
template-idsource-index
let
start0
dotimes
template-idtemplate-count
setf
arefstartstemplate-id
start
arefwritestemplate-id
start
incfstart
arefcountstemplate-id

Descending source traversal preserves the historical reverse emission order within each template bucket without a permutation.

loopforsource-indexdownfrom
1-count
to0do
let*
template-id
template-idsource-index
instance-index
arefwritestemplate-id
incf
arefwritestemplate-id
dotimes
template-idtemplate-count
let
instances
arefcountstemplate-id
when
pluspinstances
let
vertex-start
arefranges
*2template-id
vertex-count
arefranges
1+
*2template-id
push
listtemplate-idvertex-startvertex-count
arefstartstemplate-id
instances
draws
incftriangle-count
*instances
truncatevertex-count3
valueswords
nreversedraws
triangle-count
defun%finish-surface-mesh
builder
multiple-value-bind
template-wordstemplate-ranges
multiple-value-bind
face-wordsface-drawsface-triangles
%finish-instance-stream
surface-mesh-builder-face-streambuilder
template-ranges
multiple-value-bind
band-wordsband-drawsband-triangles
%finish-instance-stream
surface-mesh-builder-band-streambuilder
template-ranges
multiple-value-bind
fan-wordsfan-drawsfan-triangles
%finish-instance-stream
surface-mesh-builder-fan-streambuilder
template-ranges
%make-surface-mesh
surface-mesh-builder-domainbuilder
surface-mesh-builder-bevel-widthbuilder
template-wordstemplate-rangesface-wordsface-drawsband-wordsband-drawsfan-wordsfan-drawsface-trianglesband-trianglesfan-triangles
surface-mesh-builder-singular-star-countbuilder
defunselect-surface-mesh-stocks
meshpredicate

Return mesh's instances whose packed stock satisfies predicate.

The exact template vocabulary and geometry width remain borrowed from mesh; only the three dense instance streams are partitioned. This is intended for coarse materialization policy such as independently resident material cohorts, not as a substitute for a variable-width junction construction.

check-typemeshsurface-mesh
check-typepredicatefunction
labels
selected-stream
words
let
stream
%make-instance-stream
loopforoffsetfrom0below
lengthwords
by+mesh-instance-word-count+formeta=
arefwords
+offset3
forstock=when
funcallpredicatestock
do
loopforword-offsetbelow+mesh-instance-word-count+do
vector-push-extend
arefwords
+offsetword-offset
instance-stream-wordsstream
%finish-instance-streamstream
surface-mesh-template-rangesmesh
multiple-value-bind
face-wordsface-drawsface-triangles
selected-stream
surface-mesh-face-instance-wordsmesh
multiple-value-bind
band-wordsband-drawsband-triangles
selected-stream
surface-mesh-band-instance-wordsmesh
multiple-value-bind
fan-wordsfan-drawsfan-triangles
selected-stream
surface-mesh-fan-instance-wordsmesh
%make-surface-mesh
surface-mesh-domainmesh
surface-mesh-bevel-widthmesh
surface-mesh-template-vertex-wordsmesh
surface-mesh-template-rangesmesh
face-wordsface-drawsband-wordsband-drawsfan-wordsfan-drawsface-trianglesband-trianglesfan-triangles
surface-mesh-singular-star-countmesh

--------------------------------------------------------------------------- Exact coplanar compression

defun%point-order<
leftright
loopforlinleftforrinrightwhen
/=lr
return
<lr
finally
defun%ordered-point-edge
leftright
if
%point-order<leftright
listleftright
listrightleft
defun%point-cross
abc
let
ux
-
firstb
firsta
uz
-
thirdb
thirda
vx
-
firstc
firsta
vz
-
thirdc
thirda
list
-
*uyvz
*uzvy
-
*uzvx
*uxvz
-
*uxvy
*uyvx
defun%point-dot
leftright
+
*
firstleft
firstright
*
secondleft
secondright
*
thirdleft
thirdright
defun%primitive-plane-normal
abc
let*
cross
divisor
reduce#'gcdcross:key#'abs
unless
pluspdivisor
error"Degenerate triangle in coplanar compression: ~S ~S ~S."abc
mapcar
lambda
coordinate
/coordinatedivisor
cross
defun%map-surface-mesh-triangle-records

Call function with kind, stock, ambient, mask, normal, and three points.

let
templates
surface-mesh-template-vertex-wordsmesh
ranges
surface-mesh-template-rangesmesh
labels
visit
wordskind
loopforoffsetfrom0below
lengthwords
by4forbase=
list
arefwordsoffset
arefwords
+offset1
arefwords
+offset2
formeta=
arefwords
+offset3
fortemplate-id=
ldb
byte160
meta
forstock=forambient=forstart=
arefranges
*2template-id
forcount=
arefranges
1+
*2template-id
do
loopforvertexfromstartbelow
+startcount
by3forattributes=fora=
pointbasevertex
forb=
pointbase
1+vertex
forc=
pointbase
+vertex2
fornormal=do
funcallfunctionkindstockambient
ldb
byte310
attributes
normalabc
visit
surface-mesh-face-instance-wordsmesh
:face
visit
surface-mesh-band-instance-wordsmesh
:band
visit
surface-mesh-fan-instance-wordsmesh
:junction
defun%unit-bevel-point-site
point

Return the canonical lattice site and local direction owning point.

point must come from a width-one luft surface, so every coordinate is exactly on, one tick above, or one tick below its owning lattice plane.

let
sitenil
directionnil
dolist
coordinatepoint
multiple-value-bind
cellremainder
caseremainder
0
push0direction
1
push1direction
7
pushsite
push-1direction
t
error"Width-one point coordinate ~D has no canonical lattice-site owner."coordinate
values
nreversesite
nreversedirection
defun%point-distance-squared
leftright
loopforlinleftforrinrightsum
let
difference
-rl
*differencedifference
defun%collapsed-triangle-split
abc

Return the long edge and its interior point for a collinear triangle.

When three distinct transformed points become collinear, dropping their triangle leaves a long edge on one neighbour opposite two shorter edges on the others. The returned split is the exact T-junction contraction needed to make those three neighbours share the same two edges.

let
points
remove-duplicates
listabc
:test#'equal
when
=3
lengthpoints
destructuring-bind
abc
points
let
destructuring-bind
lengthleftrightmiddle
reduce
lambda
leftright
if
>
firstleft
firstright
leftright
candidates
declare
ignorelength
valuesmiddle
defunvary-surface-mesh-bevel-widths
witnesswidth-function&key
contract-t-junctions-pt

Evaluate one width-one witness at a locally selected width per vertex site.

width-function is called once for each canonical lattice vertex as (width-function X Y Z INCIDENT-STOCKS) where INCIDENT-STOCKS is a sorted list of the packed stocks on witness triangles using that site. It must return an integer width from one through four.

Every witness vertex has the exact affine form 8*S + Q with Q in {-1,0,1}^3. The result replaces it by 8*S + width(S)*Q. Since every incident primitive uses the same canonical S, shared vertices remain equal without stitching. At the medial limit a witness triangle can collapse to three collinear points. The result contracts that triangle by splitting its surviving neighbour's long edge at the middle point, eliminating the otherwise visible T-junction without inventing a surface. witness remains the rebuild oracle for topology and uniform-width geometry. Transition triangles may leave the uniform mesher's 26 exact normal directions. The packed trit normal remains an orientation witness; fragment shading derives the actual primitive normal from world-space position derivatives, so the new directions are not lighting-quantized.

The second value is a five-entry site census indexed by width. The third is a diagnostic plist containing the collapsed-triangle, unmatched-edge, repaired- edge, and residual-edge counts.

contract-t-junctions-p defaults true. NIL deliberately omits collapsed triangles without subdividing their surviving neighbours, returning the open diagnostic surface that motivates the contraction. Production callers should retain the default; the uncontracted surface exists only for topology study.

check-typewitnesssurface-mesh
check-typewidth-functionfunction
unless
=1
surface-mesh-bevel-widthwitness
error"A site-local bevel witness must have width one, not ~D."
surface-mesh-bevel-widthwitness

This deliberately simple exact prototype expands the witness triangles and interns sites in hash tables. A production emitter can compile the same site field densely without changing the affine invariant above.

let
stocks-by-site
make-hash-table:test#'eql
width-by-site
make-hash-table:test#'eql
width-census
make-array5:element-type'
unsigned-byte32
:initial-element0
maximum-width1
%map-surface-mesh-triangle-records
lambda
kindstockambientmasknormalabc
declare
ignorekindambientmasknormal
dolist
point
listabc
multiple-value-bind
sitedirection
declare
ignoredirection
pushnewstock
gethashstocks-by-site
:test#'=
witness
maphash
lambda
keystocks
let
width
funcallwidth-function
sort
copy-liststocks
#'<
unless
error"Site-local bevel policy assigned invalid width ~S at ~S."width
setf
gethashkeywidth-by-site
width
maximum-width
maxmaximum-widthwidth
incf
arefwidth-censuswidth
stocks-by-site
let
builder
%make-surface-mesh-builder
surface-mesh-domainwitness
maximum-width
edge-counts
make-hash-table:test#'equal
candidate-splits
make-hash-table:test#'equal
repair-splits
make-hash-table:test#'equal
collapsed-triangle-count0
setf
surface-mesh-builder-singular-star-countbuilder
surface-mesh-singular-star-countwitness
labels
transformed-point
point
multiple-value-bind
sitedirection
let*
width
gethashkeywidth-by-site
unlesswidth
error"No site-local bevel width was compiled for ~S."site
loopforcoordinateinsiteforcomponentindirectioncollect
+
*widthcomponent
count-edge
leftright
incf
gethashedge-counts0
scan-transition
kindstockambientmasknormalabc
declare
ignorekindstockambientmasknormal
let*
ta
transformed-pointa
tb
transformed-pointb
tc
transformed-pointc
cross
if
every#'zeropcross
progn
incfcollapsed-triangle-count
multiple-value-bind
edgemiddle
whenedge
pushnewmiddle
gethashedgecandidate-splits
:test#'equal
progn
count-edgetatb
count-edgetbtc
count-edgetcta
edge-splits
leftright
sort
copy-list
gethashrepair-splits
#'<:key
lambda
point
edge-points
leftright
append
listleft
edge-splitsleftright
listright
mark-visible-edge
tableleftrightbitmask
when
logtestbitmask
loopforpointson
edge-pointsleftright
while
restpoints
do
setf
gethash
%ordered-point-edge
firstpoints
secondpoints
table
t
triangle-boundary-mask
visibleabc
logior
if
gethashvisible
#b0010
if
gethashvisible
#b0100
if
gethashvisible
#b1000
emit-transition
kindstockambientmasknormalabc
let*
ta
transformed-pointa
tb
transformed-pointb
tc
transformed-pointc
cross
unless
every#'zeropcross
unless
plusp
%point-dotcrossnormal
error"Site-local bevel folded ~S triangle ~S ~S ~S into ~S ~S ~S."kindabctatbtc
let
ab
edge-splitstatb
bc
edge-splitstbtc
ca
edge-splitstcta
if
not
orabbcca
%emit-global-trianglebuilderkindstockambientmask
listtatbtc
let*
loop
append
listta
ab
listtb
bc
listtc
ca
triangles
visible
make-hash-table:test#'equal
unlesstriangles
error"Could not contract site-local bevel T-junction around ~S."loop
mark-visible-edgevisibletatb#b100mask
mark-visible-edgevisibletbtc#b001mask
mark-visible-edgevisibletcta#b010mask
dolist
triangletriangles
destructuring-bind
abc
triangle
%emit-global-trianglebuilderkindstockambient
triangle-boundary-maskvisibleabc
triangle

First find the exact geometric edge mismatch caused only by collinear medial-limit collapses. Uniform width-four regions have no mismatch and consequently receive no needless subdivisions.

%map-surface-mesh-triangle-records#'scan-transitionwitness
let
unmatched-edge-count
loopforcountbeingthehash-valuesofedge-countscount
/=count2
whencontract-t-junctions-p
maphash
lambda
edgepoints
when
=1
gethashedgeedge-counts0
destructuring-bind
leftright
edge
let*
points
sort
copy-listpoints
#'<:key
lambda
point
chain
append
listleft
points
listright
when
loopfortailonchainwhile
resttail
always
=1
gethashedge-counts0
setf
gethashedgerepair-splits
points
candidate-splits

Prove that the selected contractions account for the entire mismatch before changing any triangles. A new failure mode must become explicit rather than rendering another hairline crack.

maphash
lambda
edgepoints
decf
gethashedgeedge-counts
destructuring-bind
leftright
edge
loopfortailon
append
listleft
points
listright
while
resttail
do
incf
gethashedge-counts0
repair-splits
let
residual-edge-count
loopforcountbeingthehash-valuesofedge-countscount
not
or
zeropcount
=count2
when
andcontract-t-junctions-p
pluspresidual-edge-count
error"Site-local bevel contraction left ~D of ~D unmatched edges after ~D repairs."residual-edge-countunmatched-edge-count
hash-table-countrepair-splits
%map-surface-mesh-triangle-records#'emit-transitionwitness
valueswidth-census
list:collapsed-triangle-countcollapsed-triangle-count:unmatched-edge-countunmatched-edge-count:repaired-edge-count
hash-table-countrepair-splits
:residual-edge-countresidual-edge-count:candidate-splits
loopforedgebeingthehash-keysofcandidate-splitsusing
hash-valuepoints
append
loopforpointinpointscollect
list
firstedge
point
secondedge
defun%coplanar-group-loops
triangles

Return oriented boundary loops, or NIL when the union is not simple.

let
edges
make-hash-table:test#'equal
dolist
triangletriangles
destructuring-bind
maskabc
triangle
declare
ignoremask
dolist
edge
list
listab
listbc
listca
let
if
gethashkeyedges
remhashkeyedges
setf
gethashkeyedges
edge
let
next
make-hash-table:test#'equal
incoming
make-hash-table:test#'equal
loopforedgebeingthehash-valuesofedgesdo
destructuring-bind
startend
edge
when
gethashstartnext
return-from%coplanar-group-loopsnil
setf
gethashstartnext
end
incf
gethashendincoming0
loopforstartbeingthehash-keysofnextunless
=1
gethashstartincoming0
do
return-from%coplanar-group-loopsnil
let
loopsnil
loopwhile
plusp
hash-table-countnext
do
let*
start
sort
loopforpointbeingthehash-keysofnextcollectpoint
#'%point-order<
start
firststart
pointstart
loopnil
loopdo
pushpointloop
multiple-value-bind
followingpresent-p
gethashpointnext
unlesspresent-p
return-from%coplanar-group-loopsnil
remhashpointnext
setfpointfollowing
until
equalpointstart
push
nreverseloop
loops
nreverseloops
defun%point-in-oriented-triangle-p
pointabcnormal
and
not
memberpoint
listabc
:test#'equal
defun%triangulate-coplanar-loop
loopnormal

Ear-clip one positively oriented simple integer polygon.

Retain collinear boundary vertices: another coplanar attribute group or differently oriented plane may meet there. Removing such a vertex would preserve the continuous surface but introduce a topological T-junction.

let
pointsloop
trianglesnil
when
<
lengthpoints
3
loopwhile
>
lengthpoints
3
do
let
ear-indexnil
count
lengthpoints
dotimes
indexcount
let
a
nth
mod
1-index
count
points
b
nthindexpoints
c
nth
mod
1+index
count
points
when
and
notany
lambda
point
points
setfear-indexindex
unlessear-index
let*
count
lengthpoints
a
nth
mod
1-ear-index
count
points
b
nthear-indexpoints
c
nth
mod
1+ear-index
count
points
push
listabc
triangles
setfpoints
loopforpointinpointsforindexfrom0unless
=indexear-index
collectpoint
pushpointstriangles
nreversetriangles
defun%emit-global-triangle
builderkindstockambientmasknormaltriangle
destructuring-bind
abc
triangle
let*
minimums
loopforaxisbelow3collect
min
nthaxisa
nthaxisb
nthaxisc
base
mapcar
lambda
coordinate
minimums
origin
mapcar
lambda
coordinate
base
scratch
surface-mesh-builder-vertex-scratchbuilder
%scratch-trianglescratch0
ecasekind
:face0
:band1
:junction2
mask
-
firsta
firstorigin
-
thirda
thirdorigin
-
firstb
firstorigin
-
thirdb
thirdorigin
-
firstc
firstorigin
-
thirdc
thirdorigin
firstnormal
secondnormal
thirdnormal
%emit-instancebuilderkind
firstbase
secondbase
thirdbase
stockambient3
defunsurface-mesh-with-triangle-ink
mesh

Return mesh's exact triangles with every primitive edge marked visible.

The geometry, stock, ambient value, primitive class, and winding are retained. Only the three construction-mask bits change. This diagnostic realization exposes connectivity that the ordinary semantic edge mask intentionally hides; it must not be substituted for the production mesh outside topology captures.

check-typemeshsurface-mesh
let
builder
%make-surface-mesh-builder
surface-mesh-domainmesh
surface-mesh-bevel-widthmesh
setf
surface-mesh-builder-singular-star-countbuilder
surface-mesh-singular-star-countmesh
%map-surface-mesh-triangle-records
lambda
kindstockambientmasknormalabc
declare
ignoremask
%emit-global-trianglebuilderkindstockambient#b111normal
listabc
mesh
defunsurface-mesh-split-neighborhood
meshsplit

Return only the triangles incident to the three points in split.

split is (LEFT MIDDLE RIGHT), as reported in the :CANDIDATE-SPLITS bevel diagnostic. A triangle is retained when two or more of its vertices are split points, so the result is the smallest actual mesh patch that contrasts one long edge with its two short neighbours. Every retained edge is marked visible; no vertex or triangle geometry is otherwise changed. This is the executable closeup used by the mixed-bevel degeneracy atlas. #WSEK3C

check-typemeshsurface-mesh
unless
and
listpsplit
=3
lengthsplit
error"A mesh split neighborhood needs (LEFT MIDDLE RIGHT), not ~S."split
let
builder
%make-surface-mesh-builder
surface-mesh-domainmesh
surface-mesh-bevel-widthmesh
%map-surface-mesh-triangle-records
lambda
kindstockambientmasknormalabc
declare
ignoremask
when
>=
count-if
lambda
point
memberpointsplit:test#'equal
listabc
2
%emit-global-trianglebuilderkindstockambient#b111normal
listabc
mesh
defun%coplanar-group-key<
leftright
flet
numeric-key
key
destructuring-bind
kindstockambientnormalplane
key
list
ecasekind
:face0
:band1
:junction2
stockambient
firstnormal
secondnormal
thirdnormal
plane
loopforlin
numeric-keyleft
forrin
numeric-keyright
when
/=lr
return
<lr
finally
defun%coplanar-merged-surface-mesh
mesh

Dissolve only interior edges between exactly coplanar equal-attribute faces.

The output has the same points, oriented planes, stocks, ambient values, silhouette, and depth as mesh. Groups with a non-simple boundary retain their original triangles, making the unmerged medial mesh a local rebuild oracle.

let
groups
make-hash-table:test#'equal
builder
%make-surface-mesh-builder
surface-mesh-domainmesh
surface-mesh-bevel-widthmesh
%map-surface-mesh-triangle-records
lambda
kindstockambientmasknormalabc
let
key
listkindstockambientnormal
%point-dotnormala
push
listmaskabc
gethashkeygroups
mesh
dolist
key
sort
loopforkeybeingthehash-keysofgroupscollectkey
#'%coplanar-group-key<
let
triangles
gethashkeygroups
destructuring-bind
kindstockambientnormalplane
key
declare
ignoreplane
let
loops
mergednil
boundary
make-hash-table:test#'equal
whenloops
dolist
looploops
loopforpointonloopfora=
firstpoint
forb=
or
secondpoint
firstloop
do
setf
gethashboundary
t
setfmerged
loopforloopinloopswhen
plusp
loopforpointonloopfora=
firstpoint
forb=
or
secondpoint
firstloop
sum
appendelsedo
setfloopsnil
if
andloopsmerged
dolist
trianglemerged
destructuring-bind
abc
triangle
let
mask
logior
if
gethashboundary
#b0010
if
gethashboundary
#b0100
if
gethashboundary
#b1000
%emit-global-trianglebuilderkindstockambientmasknormaltriangle
dolist
triangletriangles
%emit-global-trianglebuilderkindstockambient
firsttriangle
normal
resttriangle
setf
surface-mesh-builder-singular-star-countbuilder
surface-mesh-singular-star-countmesh

--------------------------------------------------------------------------- Entry point

defun%call-with-boundary-policy
policythunk

Run thunk under one outside-domain policy.

:AIR answers every out-of-box probe with the TREAT-AS-AIR restart; :SIGNAL leaves the condition for the caller's own handlers (a chunk store, a test).

ecasepolicy
:air
handler-bind
outside-domain
lambda
condition
declare
ignorecondition
invoke-restart'treat-as-air
funcallthunk
:signal
funcallthunk
defunmake-surface-mesh
solid&key
stock-function
constantly0
chamfer-stock-function
lambda
stocks
firststocks
boundary:air

Classify solid into exact integer face, edge, and vertex instance streams.

Below the medial limit, every exposed cell face emits the same width-dependent central square and crease edges own the intervening bands. At the half-cell limit those two families become zero-area seams: a sub-medial witness retains their boundary cycles while only the expanded site-local patches are emitted. Each stream is sorted by template so the renderer can issue direct instanced draws. stock-function is called with an oriented boundary face. chamfer-stock-function receives the face stocks incident to one edge-owned collar, bevel, or lattice-site closure. It must return one stock for that entire chamfer.

check-typesolidchain
check-typestock-functionfunction
check-typechamfer-stock-functionfunction
unless
and
integerpbevel-width
<=1bevel-width
error"Bevel width ~S must be an integer between one and four ticks."bevel-width
check-typeboundary
member:air:signal
let*
domain
builder
%make-surface-mesh-builderdomainbevel-width
boundary-builder
if
=bevel-width
%make-surface-mesh-builderdomain
builder
%call-with-boundary-policyboundary
lambda
let
multiple-value-bind
x0x1y0y1
let
%enable-boundary-observations
listboundary-builder
packing
%emit-exposed-cell-facesboundary-builderfielddomain
%chain-sitessolid
stock-functionchamfer-stock-functionedge-candidates
loopforkeyacrossdo
%emit-edge-bandsboundary-builderfielddomainkeystock-functionchamfer-stock-function
%count-singular-vertex-starsbuilderfielddomaincells0
1+x-limit
0
1+y-limit
%emit-boundary-derived-fansbuilderfielddomainchamfer-stock-function
listboundary-builder
packing0
1+x-limit
0
1+y-limit
nil
defun%cell-key-box
cells

The half-open horizontal cell box spanned by the packed keys in cells.

declare
type
simple-array
unsigned-byte64
cells
if
zerop
lengthcells
values0101
let
x0most-positive-fixnum
x1most-negative-fixnum
y0most-positive-fixnum
y1most-negative-fixnum
loopforkeyacrosscellsdo
let
setfx0
minx0x
x1
maxx1x
y0
miny0y
y1
maxy1y
valuesx0
1+x1
y0
1+y1
defun%emit-exposed-cell-faces
targetfielddomaincellsstock-functionchamfer-stock-function&optionaledge-candidates

Emit every exposed face of the packed cell sites in cells into target.

loopforcellacrosscellsdo
let
dotimes
axis-number3
dolist
side'
-11
when
=0
%occupied-bitfielddomain
+cx
if
=axis-number0
side0
+cy
if
=axis-number1
side0
+cz
if
=axis-number2
side0
whenedge-candidates
%append-face-edge-keysedge-candidatescxcyczaxis-numberside
%emit-cell-facetargetfielddomaincellaxis-numbersidestock-functionchamfer-stock-function
edge-candidates
defun%planar-face-group<
leftright
loopforlinleftforrinrightwhen
/=lr
return
<lr
finally
defun%emit-greedy-planar-faces
builderfielddomaincellsstock-function

Merge exposed cubical faces into maximal coplanar rectangles. #YGP21F

Faces merge only when their axis, orientation, plane, and stock agree. The pass therefore changes neither position, normal, material, silhouette, nor depth relative to the cubical boundary; it only dissolves interior edges.

let
groups
make-hash-table:test#'equal
loopforcellacrosscellsdo
let
dotimes
axis-number3
dolist
side'
-11
let
x
svrefcoordinates0
y
svrefcoordinates1
z
svrefcoordinates2
caseaxis-number
0
incfxside
1
incfyside
t
incfzside
when
=0
%occupied-bitfielddomainxyz
let*
u
svref+axis-u+axis-number
v
svref+axis-v+axis-number
face
stock
funcallstock-functionface
plane
+
svrefcoordinatesaxis-number
if
pluspside
10
group-key
listaxis-numbersideplanestock
group
or
gethashgroup-keygroups
setf
gethashgroup-keygroups
make-hash-table:test#'eql
setf
gethash
%pack-planar-coordinate
svrefcoordinatesu
svrefcoordinatesv
group
t
let
group-keys
sort
loopforkeybeingthehash-keysofgroupscollectkey
#'%planar-face-group<
dolist
group-keygroup-keys
destructuring-bind
axis-numbersideplanestock
group-key
let*
u-axis
svref+axis-u+axis-number
v-axis
svref+axis-v+axis-number
group
gethashgroup-keygroups
nx
if
=axis-number0
side0
ny
if
=axis-number1
side0
nz
if
=axis-number2
side0
loopwhile
plusp
hash-table-countgroup
do
let*
first
loopforcoordinatebeingthehash-keysofgroupminimizecoordinate
u1
loopforufromu0whilefinally
v1
loopforvfrom
1+v0
while
loopforufromu0belowu1always
finally
loopforvfromv0belowv1do
loopforufromu0belowu1do
let
base
vector000
p0
vector000
p1
vector000
p2
vector000
p3
vector000
setf
svrefbaseaxis-number
plane
svrefbaseu-axis
u0
svrefbasev-axis
v0
flet
set-point
pointuv
setf
svrefpointaxis-number
svrefpointu-axis
svrefpointv-axis
set-pointp0u0v0
set-pointp1u1v0
set-pointp2u1v1
set-pointp3u0v1
%emit-quadbuilder:face
svrefbase0
svrefbase1
svrefbase2
p0p1p2p3nxnynzstock0
defun%make-planar-merged-chunk-mesh
domainbevel-widthfieldcellsstock-function
let
builder
%make-surface-mesh-builderdomainbevel-width
%emit-greedy-planar-facesbuilderfielddomaincellsstock-function
defunmesh-chunk
chunkchunk-key&key
stock-function
constantly0
chamfer-stock-function
lambda
stocks
firststocks
planar-merge-pcoplanar-merge-p

Classify one chunk's solid chunk into the instance-stream ABI.

chunk holds exactly the cells of the chunk named by chunk-key. Probes leaving the chunk signal missing-chunk once per neighboring chunk -- bind a handler that answers USE-CHUNK from a store, or TREAT-AS-AIR to fill in -- and probes past the world's box signal outside-domain; mesh-chunk sets no policy of its own. The mesh ships only what this chunk owns: faces of its own solid cells, bands whose edge anchors lie inside it, and fans at its own lattice vertices. Witness faces and bands are recomputed from the one-cell halo and scanned but never shipped, so seam fans close exactly as a whole-world mesh would close them.

When planar-merge-p is true, emit the exact unbeveled cubical boundary as greedily merged coplanar rectangles. This far-distance representation keeps occupancy, normals, materials, silhouette, and chunk seams while omitting bevel ornament and all geometrically redundant interior face edges.

When coplanar-merge-p is true, first construct the requested bevel surface, then exactly dissolve its coplanar interior edges. This retains the full surface and falls back group-by-group whenever a boundary is not simple.

check-typechunkchain
check-typestock-functionfunction
check-typechamfer-stock-functionfunction
unless
and
integerpbevel-width
<=1bevel-width
error"Bevel width ~S must be an integer between one and four ticks."bevel-width
let*
domain
field
medial-p
=bevel-width
sheet-bevel
ifmedial-p
1-bevel-width
bevel-width
builder
%make-surface-mesh-builderdomainbevel-width
ship-sheets
ifmedial-p
%make-surface-mesh-builderdomainsheet-bevel
builder
witness-sheets
%make-surface-mesh-builderdomainsheet-bevel
loopforcellacross
%chain-siteschunk
do
unless
error"Cell ~S does not belong to chunk ~D."cellchunk-key
whenplanar-merge-p
return-frommesh-chunk
%make-planar-merged-chunk-meshdomainbevel-widthfield
%chain-siteschunk
stock-function

Owned sites are the half-open coordinate box of this chunk's grid cell; anchors on the far seam belong to the next chunk over. Owned sites' cell stars reach exactly one cell below the origin per axis, so only the low-side ring of neighbor cells witnesses the seams; the high seams are the low sides of the next chunks over, which witness them symmetrically.

let
loopfor
dxdy
in'
-10
0-1
-1-1
do
let
nx
+grid-xdx
ny
+grid-ydy
when
and
<=0nx
<=0ny
let
caseresolution
:airnil
:solid
error

A fully solid chunk resolution cannot feed ~ a mesh halo yet.

t
loopforkeybeingthehash-keysofresolutiondo
let
when
and
<=
1-x0
x
<xx1
<=
1-y0
y
<yy1
or
<xx0
<yy0
pushkeyhalo-list
let*
halo
sort
coercehalo-list'
simple-array
unsigned-byte64
#'<
own-cells
region-cells
concatenate'
simple-array
unsigned-byte64
own-cellshalo
halo-sites
make-array
lengthhalo
:element-type'
unsigned-byte64
let
%enable-boundary-observations
listship-sheetswitness-sheets
packing
loopforkeyacrosshaloforindexfrom0do

Owned faces ship; halo faces are witnesses for the seam scan.

%emit-exposed-cell-facesship-sheetsfielddomain
%chain-siteschunk
stock-functionchamfer-stock-functionedge-candidates
%emit-exposed-cell-faceswitness-sheetsfielddomainhalo-sitesstock-functionchamfer-stock-functionedge-candidates
loopforkeyacrossdo
let*

High-seam anchors belong to the next chunk over and matter to none of this chunk's fans; skip them.

when
and
<=
1-x0
x
<xox1
<=
1-y0
y
<yoy1
%emit-edge-bands
if
and
<=x0x
<=y0y
ship-sheetswitness-sheets
fielddomainkeystock-functionchamfer-stock-function
%count-singular-vertex-starsbuilderfielddomainregion-cellsx0ox1y0oy1
%emit-boundary-derived-fansbuilderfielddomainchamfer-stock-function
listship-sheetswitness-sheets
packingx0ox1y0oy1t
let
ifcoplanar-merge-pmesh