636 lines
25 KiB
Racket
636 lines
25 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/flonum racket/fixnum racket/list racket/match racket/unsafe/ops racket/contract
|
|
unstable/latent-contract/defthing
|
|
(for-syntax racket/base)
|
|
"math.rkt"
|
|
"utils.rkt"
|
|
"marching-utils.rkt")
|
|
|
|
(provide heights->lines heights->polys
|
|
heights->lines:doc heights->polys:doc)
|
|
|
|
#|
|
|
Z values are at these normalized coordinates:
|
|
|
|
(0,1) (1,1)
|
|
z4 --- z3
|
|
| |
|
|
| |
|
|
z1 --- z2
|
|
(0,0) (1,0)
|
|
|
|
A marching squares algorithm and all of its facet functions have this type:
|
|
|
|
ftype m = real real real real real -> m
|
|
|
|
where 'm' is a use-specific type, such as the type of "list of lines". The
|
|
first argument is the contour value; the rest are z coordinates arranged as
|
|
above.
|
|
|#
|
|
|
|
(define-syntax-rule (unrotate-vec v)
|
|
(match-let ([(vector x y z) v])
|
|
(vector (unsafe-fl- 1.0 y) x z)))
|
|
|
|
(define-syntax-rule (mirror-x-vec v)
|
|
(match-let ([(vector x y z) v])
|
|
(vector (fl- 1.0 x) y z)))
|
|
|
|
(define-syntax-rule (mirror-y-vec v)
|
|
(match-let ([(vector x y z) v])
|
|
(vector x (fl- 1.0 y) z)))
|
|
|
|
;; =============================================================================
|
|
;; Contour lines
|
|
|
|
;; Except for opposite-corner facets, every line-returning facet function is
|
|
;; identical to the facet for its bitwise complement.
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; all corners left out or included
|
|
|
|
;(: lines0000 (FType Lines))
|
|
(define-syntax-rule (lines0000 z z1 z2 z3 z4) empty)
|
|
(define-syntax-rule (lines1111 z z1 z2 z3 z4) empty)
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; one corner included or left out
|
|
|
|
;(: lines1000 (FType Lines))
|
|
(define-syntax-rule (lines1000 z z1 z2 z3 z4)
|
|
(list (vector (unsafe-solve-t z z1 z2) 0.0
|
|
0.0 (unsafe-solve-t z z1 z4))))
|
|
|
|
;(: lines0100 (FType Lines))
|
|
(define-syntax-rule (lines0100 z z1 z2 z3 z4)
|
|
(list (vector (unsafe-solve-t z z1 z2) 0.0
|
|
1.0 (unsafe-solve-t z z2 z3))))
|
|
|
|
;(: lines0010 (FType Lines))
|
|
(define-syntax-rule (lines0010 z z1 z2 z3 z4)
|
|
(list (vector 1.0 (unsafe-solve-t z z2 z3)
|
|
(unsafe-solve-t z z4 z3) 1.0)))
|
|
|
|
;(: lines0001 (FType Lines))
|
|
(define-syntax-rule (lines0001 z z1 z2 z3 z4)
|
|
(list (vector 0.0 (unsafe-solve-t z z1 z4)
|
|
(unsafe-solve-t z z4 z3) 1.0)))
|
|
|
|
(define-syntax-rule (lines0111 z z1 z2 z3 z4) (lines1000 z z1 z2 z3 z4))
|
|
(define-syntax-rule (lines1011 z z1 z2 z3 z4) (lines0100 z z1 z2 z3 z4))
|
|
(define-syntax-rule (lines1101 z z1 z2 z3 z4) (lines0010 z z1 z2 z3 z4))
|
|
(define-syntax-rule (lines1110 z z1 z2 z3 z4) (lines0001 z z1 z2 z3 z4))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; adjacent corners included or left out
|
|
|
|
;(: lines1100 (FType Lines))
|
|
(define-syntax-rule (lines1100 z z1 z2 z3 z4)
|
|
(list (vector 0.0 (unsafe-solve-t z z1 z4)
|
|
1.0 (unsafe-solve-t z z2 z3))))
|
|
|
|
;(: lines0110 (FType Lines))
|
|
(define-syntax-rule (lines0110 z z1 z2 z3 z4)
|
|
(list (vector (unsafe-solve-t z z1 z2) 0.0
|
|
(unsafe-solve-t z z4 z3) 1.0)))
|
|
|
|
(define-syntax-rule (lines0011 z z1 z2 z3 z4) (lines1100 z z1 z2 z3 z4))
|
|
(define-syntax-rule (lines1001 z z1 z2 z3 z4) (lines0110 z z1 z2 z3 z4))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; opposite corners left out / included
|
|
|
|
;(: lines-opposite ((Float Float -> Boolean) -> (FType Lines)))
|
|
(define-syntax-rule (lines-opposite test? z z1 z2 z3 z4)
|
|
; disambiguate using average of corners as guess for center value
|
|
(let ([z5 (unsafe-flavg4 z1 z2 z3 z4)])
|
|
(if (test? z5 z)
|
|
(list (vector (unsafe-solve-t z z1 z2) 0.0
|
|
1.0 (unsafe-solve-t z z2 z3))
|
|
(vector 0.0 (unsafe-solve-t z z1 z4)
|
|
(unsafe-solve-t z z4 z3) 1.0))
|
|
(list (vector (unsafe-solve-t z z1 z2) 0.0
|
|
0.0 (unsafe-solve-t z z1 z4))
|
|
(vector 1.0 (unsafe-solve-t z z2 z3)
|
|
(unsafe-solve-t z z4 z3) 1.0)))))
|
|
|
|
(define-syntax-rule (lines1010 z z1 z2 z3 z4) (lines-opposite unsafe-fl>= z z1 z2 z3 z4))
|
|
(define-syntax-rule (lines0101 z z1 z2 z3 z4) (lines-opposite unsafe-fl< z z1 z2 z3 z4))
|
|
|
|
(define (unsafe-heights->lines z z1 z2 z3 z4)
|
|
(define p1 (z1 . unsafe-fl>= . z))
|
|
(define p2 (z2 . unsafe-fl>= . z))
|
|
(define p3 (z3 . unsafe-fl>= . z))
|
|
(define p4 (z4 . unsafe-fl>= . z))
|
|
(if p1
|
|
(if p2
|
|
(if p3
|
|
(if p4
|
|
(lines1111 z z1 z2 z3 z4)
|
|
(lines1110 z z1 z2 z3 z4))
|
|
(if p4
|
|
(lines1101 z z1 z2 z3 z4)
|
|
(lines1100 z z1 z2 z3 z4)))
|
|
(if p3
|
|
(if p4
|
|
(lines1011 z z1 z2 z3 z4)
|
|
(lines1010 z z1 z2 z3 z4))
|
|
(if p4
|
|
(lines1001 z z1 z2 z3 z4)
|
|
(lines1000 z z1 z2 z3 z4))))
|
|
(if p2
|
|
(if p3
|
|
(if p4
|
|
(lines0111 z z1 z2 z3 z4)
|
|
(lines0110 z z1 z2 z3 z4))
|
|
(if p4
|
|
(lines0101 z z1 z2 z3 z4)
|
|
(lines0100 z z1 z2 z3 z4)))
|
|
(if p3
|
|
(if p4
|
|
(lines0011 z z1 z2 z3 z4)
|
|
(lines0010 z z1 z2 z3 z4))
|
|
(if p4
|
|
(lines0001 z z1 z2 z3 z4)
|
|
(lines0000 z z1 z2 z3 z4))))))
|
|
|
|
(defproc (heights->lines [xa real?] [xb real?] [ya real?] [yb real?]
|
|
[z real?] [z1 real?] [z2 real?] [z3 real?] [z4 real?]
|
|
) (listof (list/c (vector/c real? real? real?) (vector/c real? real? real?)))
|
|
(cond [(all inexact-real? xa xb ya yb z z1 z2 z3 z4)
|
|
(define lines (unsafe-heights->lines z z1 z2 z3 z4))
|
|
(for/list ([line (in-list lines)])
|
|
(match-define (vector u1 v1 u2 v2) line)
|
|
(list (vector (unsafe-unsolve-t xa xb u1) (unsafe-unsolve-t ya yb v1) z)
|
|
(vector (unsafe-unsolve-t xa xb u2) (unsafe-unsolve-t ya yb v2) z)))]
|
|
[(find-failure-index real? xa xb ya yb z z1 z2 z3 z4)
|
|
=> (λ (i) (raise-type-error 'heights->liens "real number" i xa xb ya yb z z1 z2 z3 z4))]
|
|
[(= z z1 z2 z3 z4) empty]
|
|
[else
|
|
(let-map
|
|
(z z1 z2 z3 z4) inexact->exact
|
|
(define z-min (min z z1 z2 z3 z4))
|
|
(define z-max (max z z1 z2 z3 z4))
|
|
(define z-scale (- z-max z-min))
|
|
(define lines
|
|
(unsafe-heights->lines (exact->inexact (/ (- z z-min) z-scale))
|
|
(exact->inexact (/ (- z1 z-min) z-scale))
|
|
(exact->inexact (/ (- z2 z-min) z-scale))
|
|
(exact->inexact (/ (- z3 z-min) z-scale))
|
|
(exact->inexact (/ (- z4 z-min) z-scale))))
|
|
(for/list ([line (in-list lines)])
|
|
(match-define (vector u1 v1 u2 v2) line)
|
|
(list (vector (unsolve-t xa xb u1) (unsolve-t ya yb v1) z)
|
|
(vector (unsolve-t xa xb u2) (unsolve-t ya yb v2) z))))]))
|
|
|
|
;; =============================================================================
|
|
;; Isoband marching squares: polygonizes contour between two isoline values
|
|
|
|
(define ((rotate-facet f) za zb z1 z2 z3 z4)
|
|
(map (λ (poly) (map (λ (v) (unrotate-vec v)) poly))
|
|
(f za zb z2 z3 z4 z1)))
|
|
|
|
(define ((mirror-x-facet f) za zb z1 z2 z3 z4)
|
|
(map (λ (poly) (map (λ (v) (mirror-x-vec v)) poly))
|
|
(f za zb z2 z1 z4 z3)))
|
|
|
|
(define ((mirror-y-facet f) za zb z1 z2 z3 z4)
|
|
(map (λ (poly) (map (λ (v) (mirror-y-vec v)) poly))
|
|
(f za zb z4 z3 z2 z1)))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; all corners same
|
|
|
|
(define (polys0000 za zb z1 z2 z3 z4) empty)
|
|
(define (polys2222 za zb z1 z2 z3 z4) empty)
|
|
(define (polys1111 za zb z1 z2 z3 z4) (list 'full))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; single triangle
|
|
|
|
(define (polys1000 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))))
|
|
|
|
(define polys0100 (rotate-facet polys1000))
|
|
(define polys0010 (rotate-facet polys0100))
|
|
(define polys0001 (rotate-facet polys0010))
|
|
|
|
(define (polys1222 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))))
|
|
|
|
(define polys2122 (rotate-facet polys1222))
|
|
(define polys2212 (rotate-facet polys2122))
|
|
(define polys2221 (rotate-facet polys2212))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; single trapezoid
|
|
|
|
(define (polys2000 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))))
|
|
|
|
(define polys0200 (rotate-facet polys2000))
|
|
(define polys0020 (rotate-facet polys0200))
|
|
(define polys0002 (rotate-facet polys0020))
|
|
|
|
(define (polys0222 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))))
|
|
|
|
(define polys2022 (rotate-facet polys0222))
|
|
(define polys2202 (rotate-facet polys2022))
|
|
(define polys2220 (rotate-facet polys2202))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; single rectangle
|
|
|
|
(define (polys1100 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector 1.0 0.0 z2)
|
|
(vector 1.0 (unsafe-solve-t za z2 z3) za)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))))
|
|
|
|
(define polys0110 (rotate-facet polys1100))
|
|
(define polys0011 (rotate-facet polys0110))
|
|
(define polys1001 (rotate-facet polys0011))
|
|
|
|
(define (polys1122 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector 1.0 0.0 z2)
|
|
(vector 1.0 (unsafe-solve-t zb z2 z3) zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))))
|
|
|
|
(define polys2112 (rotate-facet polys1122))
|
|
(define polys2211 (rotate-facet polys2112))
|
|
(define polys1221 (rotate-facet polys2211))
|
|
|
|
(define (polys0022 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 (unsafe-solve-t za z1 z4) za)
|
|
(vector 1.0 (unsafe-solve-t za z2 z3) za)
|
|
(vector 1.0 (unsafe-solve-t zb z2 z3) zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))))
|
|
|
|
(define polys2002 (rotate-facet polys0022))
|
|
(define polys2200 (rotate-facet polys2002))
|
|
(define polys0220 (rotate-facet polys2200))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; single pentagon
|
|
|
|
(define (polys0111 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector 1.0 0.0 z2)
|
|
(vector 1.0 1.0 z3)
|
|
(vector 0.0 1.0 z4)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))))
|
|
|
|
(define polys1011 (rotate-facet polys0111))
|
|
(define polys1101 (rotate-facet polys1011))
|
|
(define polys1110 (rotate-facet polys1101))
|
|
|
|
(define (polys2111 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 1.0 0.0 z2)
|
|
(vector 1.0 1.0 z3)
|
|
(vector 0.0 1.0 z4)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))))
|
|
|
|
(define polys1211 (rotate-facet polys2111))
|
|
(define polys1121 (rotate-facet polys1211))
|
|
(define polys1112 (rotate-facet polys1121))
|
|
|
|
(define (polys1002 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector (unsafe-solve-t za z4 z3) 1.0 za)
|
|
(vector (unsafe-solve-t zb z4 z3) 1.0 zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))))
|
|
|
|
(define polys2100 (rotate-facet polys1002))
|
|
(define polys0210 (rotate-facet polys2100))
|
|
(define polys0021 (rotate-facet polys0210))
|
|
|
|
(define (polys1220 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector (unsafe-solve-t zb z4 z3) 1.0 zb)
|
|
(vector (unsafe-solve-t za z4 z3) 1.0 za)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))))
|
|
|
|
(define polys0122 (rotate-facet polys1220))
|
|
(define polys2012 (rotate-facet polys0122))
|
|
(define polys2201 (rotate-facet polys2012))
|
|
|
|
(define (polys1200 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 1.0 (unsafe-solve-t zb z2 z3) zb)
|
|
(vector 1.0 (unsafe-solve-t za z2 z3) za)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))))
|
|
|
|
(define polys0120 (rotate-facet polys1200))
|
|
(define polys0012 (rotate-facet polys0120))
|
|
(define polys2001 (rotate-facet polys0012))
|
|
|
|
(define (polys1022 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector 1.0 (unsafe-solve-t za z2 z3) za)
|
|
(vector 1.0 (unsafe-solve-t zb z2 z3) zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))))
|
|
|
|
(define polys2102 (rotate-facet polys1022))
|
|
(define polys2210 (rotate-facet polys2102))
|
|
(define polys0221 (rotate-facet polys2210))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; single hexagon
|
|
|
|
(define (polys0112 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector 1.0 0.0 z2)
|
|
(vector 1.0 1.0 z3)
|
|
(vector (unsafe-solve-t zb z4 z3) 1.0 zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))))
|
|
|
|
(define polys2011 (rotate-facet polys0112))
|
|
(define polys1201 (rotate-facet polys2011))
|
|
(define polys1120 (rotate-facet polys1201))
|
|
|
|
(define (polys2110 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 1.0 0.0 z2)
|
|
(vector 1.0 1.0 z3)
|
|
(vector (unsafe-solve-t za z4 z3) 1.0 za)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))))
|
|
|
|
(define polys0211 (rotate-facet polys2110))
|
|
(define polys1021 (rotate-facet polys0211))
|
|
(define polys1102 (rotate-facet polys1021))
|
|
|
|
(define (polys0121 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector 1.0 0.0 z2)
|
|
(vector 1.0 (unsafe-solve-t zb z2 z3) zb)
|
|
(vector (unsafe-solve-t zb z4 z3) 1.0 zb)
|
|
(vector 0.0 1.0 z4)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))))
|
|
|
|
(define polys1012 (rotate-facet polys0121))
|
|
(define polys2101 (rotate-facet polys1012))
|
|
(define polys1210 (rotate-facet polys2101))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; 6-sided saddle
|
|
|
|
(define (polys10100 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))
|
|
(list (vector 1.0 1.0 z3)
|
|
(vector (unsafe-solve-t za z4 z3) 1.0 za)
|
|
(vector 1.0 (unsafe-solve-t za z2 z3) za))))
|
|
|
|
(define (polys10101 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector 1.0 (unsafe-solve-t za z2 z3) za)
|
|
(vector 1.0 1.0 z3)
|
|
(vector (unsafe-solve-t za z4 z3) 1.0 za)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))))
|
|
|
|
(define (polys1010 za zb z1 z2 z3 z4)
|
|
(define z5 (unsafe-flavg4 z1 z2 z3 z4))
|
|
(cond [(z5 . unsafe-fl< . za) (polys10100 za zb z1 z2 z3 z4)]
|
|
; (z5 . >= . zb) is impossible
|
|
[else (polys10101 za zb z1 z2 z3 z4)]))
|
|
|
|
(define polys0101 (rotate-facet polys1010))
|
|
|
|
(define (polys1212-2 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))
|
|
(list (vector 1.0 1.0 z3)
|
|
(vector (unsafe-solve-t zb z4 z3) 1.0 zb)
|
|
(vector 1.0 (unsafe-solve-t zb z2 z3) zb))))
|
|
|
|
(define (polys1212-1 za zb z1 z2 z3 z4)
|
|
(list (list (vector 0.0 0.0 z1)
|
|
(vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 1.0 (unsafe-solve-t zb z2 z3) zb)
|
|
(vector 1.0 1.0 z3)
|
|
(vector (unsafe-solve-t zb z4 z3) 1.0 zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))))
|
|
|
|
(define (polys1212 za zb z1 z2 z3 z4)
|
|
(define z5 (unsafe-flavg4 z1 z2 z3 z4))
|
|
(cond [(z5 . unsafe-fl>= . zb) (polys1212-2 za zb z1 z2 z3 z4)]
|
|
; (z5 . < . za) is impossible
|
|
[else (polys1212-1 za zb z1 z2 z3 z4)]))
|
|
|
|
(define polys2121 (rotate-facet polys1212))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; 7-sided saddle
|
|
|
|
(define (polys0212-1 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 1.0 (unsafe-solve-t zb z2 z3) zb)
|
|
(vector 1.0 1.0 z3)
|
|
(vector (unsafe-solve-t zb z4 z3) 1.0 zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))))
|
|
|
|
(define (polys0212-2 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))
|
|
(list (vector 1.0 (unsafe-solve-t zb z2 z3) zb)
|
|
(vector 1.0 1.0 z3)
|
|
(vector (unsafe-solve-t zb z4 z3) 1.0 zb))))
|
|
|
|
(define (polys0212 za zb z1 z2 z3 z4)
|
|
(define z5 (unsafe-flavg4 z1 z2 z3 z4))
|
|
(cond [(z5 . unsafe-fl< . zb) (polys0212-1 za zb z1 z2 z3 z4)]
|
|
; handling (z5 . < . za) separately results in a non-convex polygon
|
|
[else (polys0212-2 za zb z1 z2 z3 z4)]))
|
|
|
|
(define polys2021 (rotate-facet polys0212))
|
|
(define polys1202 (rotate-facet polys2021))
|
|
(define polys2120 (rotate-facet polys1202))
|
|
|
|
(define (polys2010-1 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector 1.0 (unsafe-solve-t za z2 z3) za)
|
|
(vector 1.0 1.0 z3)
|
|
(vector (unsafe-solve-t za z4 z3) 1.0 za)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))))
|
|
|
|
(define (polys2010-0 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))
|
|
(list (vector 1.0 (unsafe-solve-t za z2 z3) za)
|
|
(vector 1.0 1.0 z3)
|
|
(vector (unsafe-solve-t za z4 z3) 1.0 za))))
|
|
|
|
(define (polys2010 za zb z1 z2 z3 z4)
|
|
(define z5 (unsafe-flavg4 z1 z2 z3 z4))
|
|
(cond [(z5 . unsafe-fl>= . za) (polys2010-1 za zb z1 z2 z3 z4)]
|
|
; handling (z5 . >= . zb) separately results in a non-convex polygon
|
|
[else (polys2010-0 za zb z1 z2 z3 z4)]))
|
|
|
|
(define polys0201 (rotate-facet polys2010))
|
|
(define polys1020 (rotate-facet polys0201))
|
|
(define polys0102 (rotate-facet polys1020))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; 8-sided saddle
|
|
|
|
(define (polys0202-0 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 1.0 (unsafe-solve-t zb z2 z3) zb)
|
|
(vector 1.0 (unsafe-solve-t za z2 z3) za))
|
|
(list (vector 0.0 (unsafe-solve-t za z1 z4) za)
|
|
(vector (unsafe-solve-t za z4 z3) 1.0 za)
|
|
(vector (unsafe-solve-t zb z4 z3) 1.0 zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb))))
|
|
|
|
(define (polys0202-1 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 1.0 (unsafe-solve-t zb z2 z3) zb)
|
|
(vector 1.0 (unsafe-solve-t za z2 z3) za)
|
|
(vector (unsafe-solve-t za z4 z3) 1.0 za)
|
|
(vector (unsafe-solve-t zb z4 z3) 1.0 zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))))
|
|
|
|
(define (polys0202-2 za zb z1 z2 z3 z4)
|
|
(list (list (vector (unsafe-solve-t za z1 z2) 0.0 za)
|
|
(vector (unsafe-solve-t zb z1 z2) 0.0 zb)
|
|
(vector 0.0 (unsafe-solve-t zb z1 z4) zb)
|
|
(vector 0.0 (unsafe-solve-t za z1 z4) za))
|
|
(list (vector 1.0 (unsafe-solve-t zb z2 z3) zb)
|
|
(vector 1.0 (unsafe-solve-t za z2 z3) za)
|
|
(vector (unsafe-solve-t za z4 z3) 1.0 za)
|
|
(vector (unsafe-solve-t zb z4 z3) 1.0 zb))))
|
|
|
|
(define (polys0202 za zb z1 z2 z3 z4)
|
|
(define z5 (unsafe-flavg4 z1 z2 z3 z4))
|
|
(cond [(z5 . unsafe-fl< . za) (polys0202-0 za zb z1 z2 z3 z4)]
|
|
[(z5 . unsafe-fl< . zb) (polys0202-1 za zb z1 z2 z3 z4)]
|
|
[else (polys0202-2 za zb z1 z2 z3 z4)]))
|
|
|
|
(define polys2020 (rotate-facet polys0202))
|
|
|
|
#|
|
|
(printf "(define polys-dispatch-table~n")
|
|
(printf " (vector ")
|
|
(for* ([t1 (in-range 3)]
|
|
[t2 (in-range 3)]
|
|
[t3 (in-range 3)])
|
|
(printf "~n ")
|
|
(for ([t4 (in-range 3)])
|
|
(printf " polys~a~a~a~a" t1 t2 t3 t4)))
|
|
(printf "))")
|
|
|#
|
|
|
|
(define polys-dispatch-table
|
|
(vector polys0000 polys0001 polys0002
|
|
polys0010 polys0011 polys0012
|
|
polys0020 polys0021 polys0022
|
|
polys0100 polys0101 polys0102
|
|
polys0110 polys0111 polys0112
|
|
polys0120 polys0121 polys0122
|
|
polys0200 polys0201 polys0202
|
|
polys0210 polys0211 polys0212
|
|
polys0220 polys0221 polys0222
|
|
polys1000 polys1001 polys1002
|
|
polys1010 polys1011 polys1012
|
|
polys1020 polys1021 polys1022
|
|
polys1100 polys1101 polys1102
|
|
polys1110 polys1111 polys1112
|
|
polys1120 polys1121 polys1122
|
|
polys1200 polys1201 polys1202
|
|
polys1210 polys1211 polys1212
|
|
polys1220 polys1221 polys1222
|
|
polys2000 polys2001 polys2002
|
|
polys2010 polys2011 polys2012
|
|
polys2020 polys2021 polys2022
|
|
polys2100 polys2101 polys2102
|
|
polys2110 polys2111 polys2112
|
|
polys2120 polys2121 polys2122
|
|
polys2200 polys2201 polys2202
|
|
polys2210 polys2211 polys2212
|
|
polys2220 polys2221 polys2222))
|
|
|
|
(define (unsafe-heights->polys za zb z1 z2 z3 z4)
|
|
(define t1 (if (z1 . unsafe-fl< . za) 0 (if (z1 . unsafe-fl<= . zb) 1 2)))
|
|
(define t2 (if (z2 . unsafe-fl< . za) 0 (if (z2 . unsafe-fl<= . zb) 1 2)))
|
|
(define t3 (if (z3 . unsafe-fl< . za) 0 (if (z3 . unsafe-fl<= . zb) 1 2)))
|
|
(define t4 (if (z4 . unsafe-fl< . za) 0 (if (z4 . unsafe-fl<= . zb) 1 2)))
|
|
(define facet-num
|
|
(unsafe-fx+ (unsafe-fx+ (unsafe-fx+ (unsafe-fx* (unsafe-fx* (unsafe-fx* t1 3) 3) 3)
|
|
(unsafe-fx* (unsafe-fx* t2 3) 3))
|
|
(unsafe-fx* t3 3))
|
|
t4))
|
|
(define f (vector-ref polys-dispatch-table facet-num))
|
|
(f za zb z1 z2 z3 z4))
|
|
|
|
(defproc (heights->polys [xa real?] [xb real?] [ya real?] [yb real?]
|
|
[za real?] [zb real?]
|
|
[z1 real?] [z2 real?] [z3 real?] [z4 real?]
|
|
) (listof (listof (vector/c real? real? real?)))
|
|
(cond [(all inexact-real? xa xb ya yb za zb z1 z2 z3 z4)
|
|
(define polys (unsafe-heights->polys za zb z1 z2 z3 z4))
|
|
(for/list ([poly (in-list polys)])
|
|
(cond [(eq? poly 'full) (list (vector xa ya z1) (vector xb ya z2)
|
|
(vector xb yb z3) (vector xa yb z4))]
|
|
[else (for/list ([uv (in-list poly)])
|
|
(match-define (vector u v z) uv)
|
|
(vector (unsafe-unsolve-t xa xb u) (unsafe-unsolve-t ya yb v) z))]))]
|
|
[(find-failure-index real? xa xb ya yb za zb z1 z2 z3 z4)
|
|
=> (λ (i) (raise-type-error 'heights->polys "real number" i xa xb ya yb za zb z1 z2 z3 z4))]
|
|
[(= za zb z1 z2 z3 z4) (list (list (vector xa ya z1) (vector xb ya z2)
|
|
(vector xb yb z3) (vector xa yb z4)))]
|
|
[else
|
|
(let-map
|
|
(za zb z1 z2 z3 z4) inexact->exact
|
|
(define z-min (min za zb z1 z2 z3 z4))
|
|
(define z-max (max za zb z1 z2 z3 z4))
|
|
(define z-scale (- z-max z-min))
|
|
(define polys
|
|
(unsafe-heights->polys (exact->inexact (/ (- za z-min) z-scale))
|
|
(exact->inexact (/ (- zb z-min) z-scale))
|
|
(exact->inexact (/ (- z1 z-min) z-scale))
|
|
(exact->inexact (/ (- z2 z-min) z-scale))
|
|
(exact->inexact (/ (- z3 z-min) z-scale))
|
|
(exact->inexact (/ (- z4 z-min) z-scale))))
|
|
(for/list ([poly (in-list polys)])
|
|
(cond [(eq? poly 'full) (list (vector xa ya z1) (vector xb ya z2)
|
|
(vector xb yb z3) (vector xa yb z4))]
|
|
[else (for/list ([uv (in-list poly)])
|
|
(match-define (vector u v z) uv)
|
|
(vector (unsolve-t xa xb u)
|
|
(unsolve-t ya yb v)
|
|
(+ z-min (* (inexact->exact z) z-scale))))])))]))
|